zOs/war/rexx3
}¢--- A540769.WK.REXX(MAT) cre=2016-07-11 mod=2016-07-11-11.46.31 A540769 ------
/* copy mat begin ****************************************************/
sqrt: procedure expose m.
parse arg n
if n < 2 then
return n
k = 1
g = n
do while k+1 < g
m = (g + k) % 2
if m * m <= n then
k = m
else
g = m
end
return k
endProcedure sqrt
isPrime: procedure expose m.
parse arg n
if n < 2 then
return 0
if n // 2 = 0 then
return n = 2
do q=3 by 2 to sqrt(n)
if n // q = 0 then
return 0
end
return 1
endProcedure isPrime
nxPrime: procedure expose m.
parse arg n
do i = n + (\ (n // 2)) by 2
if isPrime(i) then
return i
end
endProcedure nxPrime
permut: procedure expose m.
parse arg m, p
m.m.1 = 1
do i=2 while p > 0
j = i - (p // i)
m.m.i = m.m.j
m.m.j = i
p = p % i
end
m.m.0 = i-1
return i-1
endProcedure permut
/* copy mat end ****************************************************/
}¢--- A540769.WK.REXX(MATCH) cre=2016-07-11 mod=2016-07-11-11.46.31 A540769 ----
/* copy match begin **************************************************/
/*--- wildCard matching with the following wildchars:
* 0-n chars
? 1 char
fill matched expressions instem st if st is non empty
return 1 if mask matches wert ---------------------------------*/
match: procedure expose m.
parse arg wert, mask
if symbol('m.match_m.mask') == 'VAR' then
interpret m.match_m.mask
else
interpret matchGen('MATCH_M.'mask, mask, 'm')
endProcedure match
matchGG: procedure expose m.
parse arg wert, cd, vars
interpret cd
endProcedure matchGG
matchVars: procedure expose m.
parse arg wert, mask, vars
if symbol('m.match_v.mask') == 'VAR' then
interpret m.match_v.mask
else
interpret matchGen('MATCH_V.'mask, mask, 'v')
endProcedure match
matchRep: procedure expose m.
parse arg wert, mask, mOut
vars = 'MATCH_VV'
mm = mask'\>'mOut
if symbol('m.match_r.mm') == 'VAR' then
interpret m.match_r.mm
else
interpret matchGen('MATCH_R.'mm, mask, 'r', mOut)
endProcedure matchRep
matchGen: procedure expose m.
parse arg m, mask, opt, mOut
a = matchScan(match_sM, mask)
if symbol('m.match_g') \== 'VAR' then
m.match_g = 0
if opt \== 'r' then do
r = matchgenMat(a, opt, 1, m.a.0, 0)
end
else do
m.match_g = m.match_g + 1
sub = 'MATCH_G'm.match_g
m.sub = matchgenMat(a, 'v', 1, m.a.0, 0)
o = matchScan(match_sO, mOut)
r = matchGenRep(o, m.a.wildC)
r = 'if matchGG(wert, m.'sub', vars) then return' r';' ,
'else return "";'
end
m.m = r
return r
endProcedure matchGen
matchScan: procedure expose m.
parse arg a, mask, opt
s = match_scan
call scanSrc s, mask
ax = 0
vx = 0
m.a.wildC = ''
do forever
if scanUntil(s, '*?&\') then do
if m.a.ax == 'c' then do
m.a.ax.val = m.a.ax.val || m.s.tok
end
else do
ax = ax + 1
m.a.ax = 'c'
m.a.ax.val = m.s.tok
end
end
else if scanChar(s, 1) then do
if pos(m.s.tok, '*?') > 0 then do
ax = ax + 1
vx = vx + 1
m.a.ax = m.s.tok
m.a.ax.ref = vx
m.a.wildC = m.a.wildC || m.s.tok
end
else if m.s.tok == '\' then do
call scanChar s, 1
if pos(m.s.tok, '\*?&') < 1 then
return scanErr(s, 'bad char after \')
if abbrev(m.a.ax, 'c') then
m.a.ax.val = m.a.ax.val || m.s.tok
else do
ax = ax + 1
m.a.ax = 'c'
m.a.ax.val = m.s.tok
end
end
else if m.s.tok == '&' then do
if opt \== 'r' then
call scanErr s, '& in input'
if \ scanChar(s,1) | pos(m.s.tok, 'ms123456789')<1 then
call scanErr s, 'bad & name' m.s.tok
ax = ax + 1
m.a.ax = '&'
m.a.ax.ref = m.s.tok
end
else
call scanErr s, 'bad char 1 after until'
end
else
leave
end
m.a.0 = ax
if vx \== length(m.a.wildC) then
call scanErr 'vars' m.a.wildC 'mismatches' vx
return a
endProcedure matchScan
matchGenMat: procedure expose m.
parse arg a, opt, fx, tx, minLL
ml = 0
if fx == 1 then do
do ax=1 to m.a.0
if m.a.ax == '?' then
ml = ml + 1
else if m.a.ax == 'c' then
ml = ml + length(m.a.ax.val)
m.a.minLen.ax = ml
end
end
r = ''
ret1 = ''
ret1After = ''
lO = 0
do fy=fx to tx
if m.a.fy == 'c' then do
r = r 'if substr(wert,' (1+lO)
if fy < m.a.0 then
r = r',' length(m.a.fy.val)
r = r') \==' quote(m.a.fy.val, "'") 'then return 0;'
lO = lO + length(m.a.fy.val)
end
else if m.a.fy == '?' then do
lO = lO + 1
if opt == 'v' then
ret1 = ret1 'm.vars.'m.a.fy.ref ,
'= substr(wert,' lO', 1);'
end
else if m.a.fy == '*' then
leave
else
call err 'bad match ast' a'.'fy m.a.fy
end
rO = 0
do ty=tx by -1 to fy
if m.a.ty == 'c' then do
rO = rO + length(m.a.ty.val)
r = r 'if substr(wert, length(wert) -' (rO - 1)',' ,
length(m.a.ty.val)')' ,
'\==' quote(m.a.ty.val, "'") 'then return 0;'
end
else if m.a.ty == '?' then do
rO = rO + 1
if opt == 'v' then
ret1 = ret1 'm.vars.'m.a.fy.ref ,
'= substr(wert, length(wert) -' (rO-1)', 1);'
end
else if m.a.ty == '*' then
leave
else
call err 'bad match ast' a'.'fy m.a.fy
end
if fy > ty then do /* every thing is handled with fix len */
if fx = tx & abbrev(m.a.fx, 'c') then
r = 'if wert \==' quote(m.a.fx.val, "'") ,
'then return 0;'
else
r = 'if length(wert) \==' (lO + rO) 'then return 0;' r
end
else do
myMiLe = m.a.minLen.ty
if fy > 1 then do
fq = fy -1
myMiLe = myMiLe - m.a.minLen.fq
end
if minLL < myMiLe then
r = 'if length(wert) <' myMiLe 'then return 0;' r
if fy = ty & m.a.fy == '*' then /* single * */
ret1 = ret1 'm.vars.'m.a.fy.ref ,
'= substr(wert,' (1+lO)', length(wert) -' (lO+rO)');'
else if fy < ty & abbrev(m.a.fy, '*') ,
& abbrev(m.a.ty, '*') then do
/* several variable length parts */
suMiLe = m.a.minLen.ty - m.a.minLen.fy
m.match_g = m.match_g + 1
sub = 'MATCH_G'm.match_g
m.sub = matchGenMat(a, opt, fy+1, ty, suMiLe)
if rO = 0 then
subV = 'substr(wert, lx)'
else do
r = r 'wSub = left(wert, length(wert) -' rO');'
subV = 'substr(wSub, lx)'
end
r = r 'do lx = length(wert) -' (suMiLe+rO-1) ,
'by -1 to' (lO+1)';' ,
'if \ matchGG('subV', m.'sub', vars) then' ,
'iterate;'
ret1 = ret1 'm.vars.'m.a.fy.ref '= substr(wert,' (lO+1) ,
|| ', lx -' (lO+1)');'
ret1After = 'end; return 0;'
end
else
call err 'matchGenMat bad case' a'.'fy m.a.fy a'.'ty m.a.ty
end
if opt == 'v' & fx == 1 then do
if r <> '' then
r = 'm.vars.0 = -9;' r
ret1 = ret1 'm.vars.0 =' length(m.a.wildC)';'
end
r = r ret1 'return 1;' ret1After
return r
endProcedure matchGenMat
matchGenRep: procedure expose m.
parse arg o, wildC
xQ = 0
xS = 0
do ox=1 to m.o.0
if m.o.ox == '?' then do
xQ = pos('?', wildC, xQ+1)
if xQ < 1 then
call err 'unmatchted ?' ox
m.o.ox.re2 = xQ
end
else if m.o.ox == '*' then do
xS = pos('*', wildC, xS+1)
if xS < 1 then
call err 'unmatchted *' ox
m.o.ox.re2 = xS
end
else if m.o.ox == '&' & m.o.ox.ref >> '0' then do
if m.o.ox.ref > length(wildC) then
call err '&'m.o.ox.ref 'but wildcards' wildC
xQ = m.o.ox.ref
xS = xQ
m.o.ox.re2 = xQ
end
end
r = ''
do ox=1 to m.o.0
if abbrev(m.o.ox, 'c') then
r = r '||' quote(m.o.ox.val, "'")
else if m.o.ox == '&' & m.o.ox.re2 == 's' then
r = r '|| wert'
else if m.o.ox == '&' & m.o.ox.re2 == 'm' then
r = r '||' quote(mask, "'")
else if pos(m.o.ox, '*?&') > 0 then
r = r '|| m.vars.'m.o.ox.re2
end
if r=='' then
return "''"
else
return substr(r, 5)
endProcedure matchGenRep
/* copy match end ****************************************************/
}¢--- A540769.WK.REXX(MON#DISP) cre=2011-04-13 mod=2011-04-13-22.40.59 A540769 ---
/* REXX */ 00010000
00020000
/* ----------------------------------------------------------------- */ 00030000
/* 00040000
Name : MON#DISP 00050000
Autor : Heinz Bühler, 12.10.2009 00060000
Funktion : - DISPLAY DATABASE Command für alle Partitionen 00070000
- entweder von allen Jobs, oder von einem Job 00080000
- diese Prozedur braucht eine DB2 Verbindung 00090000
00100000
Aufruf : kein direkter Aufruf, nur im Zusammenhang mit MAREC 00110000
Aufruf aus dem MON Member der Kontroll-Library mit 00120000
Option -d ¢ jobnummer ! 00130000
MAREC -s --> MARECMON --> MON#DISP 00140000
00150000
Change Activity : 00160000
V1R0 : 11.11.2009/HBD 00170000
- Ursprungsversion 00180000
00190000
*/ 00200000
/* ----------------------------------------------------------------- */ 00210000
00220000
address tso; 00230000
pgmvers = 'V1R0' 00240000
/* */ 00250000
/* übergebenen Variablen-String ausführen */ 00260000
parse arg ar.arg 00270000
interpret ar.arg 00280000
00290000
debug=1; 00300000
debug=0; 00310000
if ar.dbug then debug=1 00320000
00330000
if debug then say ">> MON#DISP "pgmvers 00340000
if debug then say ".. LIB : "lib 00350000
if debug then say ".. JOBLIB : "joblib 00360000
if debug then say ".. MONLIB : "monlib 00370000
if debug then say ".. ARGS : "args 00380000
if debug then say ".. DBSUB : "dbsub 00390000
if debug then say ".. SHOWMBR: "showmbr 00400000
if debug then say ".. ar.arg : "ar.arg 00410000
if debug then say ".. ar.help: "ar.help 00420000
if debug then say ".. ar.dbug: "ar.dbug 00430000
00440000
/* wurde eine Jobnummer mit übergeben? */ 00450000
v.jobnum='N/A' 00460000
parse upper var ar.args v1 '-D' v2 . 00470000
if debug then say '.. v1='v1' v2='v2 00480000
if datatype(v2)='NUM' then v.jobnum=v2 00490000
if debug then say '.. v.jobnum='v.jobnum 00500000
00510000
v.mvsid = mvsvar(sysname) /* S11 ... */ 00520000
v.rzid = sysvar(sysnode) /* RZ1 ... */ 00530000
v.pid = sysvar(sysuid) /* User ID */ 00540000
v.ssid = dbsub; /* DB2 SSID */ 00550000
v.fl_testmode='0'; /* flag für Testmodus (DBOF im RZ1) */ 00560000
msg_status = MSG(OFF) /* turn off msg prompt **/ 00570000
address tso "FREE F(OUTDN) " 00580000
msg_status = MSG(ON ) /* turn on msg prompt **/ 00590000
00600000
/* DB2 REXX Support anbinden */ 00610000
call init_dsnrexx ; 00620000
00630000
/* Connect zu DB2, falls DBOF im RZ1 wird zu DBAF connectet */ 00640000
if v.rzid='RZ1' & v.ssid='DBOF' then v.fl_testmode='1' 00650000
if v.fl_testmode='1' then v.ssid='DBAF' 00660000
/* call caf_connect v.ssid; */ 00670000
00680000
00690000
/* Member RECST aus der Joblib einlesen (Recovery Startzeitpunkt) */ 00700000
drop inp. 00710000
call read_input joblib'(RECST)' 00720000
00730000
/* DISPLAY DATABASE commands aufbereiten und ausführen */ 00740000
call prepare_db2_commands; 00750000
call issue_db2_commands; 00760000
00770000
00780000
/* Tablespace Status Report erstellen */ 00790000
call prepare_disdb_report 00800000
00810000
00820000
/* aufbereiteten Report in die Monlib schreiben (Member: ##REPORT) */ 00830000
00840002
call write_member monlib'('showmbr')' 00850000
/* aufbereiteten Report in die Monlib schreiben (Member: D#hhmmss) */ 00860000
mname = substr(time(normal),1,2) || substr(time(normal),4,2) 00870000
mname = mname || substr(time(normal),7,2) 00880000
call write_member monlib'(D#' || mname || ')' 00890000
00900000
/* Anzeige wird normalerweise durch MAREC gemacht */ 00910000
/* call show_member monlib'(##REPORT)' */ 00920000
00930000
00940000
/* DB2 Verbindung beenden */ 00950000
call caf_disconnect; 00960000
/* DB2 REXX Support entfernen */ 00970000
call exit_dsnrexx ; 00980000
00990000
if debug then say ">> MON#DISP "pgmvers" END" 01000000
return; 01010000
01020000
/*===================================================================*/ 01030000
01040000
01050000
01060000
01070000
/*-------------------------------------------------------------*/ 01080000
/* Prepare Summary Report; in stem outp. */ 01090000
/*-------------------------------------------------------------*/ 01100000
prepare_disdb_report: /*$proc$*/ 01110000
procedure expose v. debug inp. outp. dsnout. joblib 01120000
if debug then say 'proc: prepare_disdb_report' 01130000
01140000
i=1;o=1; 01150000
drop outp. 01160000
outp.o = ' '; o=o+1; 01170000
t = 'MASS RECOVERY TABLESPACE STATUS REPORT'; 01180000
if datatype(v.jobnum)='NUM' then do 01190000
t = t || ' for Job Nr. 'v.jobnum 01200000
end 01210000
t = t || ', ' || date(Normal)'; 'time(Normal) ; 01220000
outp.o = t ; o=o+1; 01230000
t = '--------------------------------------'; 01240000
outp.o = t ; o=o+1; 01250000
outp.o = ' '; o=o+1; 01260000
t = "Joblib='"joblib"'"; 01270000
outp.o = t ; o=o+1; 01280000
outp.o = ' '; o=o+1; 01290000
t = 'Tablespace Typ Status '; 01300000
outp.o = t ; o=o+1; 01310000
t = '--------------------------------------------------------------';01320000
outp.o = t ; o=o+1; 01330000
outp.o = ' '; o=o+1; 01340000
01350000
do i = 1 to dsnout.0 01360000
parse var dsnout.i v1 v2 v3 v4 v5 v6 v7 01370000
/* 01380000
say i': 'dsnout.i 01390000
say 'v1='v1 01400000
say 'v2='v2 01410000
say 'v3='v3 01420000
say 'v4='v4 01430000
say 'v5='v5 01440000
*/ 01450000
if v1 ='DSNT362I' then do 01460000
ddb=strip(v5) 01470000
jwrite=0 01480000
end 01490000
else do 01500000
if v1 = '--------' then do 01510000
jwrite=1 01520000
end 01530000
else do 01540000
if v1 = '*******' then do 01550000
jwrite=0 01560000
end 01570000
else do 01580000
if jwrite = 1 then do 01590000
if strip(v1)='DSNT302I' then do 01600000
x = ddb || ':' 01610000
x = x || copies(' ',32-length(x)) 01620000
x = x || "Invalid TS name (Testmode)" 01630000
outp.o = x; o=o+1 01640000
jwrite=0 01650000
end 01660000
else do 01670000
x = ddb || '.' || strip(v1) 01680000
rv = datatype(v3) 01690000
if rv = 'NUM' then do /* d.h. partition */ 01700000
x = x || '.' || strip(v3) 01710000
x = x || copies(' ',32-length(x)) 01720000
x = x || strip(v2) || ' ' 01730000
x = x || strip(v4) 01740000
end 01750000
else do 01760000
x = x || copies(' ',32-length(x)) 01770000
x = x || strip(v2) || ' ' 01780000
x = x || v3 01790000
end 01800000
outp.o = x; o=o+1 01810000
end 01820000
end 01830000
end 01840000
end 01850000
end 01860000
end /* do */ 01870000
01880000
outp.o = ' '; o=o+1; 01890000
outp.0 = o-1 01900000
01910000
if debug then say 'end proc: prepare_disdb_report ' 01920000
return 01930000
01940000
01950000
01960000
01970000
/*-------------------------------------------------------------*/ 01980000
/* DISPLAY DATABASE Commands aufbereiten */ 01990000
/*-------------------------------------------------------------*/ 02000000
prepare_db2_commands: /*$proc$*/ 02010000
procedure expose v. debug inp. inp2. joblib dsncmd. 02020000
if debug then say 'proc: prepare_db2_commands ' 02030000
02040000
if debug then say "v.fl_testmode="v.fl_testmode 02050000
if debug then say "v.jobnum="v.jobnum 02060000
02070000
/* 02080000
Command-Format: 02090000
02100000
dsncmd.1 = "-DIS DB(FI04A1A) SPACE(A005A) LIMIT(*)"; 02110000
dsncmd.2 = "-DIS DB(FI04A1A) SPACE(A010A) PART(1) LIMIT(*)"; 02120000
dsncmd.3 = "-DIS DB(FI04A1A) SPACE(A010A) PART(7) LIMIT(*)"; 02130000
dsncmd.4 = "-DIS DB(RV01A1A) SPACE(A400A) LIMIT(*)"; 02140000
dsncmd.5 = "-DIS DB(RV01A1A) SPACE(IRV100A2) LIMIT(*)"; 02150000
02160000
*/ 02170000
02180000
j=1; drop inp2.; 02190000
do i = 1 to inp.0 02200000
parse upper var inp.i jmark ' ' jnum ' ' . 02210000
if jmark='*JOB' then do 02220000
tjn=v.jobnum 02230000
jobnr = strip(jnum) 02240000
if length(tjn)<length(jobnr) then tjn='0'tjn 02250000
if length(tjn)<length(jobnr) then tjn='0'tjn 02260000
if length(tjn)<length(jobnr) then tjn='0'tjn 02270000
if length(tjn)<length(jobnr) then tjn='0'tjn 02280000
if debug then say "jobnr="jobnr', tjn='tjn 02290000
end 02300000
else do 02310000
/* falls eine Jobnummer zur Auswahl übergeben wurde */ 02320000
if datatype(v.jobnum)='NUM' then do 02330000
if tjn=jobnr then do 02340000
inp2.j=inp.i 02350000
j=j+1 02360000
end 02370000
end 02380000
/* falls keine Jobnummer zur Auswahl übergeben wurde */ 02390000
else do 02400000
inp2.j=inp.i 02410000
j=j+1 02420000
end 02430000
end 02440000
end 02450000
inp2.0=j-1 02460000
02470000
/* array inp.2 sortieren */ 02480000
call sort_inp2; 02490000
02500000
do i = 1 to inp2.0 02510000
parse upper var inp2.i jdb ' ' jtsp ' ' jpart ' ' jwhat ' ' jts 02520000
if debug then do 02530000
if jdb = 'DA234579' then say inp2.i 02540000
end 02550000
if v.fl_testmode='1' then do 02560000
if substr(jdb,7,1) = 'P' then do 02570000
jdb = substr(jdb,1,6) || 'A' || substr(jdb,8,1) 02580000
end 02590000
end 02600000
x = "-DIS DATABASE("jdb") SPACE("jtsp") " 02610000
if jpart <> 0 then x = x || "PART("jpart") " 02620000
x = x || "LIMIT(*)" 02630000
dsncmd.i = x; 02640000
if debug then say i": "dsncmd.i 02650000
end 02660000
dsncmd.0=i-1 02670000
if debug then say "Anzahl Commands "dsncmd.0 02680000
02690000
if debug then say 'end proc: prepare_db2_commands '; 02700000
return; 02710000
02720000
02730000
02740000
/*-------------------------------------------------------------*/ 02750000
/* Call DSN to execute DB2 commands */ 02760000
/*-------------------------------------------------------------*/ 02770000
issue_db2_commands: /*$proc$*/ 02780000
procedure expose v. debug dbsub dsncmd. dsnout. 02790000
if debug then say 'proc: issue_db2_commands ' 02800000
02810000
address tso; 02820000
"newstack" 02830000
02840000
x=msg(on); 02850000
do i = 1 to dsncmd.0 02860000
queue dsncmd.i 02870000
if debug then say '.. 'i': 'dsncmd.i 02880000
end 02890000
queue "END" 02900000
x=outtrap('dsnout.') 02910000
02920000
address tso "DSN SYSTEM("v.ssid")" 02930000
db2_rc=rc 02940000
if db2_rc <> 0 then say 'DSN processor RC='db2_rc 02950000
02960000
x=outtrap("OFF") 02970000
x=msg(on ); 02980000
"delstack" 02990000
03000000
if debug then say 'end proc: issue_db2_commands' 03010000
return; 03020000
03030000
03040000
03050000
03060000
/*-------------------------------------------------------------*/ 03070000
/* Array inp2. sortieren */ 03080000
/*-------------------------------------------------------------*/ 03090000
sort_inp2: procedure expose debug inp2. /*$proc$*/ 03100000
if debug then say 'proc: sort_inp2' 03110000
03120000
sorted=0; 03130000
do while sorted=0 03140000
i1=1 03150000
i2=2 03160000
sorted=1 03170000
do while i1<inp2.0 03180000
if inp2.i2 < inp2.i1 then do 03190000
x=inp2.i1 03200000
inp2.i1 = inp2.i2 03210000
inp2.i2=x 03220000
sorted=0 03230000
end 03240000
i1=i1+1 03250000
i2=i2+1 03260000
end 03270000
end 03280000
03290000
if debug then say 'end proc: sort_inp2' 03300000
return; 03310000
03320000
03330000
/*-------------------------------------------------------------*/ 03340000
/* Read Input Member in Batch Mode */ 03350000
/*-------------------------------------------------------------*/ 03360000
read_input: procedure expose debug inp. /*$proc$*/ 03370000
if debug then say 'proc: read_input' 03380000
03390000
parse upper arg dsn 03400000
03410000
address tso; 03420000
if debug then say ".. Input Dataset='"dsn"'" ; 03430000
03440000
check_dsn = Sysdsn(''''dsn'''') 03450000
If check_dsn ^= 'OK' Then do 03460000
if debug then say dsn '.. does not exist in ' || rzid || '.' 03470000
end 03480000
else do 03490000
if debug then say ".. allocating input '"dsn"' ..." ; 03500000
"ALLOC F(INPDN) DA('"dsn"') SHR " 03510000
03520000
if debug then say ".. reading "dsn"'" ; 03530000
'EXECIO * DISKR inpdn (STEM INP. FINIS' 03540000
if debug then say ".. read "inp.0" Records from '"dsn"'" 03550000
"FREE F(INPDN) " 03560000
end 03570000
03580000
if debug then say 'end proc: read_input' 03590000
return; 03600000
03610000
03620000
/*-------------------------------------------------------------*/ 03630000
/* Write Member to MON Library */ 03640000
/*-------------------------------------------------------------*/ 03650000
write_member: /*$proc$*/ 03660000
procedure expose debug outp. /*$proc$*/ 03670000
if debug then say 'proc: write_member' 03680000
03690000
parse upper arg dsn 03700000
03710000
address tso; 03720000
if debug then say ".. Output Dataset='"dsn"'" ; 03730000
03740000
if debug then say ".. allocating output ..." ; 03750000
"ALLOC F(OUTDN) DA('"dsn"') SHR " 03760000
03770000
if debug then say ".. writing "dsn"'" ; 03780000
'EXECIO * DISKW OUTDN (STEM OUTP. FINIS' 03790000
if debug then say ".. "outp.0" Records written to '"dsn"'" 03800000
"FREE F(OUTDN) " 03810000
03820000
if debug then say 'end proc: write_member' 03830000
return; 03840000
03850000
03860000
03870000
/*-------------------------------------------------------------*/ 03880000
/* Show Member in ISPF VIEW */ 03890000
/*-------------------------------------------------------------*/ 03900000
show_member: procedure expose debug outp. /*$proc$*/ 03910000
if debug then say 'proc: show_member' 03920000
03930000
address tso; 03940000
parse upper arg dsn 03950000
03960000
if debug then say ".. allocating dataset='"dsn"'" ; 03970000
"ALLOC F(OUTDN) DA('"dsn"') SHR " 03980000
03990000
/* aufrufen des ISPF EDIT Service */ 04000000
address ISPEXEC ; 04010000
"EDIT DATASET('"dsn"')" ; 04020000
04030000
"FREE F(OUTDN) " 04040000
04050000
if debug then say 'end proc: show_member' 04060000
return; 04070000
04080000
04090000
04100000
04110000
04120000
/* pad with spaces (left Side of xstring) and shorten to */ 04130000
/* 6 Bytes, adding Dimension marker */ 04140000
/* i.e. 123.5 123.5K 123.5M 3.5G adjusted right */ 04150000
npadm: 04160000
arg xstring 04170000
if datatype(xstring) <> 'NUM' then return 'error, not numeric'; 04180000
04190000
vv_temp_num = format(xstring,12,3) 04200000
vv_dim=' '; 04210000
if vv_temp_num > 1024 then do 04220000
vv_temp_num = vv_temp_num / 1024 04230000
vv_dim='K'; 04240000
end 04250000
if vv_temp_num > 1024 then do 04260000
vv_temp_num = vv_temp_num / 1024 04270000
vv_dim='M'; 04280000
end 04290000
if vv_temp_num > 1024 then do 04300000
vv_temp_num = vv_temp_num / 1024 04310000
vv_dim='G'; 04320000
end 04330000
if vv_temp_num > 1024 then do 04340000
vv_temp_num = vv_temp_num / 1024 04350000
vv_dim='T'; 04360000
end 04370000
04380000
xstring = format(vv_temp_num,4,1) || vv_dim 04390000
if length(xstring) < 7 then do 04400000
xstring = copies(' ',(7-length(xstring))) || xstring 04410000
end 04420000
return xstring; 04430000
04440000
04450000
/* pad with spaces (left Side of xstring) */ 04460000
npad: 04470000
arg xstring, xlen 04480000
if length(xstring) > xlen then do 04490000
xstring = right(xstring,xlen) 04500000
end 04510000
if length(xstring) < xlen then do 04520000
xstring = copies(' ',(xlen-length(xstring))) || xstring 04530000
end 04540000
return xstring; 04550000
04560000
04570000
/* pad with spaces (right Side of xstring) */ 04580000
xpad: 04590000
arg xstring, xlen 04600000
if length(xstring) > xlen then do 04610000
xstring = left(xstring,xlen) 04620000
end 04630000
if length(xstring) < xlen then do 04640000
xstring = xstring || copies(' ',(xlen-length(xstring))) 04650000
end 04660000
return xstring; 04670000
04680000
04690000
/*-------------------------------------------------------------------*/ 04700000
/* Differenz in Tagen zwischen Argument und heutigem Datum */ 04710000
/*-------------------------------------------------------------------*/ 04720000
calc_date_diff: 04730000
if debug then say 'proc: calc_date_diff' 04740000
04750000
parse arg backup_date 04760000
04770000
/* Prepare the SQL Statement, assign a Statement Name */ 04780000
/* backup_date Format: '2009-11-01' */ 04790000
04800000
sq1="select current date-DATE('"backup_date"')", 04810000
"from sysibm.sysdummy1" 04820000
ADDRESS DSNREXX 04830000
'EXECSQL DECLARE C1 CURSOR FOR S1' 04840000
if sqlcode <> 0 then call rep_sqlca "DECLARE C1" 04850000
'EXECSQL PREPARE S1 INTO :OUTSQLDA FROM :SQ1' 04860000
if sqlcode <> 0 then call rep_sqlca "PREPARE S1" 04870000
'EXECSQL OPEN C1' 04880000
if sqlcode <> 0 then call rep_sqlca "OPEN C1" 04890000
'EXECSQL FETCH C1 INTO :date_diff' 04900000
if (sqlcode <> 0 & sqlcode <> 100) then , 04910000
call rep_sqlca "FETCH C1" 04920000
'EXECSQL CLOSE C1' 04930000
if sqlcode <> 0 then call rep_sqlca "CLOSE C1" 04940000
ADDRESS tso 04950000
if debug then say '.. date_diff: 'date_diff 04960000
04970000
return date_diff; 04980000
04990000
05000000
/*-------------------------------------------------------------------*/ 05010000
/* DB2 COMMIT */ 05020000
/*-------------------------------------------------------------------*/ 05030000
db2_commit: 05040000
if debug then say 'proc: db2_commit' 05050000
ADDRESS DSNREXX "EXECSQL COMMIT" 05060000
if sqlcode <> 0 then call rep_sqlca "COMMIT" 05070000
return; 05080000
05090000
05100000
05110000
/*-------------------------------------------------------------------*/ 05120000
/* CAF CONNECT zu DB2 */ 05130000
/*-------------------------------------------------------------------*/ 05140000
caf_connect: 05150000
if debug then say 'proc: caf_connect' 05160000
05170000
parse upper arg connssid 05180000
05190000
if debug then say ' CONNSSID: 'connssid 05200000
/* SQL Connect to the desired DB2 Subsystem or Sharing Group */ 05210000
ADDRESS DSNREXX "CONNECT "connssid 05220000
if sqlcode <> 0 then do 05230000
say ' ' 05240000
say '.. cannot connect to DB2 system 'connssid 05250000
say ' ' 05260000
call rep_sqlca "CONNECT" 05270000
return_flag = 'Y'; 05280000
return; 05290000
end 05300000
05310000
return; 05320000
05330000
05340000
/* ----------------------------------------------------------------- */ 05350000
/* Disconnect from DB2 */ 05360000
/* ----------------------------------------------------------------- */ 05370000
caf_disconnect: 05380000
if debug then say 'proc: caf_disconnect' 05390000
/* SQL DISCONNECT */ 05400000
ADDRESS DSNREXX "DISCONNECT" 05410000
if sqlcode <> 0 then call rep_sqlca 'DISCONNECT' 05420000
return; 05430000
05440000
05450000
05460000
05470000
/*-------------------------------------------------------------------*/ 05480000
/* DB2 REXX Extensions initialisieren (DSNREXX) */ 05490000
/*-------------------------------------------------------------------*/ 05500000
init_dsnrexx: 05510000
if debug then say 'proc: init_dsnrexx' 05520000
if debug then say ' CONNSSID: 'connssid 05530000
05540000
/* check if DSNREXX functions are available */ 05550000
ADDRESS TSO 'SUBCOM DSNREXX'; 05560000
05570000
/* if not, then add DSNREXX functions to command table */ 05580000
IF RC=1 THEN S_RC = RXSUBCOM('ADD','DSNREXX','DSNREXX') 05590000
return; 05600000
05610000
05620000
05630000
/*-------------------------------------------------------------------*/ 05640000
/* DB2 REXX Extensions terminieren (DSNREXX) */ 05650000
/*-------------------------------------------------------------------*/ 05660000
exit_dsnrexx: 05670000
if debug then say 'proc: exit_dsnrexx' 05680000
05690000
/* Remove the DSNREXX Functionality from command table */ 05700000
S_RC = RXSUBCOM('DELETE','DSNREXX','DSNREXX') 05710000
return; 05720000
05730000
05740000
05750000
/* ----------------------------------------------------------------- */ 05760000
/* Report SQLCA routine */ 05770000
/* - argument: func, is a text string that shold be used to identify */ 05780000
/* the location or function within the program */ 05790000
/* - return value: none */ 05800000
/* ----------------------------------------------------------------- */ 05810000
rep_sqlca: 05820000
arg func 05830000
say '-----------------------------------' 05840000
say 'Funktion= 'func 05850000
say 'SQLCODE = 'sqlcode 05860000
say 'SQLERRM = 'sqlerrmc 05870000
say 'SQLERRP = 'sqlerrp 05880000
say 'SQLERRD = 'sqlerrd.1',' || sqlerrd.2',', 05890000
|| sqlerrd.3',' || sqlerrd.4',', 05900000
|| sqlerrd.5',' || sqlerrd.6',' 05910000
say 'SQLWARN = 'sqlwarn.0',' || sqlwarn.1',', 05920000
|| sqlwarn.2',' || sqlwarn.3',', 05930000
|| sqlwarn.4',' || sqlwarn.5',', 05940000
|| sqlwarn.6',' || sqlwarn.7',', 05950000
|| sqlwarn.8',' || sqlwarn.9',', 05960000
|| sqlwarn.10 05970000
say 'SQLSTATE= 'sqlstate 05980000
exit; 05990000
return; 06000000
06010000
}¢--- A540769.WK.REXX(MOUT) cre=2012-03-07 mod=2012-03-07-12.26.26 A540769 -----
/* copy out begin ******************************************************
out interface with say and stems
***********************************************************************/
outIni: procedure expose m.
parse arg msg
if m.out.ini == 1 then
return
m.out.ini = 1
m.out.dst = ''
return
endProcedure outIni
/*--- output a message to the current destination -------------------*/
out: procedure expose m.
parse arg msg
if m.out.ini \== 1 then
call outIni
if m.out.dst == '' then do
say msg
end
else do
st = m.out.dst
sx = m.st.0 + 1
m.st.0 = sx
m.st.sx = msg
end
return 0
endProcedure out
/*--- set a new out destination and return old one ------------------*/
outDst: procedure expose m.
parse arg d
old = m.out.dst
m.out.dst = d
return old
endProcedure outPush
/* return the contents of a string or std input */
inp2str: procedure expose m.
parse arg rdr, opt
return rdr
endProcedure inp2str
/* copy out end *****************************************************/
}¢--- A540769.WK.REXX(NAK) cre=2010-01-20 mod=2010-02-09-13.47.28 A540769 ------
/* rexx ****************************************************************
nak what fun list
fun
a allocate libraries
u create unloadLimit0 and info alt neu
i create rebind and free
l create unload load
c copy alt und transform neu lctl, listdef etc.
k copy alt lctl, listdef etc.
r check packages and create remaining rebinds
.2 list: s = show flags, = = ignore packages as bad as befo
d check unload Datasets
drop
***********************************************************************/
parse upper arg what fun list
/* fix for partial db: select ts and tb */
m.wb = 1
m.wbTs = "'A142A'," ,
"'A163A'," ,
"'A165A'," ,
"'A166A'," ,
"'A169A'," ,
"'A170A'," ,
"'A172A'," ,
"'A173A'," ,
"'A703A'," ,
"'A704A'," ,
"'A705A'," ,
"'A706A'," ,
"'A707A'," ,
"'A708A'," ,
"'A992A'," ,
"'A999A'"
m.wbTb = "'TWB142A1',",
"'TWB163A1',",
"'TWB165A1',",
"'TWB166A1',",
"'TWB169A1',",
"'TWB170A1',",
"'TWB172A1',",
"'TWB173A1',",
"'TWB703A1',",
"'TWB704A1',",
"'TWB705A1',",
"'TWB706A1',",
"'TWB707A1',",
"'TWB708A1',",
"'TWB992',",
"'TWB999A1'"
if what = '' then
parse upper value 'tst u' with what fun
call mIni
m.warn.0 = 0
if userid() = 'A540769' then
m.skels = 'A540769.wk.skels'
else
m.skels = 'ORG.U0009.B0106.KIUT23.SKELS'
m.limit = 1E11
if fun = 'DROP' then do
if substr(what, 5, 1) ^== '.' then
call err "what = 'dbSu.pref' expected not" what 'for drop'
m.dbSys = left(what, 4)
what = substr(what, 6)
m.dPre = 'DSN.DROP.'m.dbSys
call envPut 'MGMTCLAS', 'A008Y000'
m.tas3 = left(what, 2)right(what, 1)
end
else do
m.tas3 = left(what, 2)right(what, 1)
m.task = 'NAK'what
if sysvar('SYSNODE') = 'RZ1' then do
m.dbSys = 'DBAF'
newCreator = 'TSTNAKNE'
call envPut 'MGMTCLAS', 'D008Y000'
m.dPre = 'A540769.TMPNAK.'m.task
m.dPre = 'DSN.'m.task
end
else if 1 then do /* rz2 proc */
m.dbSys = 'DBOF'
newCreator = 'OA1P'
call envPut 'MGMTCLAS', 'A008Y005'
m.dPre = 'DSN.'m.task
end
else do /* transfer rz2 --> rz1 */
m.dbSys = 'DBOF'
newCreator = 'OA1P'
call envPut 'MGMTCLAS', 'D008Y000'
m.dPre = 'SHR21.DIV.P021.'m.task
end
end
nGen = m.dPre'.JCL'
if fun = 'A' then do
if list = '' then
list = '*'
cx = pos('*', list)
if cx > 0 then
list = left(list, cx-1) 'JCL LIST CALT.LCTL CNEU.LCTL' ,
'CALT.LISTDEF CNEU.LISTDEF' substr(list, cx+1)
call allocList m.dPre, list
exit
end
call adrSqlConnect m.dbSys
if fun = 'R' then do
call restartRebind list, nGen"(info)", nGen"(rebinRst)"
exit
end
if fun = 'D' then do
call checkUnloadDS nGen"(info)", m.dPre'.UNL'
exit
end
if fun = 'DROP' then do
call infoDb nGen'('what'DB)'
call infoAlt 'STDKR'
call createJb
call showAlt nGen'('what'info)'
call showSyscopy nGen'('what'SyCo)'
call alias nGen'('what'al)'
call rebind nGen'('what'rebi)', 'REBIND', 'T'
call rebind nGen'('what'free)', 'FREE', ''
call dropAlt nGen'('what'Drop)', 1
call utilList 'PDR', nGen'('what'UPDR)', 1
exit
end
if fun = 'TT' then do
call infoDb nGen'(DB)'
call transformTest
exit
end
else if fun = 'TE' then do
call testExp
exit
end
else if fun = '' | verify(fun, 'IULCKQS') > 0 then
call err 'bad fun "'fun'"'
m.igno.0 = 0
call infoDb nGen'(DB)'
if 0 then
call mShow mGetType('StemDB'), db
aOpt = 'ST'
if verify(fun, 'IU', 'm') > 0 then
aOpt = aOpt'DKR'
else if verify(fun, 'LC', 'm') > 0 then
aOpt = aOpt'D'
call infoAlt aOpt
if verify(fun, 'CUL', 'm') > 0 then do
call infoNeu nGen'(ddlNeu)'
if 0 then
call mShow mGetType('StemNN'), nn
call mapAltNeu newCreator, (verify(fun, 'U', 'm') > 0)
if 0 then
call mShow mGetType('StemTB'), tb
if 0 then
call mShow mGetType('StemNN'), nn
if 0 then
call mShow mGetType('StemJob'), jb
if 1 then
call mShow mGetType('Stem'), igno
end
else do
call createJb
if 0 then
call mShow mGetType('StemJob'), jb
end
if verify(fun, 'IU', 'm') > 0 then do
call showAlt nGen'(info)'
call showSyscopy nGen'(infoSyCo)'
call alias nGen'(alia)'
call utilList 'PDR', nGen'(utilPDR)', 1
call utilList 'COP', nGen'(copyAlt)', 1
call dropAlt nGen'(dbDropAl)'
call count nGen'(CNALT)', 1, m.limit
end
if pos('I', fun) > 0 then do
call rebind nGen'(rebind)', 'REBIND', 'T'
call rebind nGen'(freePkg)', 'FREE', ''
end
if pos('U', fun) > 0 then do
call showNeu nGen'(infoMap)'
call unload 'ULI', nGen'(unloLim0)'
call check 'CHK', nGen'(check)'
call rebind nGen'(rebind)', 'REBIND', 'TOQ'
call utilList 'COP', nGen'(copyNeu)', 0
call count nGen'(cnNeu)', 0, m.limit
end
if pos('L', fun) > 0 then do
call unload 'UNL', nGen'(unload)'
call unload 'UNL', nGen'(unloaSAV)', 'SAV'
call loadLines m.dPre'.ULI'
call load 'LOA', nGen'(load)'
end
sMbrs = 'LCTL LISTDEF PCL DBSP BOLIAL BOLIBS BOLICI',
'BOLICR BOLIPH BOLIPI BOLIRZ BOLIUE BOLIVI BOLIW7 BOLIW8'
if pos('Q', fun) > 0 then do
call ctlTransQQ
end
else if pos('C', fun) > 0 then do
call ctlSearch 'C', nGen'(infoCTL)', m.dPre'.LIST', sMbrs, m.dPre
end
if pos('K', fun) > 0 then do
call ctlSearch 'K', nGen'(infoCTL)', m.dPre'.LIST', sMbrs, m.dPre
end
if pos('S', fun) > 0 then do
call count nGen'(CNALT)', 1, m.limit
end
call adrSqlDisConnect m.dbSys
call warnWrite m.dPre'.JCL'
exit
infoAlt: procedure expose m.
parse arg opt
if pos('S', opt) > 0 then do
call infoTS
if 0 then
call mShow mGetType('StemTS'), ts
if 0 then
do x=1 to m.ts.0
say m.ts.x.db'.'m.ts.x.ts m.ts.x.bp m.ts.x.used
end
end
if pos('T', opt) > 0 then do
call mapReset crNa
call infoTB
if 0 then
call mShow mGetType('StemTB'), tb
if 0 then
do x=1 to m.tb.0
n = m.tb.x.tsNd
say m.tb.x.cr'.'m.tb.x.tb m.tb.x.db'.'m.tb.x.ts n '->' m.n
end
end
if pos('D', opt) > 0 then do
call infoDep
if 0 then
call mShow mGetType('StemDep'), dep
if 0 then
do x=1 to m.dep.0
say m.dep.x.ty m.dep.x.cr'.'m.dep.x.na,
m.dep.x.bTy m.dep.x.bCr'.'m.dep.x.bNa
end
end
if 0 then
call mShow mGetType('Stem'), igno
if pos('K', opt) > 0 then do
call infoPackage
if 0 then
call mShow mGetType('StemPK'), pk
end
if pos('R', opt) > 0 then do
call infoRI
if 0 then
call mShow mGetType('StemRI'), ri
end
return
endProcedure infoAlt
infoDB: procedure expose m.
parse arg inp
call mapReset ii, 'K'
call readDsn inp, c.
dbII = 'in ('
dbNN = 'in ('
con = ''
call mapReset(db.a2n)
call mapReset(db.n2a)
call mTypeNew 'StemDB', mTypeNew(db, '', 'ALT NEU')
m.db.0 = 0
do c=1 to c.0
dbAlt = word(c.c, 1)
dbNeu = word(c.c, 2)
if left(dbAlt, 1) <> '-' then do
dd = mAdd(db, dbAlt'->'dbNeu)
m.dd.alt = dbAlt
m.dd.neu = dbNeu
call mapPut db.a2n, dbAlt, dbNeu
call mapPut db.n2a, dbNeu, dbAlt
dbII = dbII || con || "'"dbAlt"'"
dbNN = dbNN || con || "'"dbNeu"'"
con = ', '
end
else do
call mapAdd ii, translate(dbNeu), dbNeu
end
end
m.dbIn = dbII')'
m.dbInNeu = dbNN')'
say m.db.0 'alte DB' m.dbIn', neue' m.dbInNeu
call mShow mGetType('Stem'), mapKeys(ii)
return
endProcedure infoDB
isIgnored: procedure expose m.
parse upper arg ty, qu, na
if pos(ty, 'VTA') > 0 then do
if mapHasKey(ii, 'C.'qu) then
return 1
end
if mapHasKey(ii, ty'.'qu'.'na) then
return 1
return 0
endProcedure isIgnored
infoTS: procedure expose m.
root = 'TS'
flds = DB TS NTB PARTS BP USED
if mDefIfNot(root'.'0, 0) then do
call mTypeNew 'StemTS', mTypeNew(ts, '', flds 'TBSQ')
call mapReset root
end
sqlFlds = sqlFields(flds)
if m.wb then
pp = "and name in ("m.wbTs")"
else
pp = ""
sql = "select dbName, name, nTables, partitions," ,
"bPool, float(nActive)*pgSize*1024" ,
"from sysibm.systablespace",
"where dbname" m.dbIn pp ,
"order by 1, 2 "
call adrSql 'prepare s1 from :sql'
call adrSql "declare c1 cursor for s1"
call adrSql 'open c1'
tbSQ = ''
do c=1 by 1
call adrSql 'fetch c1 into' sqlFlds
if sqlCode = 100 then
leave
call stripVars flds
if isIgnored('S', db, ts) then do
call mAdd igno, 'alt S' db'.'ts
iterate
end
used = format(used,2,3,2,0)
nd = mPutVars(mAdd(root, db'.'ts), flds 'TBSQ')
call mapAdd root, db'.'ts, nd
end
call adrSql 'close c1'
say m.root.0 'tablespaces'
return
endProcedure infoTS
infoTB: procedure expose m.
root = tb
flds = cr tb db ts
xFlds = tsNd newNd
if mDefIfNot(root'.'0, 0) then do
call mTypeNew 'StemTB', mTypeNew(tb, '', flds xflds)
call mapReset root
end
newNd = ''
sqlFlds = sqlFields(flds)
sql = "select creator, name, dbName, tsName",
"from sysibm.systables",
"where dbname" m.dbIn "and type = 'T'"
if m.wb then
sql = sql "and name in ("m.wbTb")"
call adrSql 'prepare s1 from :sql'
call adrSql "declare c1 cursor for s1"
call adrSql 'open c1'
do forever
call adrSql 'fetch c1 into' sqlFlds
if sqlCode = 100 then
leave
call stripVars flds
if isIgnored('T', cr, tb) then do
call mAdd igno, 'alt T' cr'.'tb 'in' db'.'ts
iterate
end
tsNd = mapGet('TS', db'.'ts)
nd = mPutVars(mAdd(root, cr'.'tb), flds xFlds)
m.tsNd.tbSq = m.tsNd.tbSq nd
if mapHasKey(root, tb) then
call err '??? duplicate table' cr'.'tb
else
call mapAdd root, tb, nd
call mapAdd crNa, cr'.'tb, nd
end
call adrSql 'close c1'
say m.root.0 'tables'
return
endProcedure infoTb
stripVars:
parse arg ggList
do ggX=1 to words(ggList)
ggW = word(ggList, ggX)
x=value(ggW, strip(value(ggW)))
end
return
endSubroutine stripVars
infoDep: procedure expose m.
flds = ty cr na bTy bCr bNa
if mDefIfNot(dep'.'0, 0) then
call mTypeNew 'StemDep', mTypeNew('Dep', '', flds 'NEWND ACT')
sqlFlds = sqlFields(flds)
newNd = ''
act = ''
if m.wb then
call envPut 'DBIN', m.dbin "and name in ("m.wbTb")"
else
call envPut 'DBIN', m.dbin
sql = skel2sql('nakDep')
call adrSql 'prepare s1 from :sql'
call adrSql "declare c1 cursor for s1"
call adrSql 'open c1'
do forever
call adrSql 'fetch c1 into' sqlFlds
if sqlCode = 100 then
leave
call stripVars flds
if isIgnored(ty, cr, na) then do
call mAdd igno, 'alt dep' ty cr'.'na 'from' bTy bCr'.'bNa
end
else if mapHasKey(crNa, cr'.'na) then do
qTy = 'TY'
qBTy = 'BTY'
qbCr = 'BCR'
qbNa = 'BNA'
oo = mapGet(crNa, cr'.'na)
if left(oo, 3) = 'TB.' then do
if ty = 'T' & bTy = '.' & bNa = m.oo.db then
nop /* say 'old table in dep' cr'.'na */
else
call err 'dep with name of old table' ty cr'.'na
end
else if ty ^== m.oo.qTy then
call err 'new dep' m.oo.qTy cr'.'na 'mismatches old' ,
m.oo.qTy m.oo
else if (ty == 'A'| ty == 'Y') ,
& ^ (bTy == m.oo.qBty & bCr == m.oo.qBcr ,
& bNa == m.oo.qBNa) then
call err 'dep with duplicate different al/sy' cr'.'na ,
'b' bTy bCr'.'bNa ,
'oo' m.oo.qBty m.oo.qBcr'.'m.oo.qBNa
else if 0 then
say 'skipping duplicate' cr'.'na
end
else do
nd = mPutVars(mAdd(dep, cr'.'na), flds 'NEWND' 'ACT')
call mapAdd crNa, cr'.'na, nd
end
end
call adrSql 'close c1'
say m.dep.0 'dependencies'
return
endProcedure infoDep
infoNeu: procedure expose m.
parse arg ddlNeu
flds = cr na ty for oldNd oldAl
if mDefIfNot(nn.0, 0) then do
call mapReset(nn)
call mTypeNew 'StemNN', mTypeNew('NN', '', flds)
end
oldNd = ''
oldAl = ''
r = jDsn(ddlNeu)
call jOpen r, 'r'
call scanReader scanSqlIni(s), r
lastX = 0
do forever
if lastX = m.scan.s.lineX then
if ^ scanNl(s, 1) then
leave
lastX = m.scan.s.lineX
if pos('CREATE', translate(m.scan.s.src)) < 1 then
iterate
fnd = 0
linePos = scanLinePos(s)
do while lastX = m.scan.s.lineX & ^fnd
if scanSql(scanSkip(s)) = '' then
leave
fnd = m.sqlType = 'i' & m.val == 'CREATE'
end
if ^ fnd then do
say 'no create, ignoring' linePos
iterate
end
if scanSqlId(scanSkip(s)) == '' then do
say 'no sqlId, ignoring line' lastx strip(m.scan.s.src)
iterate
end
subTy = ''
if wordPos(m.val, 'UNIQUE LARGE LOB') > 0 then do
subTy = m.val
plus = ''
if subTy = 'UNIQUE' then
plus = 'WHERE NOT NULL'
do wx=1 by 1
if scanSqlId(scanSkip(s)) == '' then
call scanErr s, 'no sqlId after create' subTy
else if m.val = word(plus, wx) then
subTy = subTy m.val
else if wx=1 | wx > words(plus) then
leave
else
call scanErr s, 'stopped in middle of' plus
end
end
ty = m.val
m.scan.s.sqlBrackets = 0
if scanSqlQuId(scanSkip(s)) == '' then
call scanErr s, 'no qualId after create' subTy ty
na = m.val
na1 = m.val.1
na2 = m.val.2
for = '-'
if ty = 'ALIAS' then do
if scanSqlId(scanSkip(s)) ^== 'FOR' then
call scanErr s, 'IN expected after create' ty
if scanSqlQuId(scanSkip(s)) == '' then
call scanErr s, 'table name expected after create' ty na
for = m.val
ty = 'A'
end
else if ty = 'INDEX' then do
if scanSqlId(scanSkip(s)) ^== 'ON' then
call scanErr s, 'IN expected after create' ty
if scanSqlQuId(scanSkip(s)) == '' then
call scanErr s, 'table name expected after create' ty na
for = m.val
ty = 'X'
end
else if ty = 'TABLE' then do
do while ^ (m.scan.s.sqlBrackets = 0 & m.sqlType = 'i' ,
& m.val == 'IN')
if scanSql(scanSkip(s)) = '' | m.tok == ';' then
call scanErr s, 'in database expected'
end
if scanSqlQuId(scanSkip(s)) == '' | m.val = 'DATABASE' then
call scanErr s, 'ts name expected after create' ty na
for = m.val
ty = 'T'
end
else if ty = 'TABLESPACE' then do
if scanSqlId(scanSkip(s)) ^== 'IN' then
call scanErr s, 'IN expected after create' ty
if scanSqlDeId(scanSkip(s)) == '' then
call scanErr s, 'db name expected after create' ty
na = m.val'.'na
ty = 'S'
end
else if ty = 'VIEW' then do
ty = 'V'
for = ''
end
if 0 then
say 'create' subTy ty 'name' na 'for' for
if for == '-' then do
end
else if isIgnored(ty, na1, na2) then do
call mAdd igno, 'neu ' ty na 'for' for
end
else do
nd = mPut(mAdd(nn, na), flds, na1, na2, ty, for)
call mapAdd nn, na, nd
end
end
call jClose r
return
endProcedure infoNeu
infoRI: procedure expose m.
flds = cr tb db ts bCr bTb bDb bTS rNa
if mDefIfNot(ri.0, 0) then
call mTypeNew 'StemRI', mTypeNew('RI', '', flds)
sql = "select r.creator, r.tbName, td.dbName, td.tsName" ,
", refTbcreator, refTbName, tr.dbName, tr.tsName, relName",
"from sysibm.sysrels r, sysibm.sysTables td, sysibm.sysTables tr",
"where r.creator = td.creator and r.tbName = td.name",
"and r.refTbcreator = tr.creator and r.reftbName = tr.name"
sql = sql "and td.dbname" m.dbIn ,
'union' sql "and tr.dbname" m.dbIn
sqlFlds = sqlFields(flds)
call adrSql 'prepare s1 from :sql'
call adrSql "declare c1 cursor for s1"
call adrSql 'open c1'
do forever
call adrSql 'fetch c1 into' sqlFlds
if sqlCode = 100 then
leave
call stripVars flds
nd = mPutVars(mAdd(ri, cr'.'tb'.'rNa), flds)
end
call adrSql 'close c1'
say m.ri.0 'references'
return
endProcedure infoRI
infoPackage: procedure expose m.
flds = timeStamp pcTimestamp type,
validate isolation valid operative owner qualifier
fldStr = collid Name version flds
flds = collid Name version conToken flds
if mDefIfNot(pk.0, 0) then do
call mTypeNew 'StemPK', mTypeNew('PK', '', flds 'ACT')
call mapReset pkMap
end
call envPut 'DBIN', m.dbIn
sql = skel2sql('nakPckg')
sqlFlds = sqlFields(flds)
call adrSql 'prepare s1 from :sql'
call adrSql "declare c1 cursor for s1"
call adrSql 'open c1'
cVa = 0
cOp = 0
act = ''
do c=1 by 1
call adrSql 'fetch c1 into' sqlFlds
if sqlCode = 100 then
leave
call stripVars fldStr
nd = mPutVars(mAdd('PK', collid'.'name), flds 'ACT')
call mapAdd pkMap, collid'.'name'.'conToken, nd
if valid = 'Y' then
cVa = cVa + 1
if operative = 'Y' then
cOp = cOp + 1
end
call adrSql 'close c1'
say (c-1) 'packages,' cVa 'valid,' cOp 'operative'
return
endProcedure infoPackage
showSyscopy: procedure expose m.
parse arg out
m.o.0 = 0
call envPut 'DBIN', m.dbIn
sql = skel2Sql('nakSysCo')
call adrSql 'prepare s1 from :sql'
call adrSql "declare c1 cursor for s1"
call adrSql 'open c1'
do c=1 by 1
call adrSql 'fetch c1 into :job, :ty, :cnt, :tst'
if sqlCode = 100 then
leave
call mAdd o, left(job, 8) left(ty, 1) right(cnt, 9) tst
end
call adrSql 'close c1'
call writeDsn out, m.o., , 1
return
endProcedure showSyscopy
skel2Sql: procedure expose m.
parse arg skel
call readDsn m.skels'('skel')', m.skel2Sql.i.
call leftSt skel2Sql.i, 72
m.skel2Sql.o.0 = 0
call envExpAll skel2Sql.o, skel2Sql.i
return catStripSt(skel2Sql.o)
endProcedure skel2Sql
catStripSt: procedure expose m.
parse arg m
r = ''
mid = ''
do x=1 to m.m.0
r = r || mid || strip(m.m.x)
mid = ' '
end
return r
endProcedure catStripSt
leftSt: procedure expose m.
parse arg m, le
do x=1 to m.m.0
m.m.x = left(m.m.x, 72)
end
return m
endProcedure leftSt
mapAltNeu: procedure expose m.
parse arg newCr, doQ
do tx=1 to m.tb.0
cc = tb'.'tx
if ^ mapHasKey(nn, newCr'.'m.cc.tb) then
call err 'old table' m.cc 'has no corr. new'
dd = mapGet(nn, newCr'.'m.cc.tb)
if ^mapHasKey(db.a2n, m.cc.db) then
call err 'old table' m.cc 'ts in bad db' m.cc.db'.'m.cc.ts
if m.dd.oldNd ^== '' then
call err 'old table' m.cc 'maps to new' m.dd ,
'which already maps to' m.dd.oldNd
nTs = m.dd.for
if mapGet(db.a2n, m.cc.db) <> left(nTs, pos('.', nTs)-1) then
/* call err 'new table' m.dd 'in wrong db' nTs wkTst????
*/ say 'new table' m.dd 'in wrong db' nTs
m.cc.newNd = dd
m.dd.oldNd = cc
end
qDep = ''
do dx=1 to m.dep.0
dd = dep'.'dx
a = m.dd.ty
if ^ mapHasKey(nn, newCr'.'m.dd.na) then do
if a <> 'A' & a <> 'Y' then
call err 'old dep' a m.dd 'has no corr. new'
m.dd.act = 'q'
qDep = qDep "or (bQualifier = '"m.dd.cr"'" ,
"and bName = '"m.dd.na"')"
iterate
end
ww = mapGet(nn, newCr'.'m.dd.na)
if a == 'V' then do
if m.ww.ty ^== 'V' then
call err 'old view' m.dd 'maps to' m.ww.ty m.ww
if m.ww.oldNd ^== '' then
call err 'old view' m.dd 'maps to' m.ww.ty m.ww ,
'which is already mapped to' m.ww.oldNd
m.ww.oldNd = dd
m.dd.newNd = ww
end
else if (a == 'A' | a == 'Y') then do
if m.dd.na ^== m.dd.bNa then
call err 'bad old alias' m.dd ,
'for' m.dd.bCr'.'m.dd.bNa
m.ww.oldAl = m.ww.oldAl m.dd
end
else do
call err 'bad dep type' m.dd.ty m.dd
end
end
do nx=1 to m.nn.0
ww = nn'.'nx
if m.ww.ty = 'T' | m.ww.ty = 'V' then do
oo = m.ww.oldNd
if oo == '' then
call err 'no old for new' m.ww.ty m.ww
else if m.oo.cr ^== newCr & m.ww.oldAl = '' then
call warn 'no old alias for new obj' m.ww.ty m.ww
end
end
do otX=1 to m.tb.0
ot = 'TB.'otX
os = m.ot.tsNd
osNa = m.os
nt = m.ot.newNd
ns = m.nt.for
if symbol('os.os') ^== 'VAR' then do
os.os = ns
m.oldTs.osNa = ns
end
else if wordPos(ns, os.os) < 1 then do
os.os = os.os ns
m.oldTs.osNa = os.os
end
if symbol('ns.ns') ^== 'VAR' then do
ns.ns = os
nt.ns = nt
end
else do
if ns.ns ^== os then
call err 'new TS maps to old' ns.ns 'and' os
if wordPos(nt, nt.ns) < 1 then
nt.ns = nt.ns nt
end
end
do tx=1 to m.ts.0
tt = ts'.'tx
newSq = ''
do nsX=1 to words(os.tt)
ns = word(os.tt, nsX)
do ntx=1 to words(nt.ns)
nt = word(nt.ns, ntX)
newSq = newSq m.nt.oldNd
end
end
/* say 'ts' m.tt 'seq' m.tt.tbSq '-->' newSq */
m.tt.tbSq = newSq
end
call createJb
if doQ & qDep <> '' then do
m.o.0 = 0
call mAdd o, 'select * from RZ2.TACCT_PKGUSED where'
pre = ' '
sql = "select dCollid, dName, dConToken" ,
"from sysibm.syspackdep",
"where (not bType in ('P', 'R')) and" ,
"(" substr(qDep, 5) ")"
flds = co na ct
sqlFlds = sqlFields(flds)
call adrSql 'prepare s1 from :sql'
call adrSql "declare c1 cursor for s1"
call adrSql 'open c1'
do c=1 by 1
call adrSql 'fetch c1 into' sqlFlds
if sqlCode = 100 then
leave
call stripVars 'CO NA'
if ^ mapHasKey(pkMap, co'.'na'.'ct) then
call err 'q package' co'.'na'.'ct 'not in dep'
dd = mapGet(pkMap, co'.'na'.'ct)
if m.dd.act ^== 'q' then do
m.dd.act = 'q'
call mAdd o, pre "(PCK_ID = '"na"' AND" ,
"PCK_CONSIST_TOKEN = '"c2x(ct)"')"
pre = ' or'
end
end
call adrSql 'close c1'
call writeDsn m.dPre'.JCL(QPKGSQL)', m.o., , 1
end
return
endProcedure mapAltNeu
createJb: procedure expose m.
m.jb.0 = 0
call mTypeNew 'StemJob', mTypeNew('Job', '', 'JOB TBND')
if m.task = 'NAKCD01' then
bLim = 4E+9
else
bLim = 1E+9
tLim = 30
tbs = 0
bys = 0
jobNo = 1
do tx=1 to m.ts.0
tt = ts'.'tx
if tbs > 0 & (bys + m.tt.used > bLim ,
| tbs + m.tt.nTb > tLim) then do
jobNo = jobNo + 1
bys = 0
tbs = 0
end
if m.tt.nTb < 1 then do
call warn 'skipping ts' m.tt 'without tables' m.tt.nTb
iterate
end
bys = bys + m.tt.used
tbs = tbs + m.tt.nTb
do nsX=1 to words(m.tt.tbSq)
ot = word(m.tt.tbSq, nsX)
if symbol('m.ot') ^== 'VAR' then
call err 'oldTable' ot 'undefined in TS' m.tt tt
call mPut mAdd(jb, m.ot), 'JOB TBND', jobNo, ot
end
end
return
endProcedure createJb
showAlt: procedure expose m.
parse arg out
m.o.0 = 0
do dx=1 to m.db.0
dd = db'.'dx
call mAdd o, 'mD' left(m.dd.alt, 20)left(m.dd.neu, 20)
end
do tx=1 to m.tb.0
tt = 'TB.'tx
ss = m.tt.tsNd
l = 'oT' left(m.tt, 20)left(m.ss, 20) m.ss.used,
right(m.ss.ntb, 4) || right(m.ss.parts, 4) m.ss.bp
call mAdd o, l
end
do dx=1 to m.dep.0
dd = dep'.'dx
ww = m.dd.newNd
tp = m.dd.ty
if tp == 'V' then do
l = 'mV' left(m.dd, 20)left(m.ww, 20)
end
else if tp == 'A' | tp == 'Y' then do
l = m.dd.act
if l = '' then
l = 'd'
else if length(l) <> 1 | l = 'd' then
call err 'bad dep act' l 'for' m.dd
l = l || tp left(m.dd, 30)left(m.dd.bCr'.'m.dd.bNa, 30)
end
else do
call err 'bad ty in dep' m.dd.ty m.dd
end
call mAdd o, l
end
do rx=1 to m.ri.0
rr = ri'.'rx
if ^mapHasKey(db.a2n, m.rr.db) ,
| ^mapHasKey(db.a2n, m.rr.bDb) then
call err 'implement external ri' m.rr ,
'->' m.rr.bCr'.'m.rr.bTb
/* q = '|f' */
else if m.rr.db <> m.rr.bDb then
q = '|d'
else
q = '= '
call mAdd o, 'mR' left(m.rr.cr'.'m.rr.tb, 20) ,
|| left(m.rr.bCr'.'m.rr.bTb, 20) q m.rr.rNa
end
do px=1 to m.pk.0
p = 'PK.'px
if m.p.act = '' then
aa = 'pk'
else if (length(m.p.act) <> 1 | m.p.act = 'k') then
call err 'bad pk act' m.p.act
else
aa = m.p.act'k'
call mAdd o, aa left(m.p.collid'.'m.p.name, 17) ,
left(c2x(m.p.conToken), 16) substr(m.p.pcTimeStamp, 3,8),
left(m.p.validate, 1)left(m.p.isolation, 1),
|| left(m.p.valid, 1)left(m.p.operative, 1),
left(m.p.qualifier,8) left(m.p.owner, 8)
end
call writeDsn out, m.o., ,1
return
endProcedure showAlt
showNeu: procedure expose m.
parse arg out
m.o.0 = 0
do jx=1 to m.jb.0
jj = 'JB.'jx
tt = m.jj.tbNd
ww = m.tt.newNd
l = 'mt'right(m.jj.job, 4) left(m.tt, 20)left(m.ww, 20),
|| left(m.tt.ts, 8) m.ww.for
call mAdd o, l
end
call writeDsn out, m.o., ,1
return
endProcedure showNeu
alias: procedure expose m.
parse arg out
m.dr.0 = 0
m.cr.0 = 0
c = 0
call sqlId cr, dr
do dx=1 to m.dep.0
dd = dep'.'dx
if m.dd.ty ^== 'A' then
iterate
c = c + 1;
if c // 50 = 0 then
call commit cr, dr
call mAdd dr, 'DROP ALIAS' m.dd';'
call mAdd cr, 'CREATE ALIAS' m.dd 'FOR' m.dd.bCr'.'m.dd.bNa';'
end
call commit cr, dr
mb = dsnGetMbr(out)
call writeDsn dsnSetMbr(out, left(mb'CREATE', 8)), m.cr., ,1
call writeDsn dsnSetMbr(out, left(mb'DROPPP', 8)), m.dr., ,1
return
endProcedure alias
commit: procedure expose m.
do ax=1 to arg()
call mAdd arg(ax), 'COMMIT;'
end
return
endProcedure commit
sqlId: procedure expose m.
do ax=1 to arg()
call mAdd arg(ax), "SET CURRENT SQLID = 'S100447';"
end
return
endProcedure sqlId
unload: procedure expose m.
parse arg fun, out, suFu
call readDsn m.skels'(nakJobCa)', m.jc.
call readDsn m.skels'(nak'fun'Ut)', m.skSt.
call readDsn m.skels'(nak'fun'TS)', m.skTs.
call readDsn m.skels'(nak'fun'Tb)', m.skTb.
m.o.0 = 0
jj = ''
call envPut 'STEP', 'S01'
call envPut 'DBSYS', m.dbSys
if suFu = '' then
call envPut 'DSNPRE', m.dPre'.'fun
else
call envPut 'DSNPRE',
, overlay(suFu, m.dPre, pos('NAK', m.dPre))'.'suFu
jOld = 0
do jx=1 to m.jb.0
jj = 'JB.'jx
if oldJob <> m.jj.job then do
if jx > 1 then
say 'job' fun oldJob':' (jx-jOld) 'tables'
jOld = jx
oldJob = m.jj.job
if suFu = '' then
call envPutJOBNAME fun, oldJob
else
call envPutJOBNAME suFu, oldJob
call envExpAll o, jc
call envExpAll o, skSt
end
ot = m.jj.tbNd
os = m.ot.tsNd
if oldOs <> os then do
oldOs = os
call envPut 'TS', m.os
if m.os.parts = 0 then do
call envPut 'PARTONE', ''
call envPut 'PAUN', 'UN'
end
else do
call envPut 'PARTONE', 'PART 1'
call envPut 'PAUN', 'PA'
end
call envExpAll o, skTS
end
call envPut 'TB', m.ot
call envExpAll o, skTb
end
say 'job' fun oldJob':' (jx-jOld) 'tables'
call writeDsn out, m.o., ,1
return
endProcedure unload
loadLines: procedure expose m.
parse arg punPre
do sx=1 to m.ts.0
ss = ts'.'sx
pun = punPre'.'m.ss.db'.'m.ss.ts'.PUN'
call readDsn pun, p.
wh = ''
tbCnt = 0
do p=1 to p.0
w1 = word(p.p, 1)
if w1 = 'LOAD' then do
wh = 'l'
end
else if w1 = 'INTO' then do
if word(p.p, 2) ^== 'TABLE' then
call err 'TABLE expected in line' p 'in' pun':' p.p
w3 = word(p.p, 3)
if w3 = '' then do
p = p+1
w3 = word(p.p, 1)
end
if right(w3, 1) == '.' then do
p = p+1
w3 = w3 || word(p.p, 1)
end
dx = pos('.', w3)
if dx < 1 then
call err '. expected in w3 line' p 'in' pun':' p.p
crTb = strip(left(w3, dx-1), 'b', '"')'.',
||strip(substr(w3, dx+1), 'b', '"')
if ^ mapHasKey(crNa, crTb) then
call err 'old table' crTb 'not found' ,
'for punchLine' p 'in' pun':' p.p
tt = mapGet(crNa, crTb)
if m.tt.tsNd ^== ss then
call err 'old table' crTb ,
'wrong ts' m.tt.db'.'m.tt.ts,
'for punchLine' p 'in' pun':' p.p
if ^mDefIfNot(tt'.LO.0', 0) then
call err 'already loaded table' crTb ,
'for punchLine' p 'in' pun':' p.p
tbCnt = tbCnt + 1
if m.ss.parts == 0 then
wh = 'i'
else
wh = 'p'
end
else if w1 = 'PART' then do
if wh = 'p' then
wh = 'i'
else
call err 'PART in unpartitioned TS' m.tt.ts,
'for punchLine' p 'in' pun':' p.p
end
else if w1 = ')' then do
if strip(p.p) <> ')' then
call err 'bad ) line' p 'in' pun':' p.p
if wh <> 'i' then
call err ') in state' wh 'line' p 'in' pun':' p.p
call mAdd tt'.LO', p.p
wh = ''
end
else if wh == 'i' then do
call mAdd tt'.LO', p.p
end
else if wh == 'l' then do
if w1 ^== 'EBCDIC' then
call err 'bad line after load' ,
'in punchLine' p 'in' pun':' p.p
end
end
if wh ^== '' then
call err 'punch' pun 'ends in state' wh
if tbCnt <> m.ss.nTb then
call err tbCnt 'tables not' m.ss.nTb 'loaded for' m.ss
say 'loadCards for' tbCnt 'tables for' m.ss
end
return
endProcedure loadLines
load: procedure expose m.
parse arg fun, out
call readDsn m.skels'(nakJobCa)', m.jc.
call readDsn m.skels'(nak'fun'Ut)', m.skSt.
call readDsn m.skels'(nak'fun'OS)', m.skOs.
call readDsn m.skels'(nak'fun'TS)', m.skTs.
call readDsn m.skels'(nak'fun'Tb)', m.skTb.
m.o.0 = 0
jj = ''
call envPut 'STEP', 'S01'
call envPut 'DBSYS', m.dbSys
call envPut 'DSNPRE', m.dPre'.UNL'
do jx=1 to m.jb.0
jj = 'JB.'jx
if oldJob <> m.jj.job then do
if jx > 1 then
say 'job' fun oldJob':' (jx-jOld) 'tables'
jOld = jx
oldJob = m.jj.job
call envPutJOBNAME fun, oldJob
call envExpAll o, jc
call envExpAll o, skSt
end
ot = m.jj.tbNd
os = m.ot.tsNd
nt = m.ot.newNd
ns = m.nt.for
if oldOS ^== os then do
oldOS = os
tRec = 'TREC' || jx
call envPut 'TREC', tRec
call envPut 'OLDDB', m.os.db
call envPut 'OLDTS', m.os.ts
if m.os.parts = 0 then do
call envPut 'PAVAR',''
call envPut 'UNPARTDDN', 'INDDN' tRec
end
else do
call envPut 'PAVAR','P&PA..'
call envPut 'UNPARTDDN', ''
end
call envExpAll o, skOS
end
if oldNS ^== ns then do
oldNS = ns
call envPut 'TS', ns
call envExpAll o, skTs
end
call envPut 'TB', m.nt
if m.os.parts = 0 then do
call envPut 'PARTDDN', ''
call envExpAll o, skTb
call mAddSt o, ot'.LO'
end
else do
do px=1 to m.os.parts
call envPut 'PARTDDN', 'PART' px 'INDDN' tRec
call envExpAll o, skTb
call mAddSt o, ot'.LO'
end
end
end
say 'job' fun oldJob':' (jx-jOld) 'tables'
call writeDsn out, m.o., ,1
return
endProcedure load
check: procedure expose m.
parse arg fun, out
call readDsn m.skels'(nakJobCa)', m.jc.
call readDsn m.skels'(nak'fun'Ut)', m.skut.
call readDsn m.skels'(nak'fun'Ts)', m.skts.
call envPut 'STEP', 'S01'
call envPut 'DBSYS', m.dbSys
call envPutJOBNAME 'CHCK'
m.o.0 = 0
call envExpAll o, jc
call envExpAll o, skUt
do rx=1 to m.ri.0
rr = 'RI.'rx
cn = m.rr.cr'.'m.rr.tb
if mapHasKey(crNa, cn) then do
ot = mapGet(crNa, cn)
nt = m.ot.newNd
dbTs = m.nt.for
end
else do
call err 'implement check on foreign table'
end
if R.dbTs == 1 then
iterate
R.dbTs = 1
call envPut 'TS', dbTs
call envExpAll o, skTs
end
call writeDsn out, m.o., ,1
return
endProcedure check
utilList: procedure expose m.
parse arg fun, out, useOld
call readDsn m.skels'(nakJobCa)', m.jc.
call readDsn m.skels'(nakLstUt)', m.skUt.
call readDsn m.skels'(nakLstTs)', m.skTS.
call readDsn m.skels'(nak'fun')', m.skFu.
m.o.0 = 0
jj = ''
call envPut 'STEP', 'S01'
call envPut 'DBSYS', m.dbSys
do jx=1 to m.jb.0
jj = 'JB.'jx
if oldJob <> m.jj.job then do
if jx > 1 then
call envExpAll o, skFu
oldJob = m.jj.job
call envPutJOBNAME fun, oldJob
call envExpAll o, jc
call envExpAll o, skUt
end
ot = m.jj.tbNd
if useOld then do
os = m.ot.tsNd
ts = m.os
end
else do
nt = m.ot.newNd
ts = m.nt.for
end
if ts.ts = 1 then
iterate
ts.ts = 1
call envPut 'TS', ts
call envExpAll o, skTS
end
if jx > 1 then
call envExpAll o, skFu
call writeDsn out, m.o., ,1
return
endProcedure utilList
envPutJobname: procedure expose m.
parse arg fun, jobNo
jobChars = '0123456789ABCDEF'
if jobNo = '' then
n = 'Y' || m.tas3 || left(fun, 4, 'Z')
else
n = 'Y' || m.tas3 || left(fun, 3, 'Z') ,
|| substr(jobChars, 1 + (jobNo // length(jobChars)), 1)
call envPut 'JOBNAME', n
return
endProcedure envPutJobname
dropAlt: procedure expose m.
parse upper arg out, dropOnly
m.o.0 = 0
call mAdd o, "bist Du wirklich sicher ?"
call mAdd o, "set current sqlId = 'q100447';"
do ddx=1 to m.db.0
dd = 'DB.'ddx
call mAdd o, 'xrop database' m.dd.alt';'
call mAdd o, 'commit;'
end
call writeDsn out, m.o., ,1
if dropOnly == 1 then
return
call readDsn m.skels'(nakJobCa)', m.jc.
m.o.0 = 0
call envPutJOBNAME 'DBDROP'
call envExpAll o, jc
call dsnTep2 o, 'SDROP', out, '*'
call writeDsn m.dPre'.JCL(DBDROPAJ)', m.o., ,1
m.o.0 = 0
call envPutJobname 'DDLNEU'
call envExpAll o, jc
call dsnTep2 o, 'SCREA', m.dPre'.JCL(DDLNEU)', '*'
call writeDsn m.dPre'.JCL(DDLNEUJ)',m.o., ,1
m.o.0 = 0
call envPutJobname 'REBIND'
call envExpAll o, jc
call db2Dsn o, 'SCREA', m.dPre'.JCL(REBIND)', '*'
call writeDsn m.dPre'.JCL(REBINDJ)',m.o., ,1
return
endProcedure dropAlt
count: procedure expose m.
parse upper arg out, useOld, lim
outMb = dsnGetMbr(out)
if useOld then
call envPut 'DBIN', m.dbIn
else
call envPut 'DBIN', m.dbInNeu
if symbol('m.cnWit.0') ^== 'VAR' then do
call readDsn m.skels'(nakCnWit)', m.cnWit.
call readDsn m.skels'(nakCnRun)', m.cnRun.
call readDsn m.skels'(nakCnRts)', m.cnRts.
call readDsn m.skels'(nakCnSQL)', m.cnSQL.
call readDsn m.skels'(nakCnSQ2)', m.cnSQ2.
call readDsn m.skels'(nakJobCa)', m.cnJC.
end
m.o.0 = 0
call envExpAll o, cnWit
call envExpAll o, cnRun
m.o2.0 = 0
call splitSql o2, o
call writeDsn dsnSetMbr(out, outMb'RUN'), m.o2., ,1
m.o.0 = 0
call envExpAll o, cnWit
call envExpAll o, cnRts
m.o2.0 = 0
call splitSql o2, o
call writeDsn dsnSetMbr(out, outMb'RTS'), m.o2., ,1
m.o.0 = 0
call envExpAll o, cnWit
call envExpAll o, cnSQL
pre = ' '
if lim = '' then
lim = 9E99
ovLim = ''
do tx = 1 to m.tb.0
s = m.tb.tx.tsNd
if m.s.used > lim then do
ovLim = ovLim m.tb.tx.tb
end
else do
if useOld then do
call mAdd o, pre "select '"m.tb.tx.cr"', '"m.tb.tx.tb"'," ,
'count(*) from' m.tb.tx
end
else do
nt = m.tb.tx.newNd
call mAdd o, pre "select '"m.nt.cr"', '"m.nt.na"'," ,
'count(*) from' m.nt
end
pre = 'union'
end
end
call warn words(ovLim) 'tables over limit' lim 'of' m.tb.0':' ovLim
call envExpAll o, cnSQ2
m.o2.0 = 0
call splitSql o2, o
call writeDsn dsnSetMbr(out, outMb'SQL'), m.o2., ,1
call envPut 'DBSYS', m.dbSys
call envPutJobname outMb
m.o.0 = 0
call envExpAll o, cnJC
call dsnTep2 o, 'SRUN', m.dPre'.JCL('outMb'RUN)',
, m.dPre'.LIST('outMb'RUJ)'
call dsnTep2 o, 'SRTS', m.dPre'.JCL('outMb'RTS)',
, m.dPre'.LIST('outMb'RTJ)'
call dsnTep2 o, 'SSQL', m.dPre'.JCL('outMb'SQL)',
, m.dPre'.LIST('outMb'SQJ)'
/* call envPut 'STEP', 'SRUN'
call envPut 'DSNIN', 'DISP=SHR,DSN='m.dPre'.JCL('outMb'RUN)'
call envPut 'DSNOUT', 'DISP=SHR,DSN='m.dPre'.LIST('outMb'RUJ)'
call envExpAll o, cnTep2
call envPut 'STEP', 'SRTS'
call envPut 'DSNIN', 'DISP=SHR,DSN='m.dPre'.JCL('outMb'RTS)'
call envPut 'DSNOUT', 'DISP=SHR,DSN='m.dPre'.LIST('outMb'RTJ)'
call envExpAll o, cnTep2
call envPut 'STEP', 'SSQL'
call envPut 'DSNIN', 'DISP=SHR,DSN='m.dPre'.JCL('outMb'SQL)'
call envPut 'DSNOUT', 'DISP=SHR,DSN='m.dPre'.LIST('outMb'SQJ)'
call envExpAll o, cnTep2
*/ call writeDsn dsnSetMbr(out, outMb'J'), m.o., ,1
return
endProcedure count
dsnTep2: procedure expose m.
parse arg o, st, in ,out
if symbol('m.dsnTep2.0') ^== 'VAR' then
call readDsn m.skels'(nakTep2)' , m.dsnTep2.
call envPut 'STEP', st
call envPut 'DSNIN', 'DISP=SHR,DSN='in
if out == '*' then
call envPut 'DSNOUT', 'SYSOUT=*'
else
call envPut 'DSNOUT', 'DISP=SHR,DSN='out
call envExpAll o, dsnTep2
return
endProcedure dsnTep2
db2Dsn: procedure expose m.
parse arg o, st, in ,out
if symbol('m.db2Dsn.0') ^== 'VAR' then
call readDsn m.skels'(nakDsn)' , m.db2Dsn.
call envPut 'STEP', st
call envPut 'DSNIN', 'DISP=SHR,DSN='in
if out == '*' then
call envPut 'DSNOUT', 'SYSOUT=*'
else
call envPut 'DSNOUT', 'DISP=SHR,DSN='out
call envExpAll o, db2Dsn
return
endProcedure db2Dsn
splitSql: procedure expose m.
parse arg d, s
do sx=1 to m.s.0
l = strip(m.s.sx, 't')
do while length(l) > 71
cx = lastPos(", ", left(l, 72))
if cx < 20 then
call err 'cannot split line' l
call mAdd d, left(l, cx+1)
l = ' ' substr(l, cx+2)
end
call mAdd d, l
end
return
endProcedure splitSql
rebind: procedure expose m.
parse arg out, cmd, opt
m.o.0 = 0
spec = 0
triCmd = cmd
if pos('T', opt) > 0 then
triCmd = cmd 'TRIGGER'
do px=1 to m.pk.0
p = 'PK.'px
spec = spec+rebindOut(o, cmd, opt,
, m.p.collid, m.p.name, m.p.version,
, m.p.type, m.p.qualifier, m.p.owner)
end
if spec > 0 then do
call warn spec 'special rebinds (qualifier or owner)'
end
call writeDsn out, m.o., ,1
return
endProcedure rebind
rebindOut: procedure expose m.
parse arg o, cmd, opt, co, pk, ve, ty, qu, ow
if ty == 'T' then
t = cmd 'PACKAGE('co'.'pk')'
else
t = cmd 'PACKAGE('co'.'pk'.('strip(ve)'))'
q = ''
if pos('Q', opt) > 0 then
if qu ^= 'OA1P' then
q = 'QUAL(OA1P)'
if pos('O', opt) > 0 then
if wordPos(ow, 'S100447 CMNBATCH S100006') < 1 then
q = q 'OWNER(S100447)'
if q == '' then do
call mAdd o, t';'
return 0
end
if length(t q) <= 70 then do
call mAdd o, t q';'
end
else do
call mAdd o, t '-'
call mAdd o, ' ' q';'
end
return 1
endProcedure rebindOut
restartRebind: procedure expose m.
parse arg opt, in, out
sql = "select version,type, valid, operative",
"from sysibm.sysPackage",
"where location = '' and collid=? and name=? and conToken = ? "
call adrSql 'prepare s1 from :sql'
call adrSql "declare c1 cursor for s1"
call readDsn in, i.
m.o.0 = 0
cPk = 0
cRs = 0
do i=1 to i.0
if ^ (left(i.i, 3) == 'pk ' | left(i.i, 3) == 'qk ') then
iterate
parse var i.i 4 co '.' pk ct dt fl qu ow .
ctsq = "'" || x2c(ct) || "'"
call adrSql 'open c1 using :CO, :PK , :ctsq'
call adrSql 'fetch c1 into :fVe, :fTy, :fVd, :fOp'
rst = 0
msg = ''
if sqlCode = 100 then do
say '*** pkg not in catalog' fl co'.'pk ct
rst = 1
end
call adrSql 'fetch c1 into :fVe, :fTy, :fVd, :fOp'
if sqlCode ^= 100 then
call err 'duplicate fetch for package' co'.'pk ct
if rst then
nop
else if fVd = 'Y' & fOp = 'Y' then
nop /* say fVe fTy fVd '|| fOp 'validOp' */
else if (fVd = 'Y' | substr(fl, 3, 1) = 'N') then
msg = 'inval bef'
else if pos('=', opt) > 0 & (fVd = substr(fl, 3, 1)) then
msg = 'as before'
else
rst = 1
if pos('S', opt) > 0 then do
if rst then
msg = 'retrying '
if msg ^== '' then
say msg fTy fl '-->' fVd || fOp co'.'pk'('fVe')'
end
cPk = cPk + 1
cRs = cRs + rst
if rst then do
/* say 'retrying ' fTy fl '-->' fVd || fOp co'.'pk'('fVe')'
*/ call rebindOut o, 'REBIND', 'QO', co, pk, fVe, fTy, qu, ow
end
call adrSql 'close c1'
end
say 'retrying' cRs 'rebinds of' cPk
if m.o.0 > 0 then
call writeDsn out, m'.'o'.', , 1
return
endProcedure restartRebind
checkUnloadDS: procedure expose m.
parse arg in, pref
call readDsn in, i.
cTb = 0
cTs = 0
cDS = 0
cEr = 0
call mapReset 'TS', 'K'
do i=1 to i.0
if left(i.i, 3) ^== 'oT ' then
iterate
parse var i.i 4 cr '.' tb db '.' ts sz nTb parts bp .
call stripVars 'cr tb db ts'
if 0 then
say cr'.'tb 'in' db'.'ts 'sz' sz 'nTb' nTb 'parts' parts
dbTs = db'.'ts
cTb = cTb + 1
if mapHasKey('TS', dbTs) then do
ts.dbTs = ts.dbTs cr'.'tb
end
else do
cTs = cTs + 1
call mapAdd 'TS', dbTs, nTb
ts.dbTs = cr'.'tb
if parts = 0 then do
cEr = cEr + check1Ds(pref'.'db'.'ts'.UNL')
cDs = cDs + 1
end
else do
do px=1 to parts
cEr = cEr + check1Ds( ,
pref'.'db'.'ts'.P'right(px, 5, 0)'.UNL')
cDs = cDs + 1
end
end
end
end
say cTb 'tables,' cTs 'TS, ' cDs 'Datasets with' cEr 'errors'
k = mapKeys('TS')
do x=1 to m.k.0
dbts = m.k.x
if mapGet('TS', dbTs) ^= words(ts.dbTs) then
call err 'ts' dbTs 'should have' mapGet('TS', dbTs) ,
'tables but found' words(ts.dbTs)':' ts.dbTs
end
return
endProcedure checkUnloadDS
check1Ds: procedure expose m.
parse arg dsn
res = sysDsn("'"dsn"'")
if res ^== 'OK' then do
say dsn res
return 1
end
res = adrTso("alloc dd(ch) dsn('"dsn"')", '*')
if res <> 0 then do
say 'could not allocate' dsn
call adrTso "free dd(ch)", '*'
return 1
end
call readDDbegin ch
call readDD ch, ch., 100
if ch.0 < 100 then
say 'read' dsn ch.0
call readDDend ch
call adrTso "free dd(ch)", '*'
return 0
endProcedure check1DS
ctlSearch: procedure expose m.
parse arg fun, out, pds, mbrs, sPre
m.o.0 = 0
do mx=1 to words(mbrs)
seMb = word(mbrs, mx)
dsn = pds'('seMb')'
call readDsn dsn, l.
do l=1 to l.0 while pos('SRCH DSN:', l.l) < 1
end
cx = pos('SRCH DSN:', l.l)
if cx < 1 then
call err 'no SRCH DSN: found in' dsn
sLib = word(substr(l.l, cx+9), 1)
cnt = 0
drop f.
do l=l to l.0
cx = pos('--- STRING(S) FOUND ---', l.l)
if cx < 1 then
iterate
else if cx < 20 then
call err 'bad ...FOUND... line' l in dsn':' l.l
cMb = word(l.l, 1)
if f.cMb = 1 then do
call warn 'duplicate' cMb 'in' seMb sLib
iterate
end
f.cMb = 1
call mAdd o, 'cc' left(cMb, 9) left(seMb,9) sLib
cnt = cnt + 1
call readDsn sLib'('cMb')', m.cc.
m.ctlMbr = seMb'('cMb')'
call writeDsn sPre'.CALT.'seMb'('cMb') ::F', m.cc., , 1
if fun = 'C' then do
call transformCtl cc
call writeDsn sPre'.CNeu.'seMb'('cMb') ::F', m.cc., , 1
end
end
say cnt 'members found in' seMb sLib
end
call writeDsn out, m.o., ,1
return
endProcedure ctlSearch
ctlTransQQ: procedure expose m.
call ctlTransMM 'DSN.NAKWB.CALT.LISTNEU', 'DSN.NAKWB.CNEU.LISTNEU',
, QR055031 ,
QR055081 ,
QR055151 ,
QR058041 ,
QR058051 ,
QR058071 ,
QS055031 ,
QS055081 ,
QS055151 ,
QS058031 ,
QS058041 ,
QS058051
return
endProcedure ctlTransQQ
ctlTransMM: procedure expose m.
parse arg src, trg, mbrs
say '??mm' mbrs
do mx=1 to words(mbrs)
mb = word(mbrs,mx)
say '??' mb
call readDsn src'('mb')', m.cc.
call transformCtl cc
call writeDsn trg'('mb') ::F', m.cc., , 1
end
return
endProcedure ctlTransMM
transformTest: procedure expose m.
m.h.1 = 'wie gehts walti'
m.h.2 = 'wie ODV.walti mit imf.ersatz oder IMFDNF01DNF02ODV'
m.oldTs.TSTNAKAL.S004A = TSTNAKNE.A00004A345A
m.oldTs.TSTNAKAL.S003 = TSTNAKNE.A3A
m.h.3 = 'wie TSTNAKAL . S003 TSTNAKAL.S004A DTSTNAKAL . M014A V'
m.h.4 = 'TSTNAKAL,.| TSTNAKAL ? SP(S003 , S004A , M014A* V'
m.h.0 = 4
call mAddSt mCut(i, 0), h
call transformCtl i
do x=0 to m.h.0
say 'i' m.h.x
say 'o' m.i.x
end
exit
endProcedure transformTest
transformCtl: procedure expose m.
parse arg i
if symbol('m.tcl.0') ^== 'VAR' then do
say m.scan.tcl.name1
call scanSqlIni tcl
say m.scan.tcl.name1
say m.scan.tcl.name
if symbol('m.scan.tcl.name') ^== 'VAR' then
call err 'ini scanSql failed'
m.tcl.f.1 = 'ODV'
m.tcl.t.1 = 'OA1P'
m.tcl.f.2 = 'IMF'
m.tcl.t.2 = 'OA1P'
y = 2
do d=1 to m.db.0
y = y + 1
m.tcl.f.y = m.db.d.alt
m.tcl.t.y = m.db.d.neu
end
m.tcl.0 = y
end
do j=1 to m.i.0
lNo = substr(m.i.j, 73)
m.i.j = strip(left(m.i.j, 72), 't')
if left(m.i.j, 2) = '//' & word(m.i.j, 2) = 'JOB' then
iterate
do y=1 to m.tcl.0
cx = 1
do forever
cx = replOne(i'.'j, cx, m.tcl.f.y, m.tcl.t.y)
if cx < 1 then
leave
if y <= 2 then
iterate
call scanLine tcl, m.i.j " ' ' ' ' ' ' ' ' "
m.scan.tcl.pos = cx
call scanSql scanSkip(tcl)
if m.sqlType == '.' then do
if scanSqlDeID(scanSkip(tcl)) ^== '' then do
cx = replTS(i'.'j,
, m.scan.tcl.pos,
, length(m.tok),
, m.tcl.f.y'.'m.val)
end
end
else do
fnd = 0
do q=1 to 3 while m.scan.tcl.pos <= 73
if m.sqlType == 'i' & wordPos(m.val,
, 'SP SPACE SPACENAM') > 0 then do
fnd = 1
leave
end
call scanSql scanSkip(tcl)
end
if ^fnd then
iterate
do while m.scan.tcl.pos <= 73
if scanSqlDeID(scanSkip(tcl)) ^== '' then do
px = replTS(i'.'j,
, m.scan.tcl.pos,
, length(m.tok),
, m.tcl.f.y'.'m.val)
call scanLine tcl, m.i.j
m.scan.tcl.pos = px
end
else if scanSql(scanSkip(tcl)) == '' ,
| m.sqlType == ')' then
leave
end
end
end
end
m.i.j = strip(m.i.j, 't')
if length(m.i.j) > 72 then do
call warn 'line overFlow' length(m.i.j)m.i.j
m.i.j = left(m.i.j, 80)
end
m.i.j = left(m.i.j, 72)lNo
end
return
endProcedure transformCtl
replOne: procedure expose m.
parse arg l, x, o, n
y = pos(o, translate(m.l), x)
if y < 1 then
return 0
m.l = left(m.l, y-1) || n || substr(m.l, y + length(o))
return y + length(n)
endProcedure replOne
replTS: procedure expose m.
parse arg li, x, len, os
if symbol('m.oldTs.os') ^== 'VAR' then do
call warn 'old TS not found:' os 'in' m.ctlMbr 'line' m.li
return x
end
na = strip(m.oldTs.os)
if words(m.oldTs.os) > 1 then do
call warn 'old TS has multiple new:' os '->' nn,
'in' m.ctlMbr 'line' m.li
return x
end
na2 = strip(substr(na, pos('.', na)+1))
m.li = left(m.li, x-1-len) || na2 || substr(m.li, x)
return x - len + length(na2)
endProcedure replTS
allocList: procedure expose m.
parse upper arg nPre, list
s.1 = 'dummy member zzzzzzzz'
s.0 = 1
do wx=1 to words(list)
w = word(list, wx)
if w = 'LIST' then
call writeDsn nPre'.'w'(ZZZZZZZZ) ::F133', s., 1, 1
else
call writeDsn nPre'.'w'(ZZZZZZZZ) ::F', s., 1, 1
end
return
endProcedure allocList
err:
say '*** error:' arg(1)
call warnWrite m.dPre'.JCL'
call errA arg(1), 1
endSubroutine err
envPut: procedure expose m.
parse arg na, va
call mapPut m.vars, na, va
return
endProcedure envPut
envIsDefined: procedure expose m.
parse arg na
return mapHasKey(m.vars, na)
endProcedure envIsDefined
envGet: procedure expose m.
parse arg na
return mapGet(m.vars, na)
endProcedure envGet
envRemove: procedure expose m.
parse arg na
return mapRemove(env.vars, na)
endProcedure envRemove
envExpand: procedure expose m.
parse arg src
cx = pos('$', src)
if cx < 1 then
return strip(src, 't')
res = left(src, cx-1)
do forever
if substr(src, cx+1, 1) = '{' then do
ex = pos('}', src, cx+2)
if ex < 1 then
call err 'missing } after' substr(src, cx) 'in' src
res = res || envGet(substr(src, cx+2, ex-cx-2))
ex = ex + 1
end
else do
ex = verify(src, 'ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_',
|| 'abcdefghijklmnopqrstuvwxyz', 'n', cx+1)
if ex < 1 then
return strip(res || envGet(substr(src, cx+1)), 't')
res = res || envGet(substr(src, cx+1, ex-cx-1))
end
cx = pos('$', src, ex)
if cx < 1 then
return strip(res || substr(src, ex), 't')
res = res || substr(src, ex, cx-ex)
end
endProcedure envExpand
envExpAll: procedure expose m.
parse arg dst, src
dx = m.dst.0
do sx = 1 to m.src.0
dx = dx+1
m.dst.dx = envExpand(m.src.sx)
end
m.dst.0 = dx
return
endProcedure envExpAll
testExp: procedure
call mIni
m.xx.0 = 0
call envPut 'v1', eins
call envPut 'v2', zwei
call testExp1 'ohne variabeln'
call testExp1 '$v1 variabeln'
call testExp1 'mit $v1 iabeln'
call testExp1 'mit variab$v1'
call testExp1 '${v2}variabeln'
call testExp1 'mit vari${v1}'
call testExp1 'mit v${v2}eln'
call testExp1 'mit v${v1}eln'
call testExp1 'mit $v1 viel${v2}+$v1-vars${v2}'
call envExpAll mCut(yy, 0), xx
do x=1 to m.yy.0
say 'tesStem exp' m.yy.x'|'
end
return
endProcedure testExp
testExp1: procedure expose m.
parse arg src
call mAdd xx, src
say 'testExp src' src'|'
say 'testExp exp' envExpand(src)'|'
return
endProcedure testExp1
warn: procedure expose m.
parse arg msg
msg = strip(msg)
say '***warn:' msg
call mAdd warn, left(msg, 72)
do x=73 by 68 to length(msg)
call mAdd warn, ' 'substr(msg,x, 68)
end
return
endProcedure warn
warnWrite: procedure expose m.
parse arg lib
if 0 then do
x = 'abcdefghijklmnopqrstuvwxyz'
x = '0123456789' || x || translate(x)
call warn 'test mit langer warnung' x x x x x x x x x x x'|'
end
if m.warn.0 = 0 then do
say 'keine Warnungen'
return
end
say m.warn.0 'Warnungen'
do i=1 to 20
dsn = lib'(warn'right(i, 3, 0)')'
sd = sysDsn("'"dsn"'")
if sd = 'MEMBER NOT FOUND' then
leave
end
if sd = 'MEMBER NOT FOUND' then do
call writeDsn dsn, m.warn., , 1
end
else do
say 'error cannot write warnings' dsn ':' sd
do x=1 to m.warn.0
say m.warn.x
end
end
return
endProcedure warnWrite
/* copy scanSql begin *************************************************/
/*--- initialize with reader inRdr ----------------------------------*/
scanSqlIni: procedure expose m.
parse arg m
call scanOptions m, , '0123456789_' , '--'
m.scan.m.sqlBrackets = 0
return m
endProcedure scanSqlIni
scanSqlSeekId: procedure expose m.
parse arg m, lx, cmd
call adrEdit "cursor =" lx
do while adrEdit("seek" cmd 'word', 4) = 0 /* find each command*/
call adrEdit "(fx) = cursor"
call debug 'scanSqlSeekId after' lx 'found' cmd 'at' fx
call editReadDefine m, fx
call scanReader m, m
do while m.m.editReadLx <= fx
if scanSql(scanSkip(m)) = '' then
return -1
if m.sqlType = 'i' & m.val == cmd then
return fx
end
end
return -1
endProcedure scanSqlSeekId
ePos: procedure expose m.
parse arg m
return m.m.editReadLx m.scan.m.pos
endProcedure ePos
/*--- scan a sql token put type in m.sqltype:
'i': ordinary identifier e.g. Name
'd': delimited identifier e.g. "Delimited"
'q': quantified identifier e.g. abc."efg"
'u': integer units e.g. 8G
'n': number e.g. -234
"'": string e.g. 'abc''ef'
'' : at end
: any other character e.g. ;
----------------------------------------------------------------*/
scanSql: procedure expose m.
parse arg m
if scanAtEnd(m) then do
m.sqlType = ''
m.val = ''
end
else if scanStringML(m, "'") then
m.sqlType = "'"
else if scanSqlQuId(m) ^== '' then
nop
else if scanSqlNumUnit(m, 1) ^== '' then
nop
else if scanChar(m, 1) then do
m.sqlType = m.tok
m.val = ''
if m.tok = '(' then
m.scan.m.sqlBrackets = m.scan.m.sqlBrackets + 1
else if m.tok = ')' then
m.scan.m.sqlBrackets = m.scan.m.sqlBrackets - 1
end
else
call scanErr m, 'cannot scan sql'
return m.sqlType
endProcedure scanSql
/*--- scan an ordinary sql identifier e.g. abc, ef_12 ----------------*/
scanSqlId: procedure expose m.
parse arg m
if ^ scanName(m) then
return ''
m.val = translate(m.tok)
m.sqlType = 'i'
return m.val
endProcedure scanSqlId
/*--- scan a delimited or ordinay sql identifier ---------------------*/
scanSqlDeId: procedure expose m.
parse arg m
if scanSqlId(m) == '' then do
if scanString(m, '"') then do
val = strip(val, 't')
m.sqlType = 'd'
end
end
return m.val
endProcedure scansqlDeId
/*--- scan a qualified sql identifier --------------------------------*/
scanSqlQuId: procedure expose m.
parse arg m
if scanSqlDeId(m) == '' then
return ''
res = ''
do qx=1 by 1
m.val.qx = m.val
res = res'.'m.val
if ^ scanLit(scanSkip(m), '.') then do
m.val.0 = qx
if qx > 1 then
m.sqlType = 'q'
m.val = substr(res, 2)
return m.val
end
if scansqlDeId(scanSkip(m)) == '' then
call scanErr m, 'id expected after .'
end
endProcedure scanSqlQuId
/*--- scan a sql number ----------------------------------------------*/
scanSqlNum: procedure expose m.
parse arg m, checkEnd
c3 = left(scanLook(m, 3), 3)
p = left(c3, 1) == '+' | left(c3, 1) == '-'
p = p + (substr(c3, p + 1, 1) == '.')
if pos(substr(c3, p+1, 1), '0123456789') < 1 then
return ''
n = ''
if p > 0 & left(c3, 1) ^== '.' then do
call scanChar m, 1
n = m.tok
end
if scanVerify(m, '0123456789') then
n = n || m.tok
if scanLit(m, '.') then do
n = n'.'
if scanVerify(m, '0123456789') then
n = n || m.tok
end
c3 = left(translate(scanLook(m, 3)), 3)
if left(c3, 1) == 'E' then do
p = substr(c3, 2, 1) == '+' | substr(c3, 2, 1) == '-'
if pos(substr(c3, p+2, 1), '0123456789') > 0 then do
call scanChar m, p+1
n = n || m.tok
if scanVerify(m, '0123456789') then
n = n || m.tok
c3 = scanLook(m, 1)
end
end
if checkEnd ^= 0 then
if pos(left(c3, 1), m.scan.m.name) > 0 then
call scanErr m, 'end of number' n 'expected'
m.val = n
return n
endProcedure scanSqlNum
/*--- scan a sql number with unit K M or G ---------------------------*/
scanSqlNumUnit: procedure expose m.
parse arg m, both
nu = scanSqlNum(m, 0)
if nu = '' then
return ''
sp = scanSpaceNl(m)
af = translate(scanSqlId(m))
if wordPos(af, "K M G") > 0 then do
m.sqlType = 'u'
m.val = nu || af
return m.val
end
else if af <> '' & ^ sp then
call scanErr m, 'end of number' nu 'expected'
if both ^== 1 then
call scanErr m, 'unit K M or G expected'
else if af ^== '' then
call scanBack m, m.tok
m.sqlType = 'n'
m.val = nu
return nu
endProcedure scanSqlNumUnit
scanSqlskipBrackets: procedure expose m.
parse arg m, br
call scanSpaceNl m
if br ^== '' then
nop
else if ^ scanLit(m, '(') then
return 0
else
br = 1
do forever
t = scanSql(scanSpaceNl(m))
if t = '' | t = ';' then
call scanErr m, 'closing )'
else if t = '(' then
br = br + 1
else if t ^== ')' then
nop
else if br > 1 then
br = br - 1
else if br = 1 then
return 1
else
call scanErr m, 'skipBrackets bad br' br
end
endProcedure skipBrackets
/* copy scanSql end *************************************************/
/* copy scan begin ****************************************************
Scan: scan an input:
scanLine(m,ln) : begin scanning a single line (string)
scanReader(m,ln): begin scanning all lines of an opened reader
scanAtEnd(m) : returns whether we reached end of input
scanLit(m,lit) : scan Literal lit if present or return 0
scanChar(m,n) : scan next n characters
scanName(m) : scan a name
ScanNat(m) : scan a natural number (without sign)
scanString(m,q): scan a String with quote q. (with doubble = 1)
scanVerify(m,c,o): verify(...,c,o,...)
scanKeyValue(m): scan a key = value clause (with spaces)
scanWord(m,u) : scan a space delimited word or a string,
if u=1 then uppercase non-strings
scanErr(m, txt): error with current scan location
m is an adress, to store our state
if a scan function succeeds, the scan posititon is moved
returns: true if scanned, false otherwise
m.tok ==> last token
m.val ==> last value for scanString/Word/KeyValue
m.key ==> key for scanKeyValue
m.scan.m.pos ==> scan position
m.scan.m.src ==> scan source
***********************************************************************/
/*--- begin scanning a single line -----------------------------------*/
scanLine: procedure expose m.
parse arg m, m.scan.m.src
m.scan.m.pos = 1
call scanInit m
return m
endProcedure scanLine
/*--- switch to next line if atEnd of line or unCond=1 ---------------*/
scanNL: procedure expose m.
parse arg m, unCond
if m.scan.m.reading then do
interpret m.scan.m.scanNl
end
else do
np = 1 + length(m.scan.m.src)
if np <= m.scan.m.pos then
return 0
if unCond == 1 then nop
else if unCond ^= 0 & m.scan.m.comment ^== '' ,
& abbrev(m.scan.m.src, m.scan.m.comment) then nop
else
return 0
m.scan.m.pos = np
return 1
end
endProcedure scanNL
scanAtEnd: procedure expose m.
parse arg m, what
if m.scan.m.reading then
interpret m.scan.m.scanAtEnd
else
return m.scan.m.pos > length(m.scan.m.src)
endProcedure scanAtEnd
/*--- initialize scanner for m --------------------------------------*/
scanInit: procedure expose m.
parse arg m, rdng
m.scan.m.reading = rdng == 1
m.tok = ''
m.val = ''
m.key = ''
if symbol('m.scan.m.name') ^== 'VAR' then do
m.scan.LC = 'abcdefghijklmnopqurstuvwxyz'
m.scan.UC = 'ABCDEFGHIJKLMNOPQURSTUVWXYZ'
m.scan.Alpha = m.scan.LC || m.scan.UC
m.scan.AlNum = '0123456789' || m.scan.ALPHA
m.scan.m.Name1 = m.scan.ALPHA
m.scan.m.Name = m.scan.ALNUM
m.scan.m.comment = ''
end
return
endProcedure scanInit
/*--- set options name characters, comment characters ----------------*/
scanOptions: procedure expose m.
parse arg m, nameOne, namePlus, comm
call scanInit m
m.scan.m.comment = comm
if nameOne ^== '' then do
m.scan.m.Name1 = nameOne
m.scan.m.name = m.scan.m.name1 || '0123456789'
end
if namePlus ^== '' then
m.scan.m.name = m.scan.m.name1 || namePlus
return
endProcedure scanOptions
/*--- return the next len characters ---------------------------------*/
scanLook: procedure expose m.
parse arg m, len
nx = 1 + length(m.scan.m.src)
if len ^== '' then
if nx > m.scan.m.pos + len then
nx = m.scan.m.pos + len
return substr(m.scan.m.src, m.scan.m.pos, nx - m.scan.m.pos)
endProcedure scanLit
/*--- scan the next len characters -----------------------------------*/
scanChar: procedure expose m.
parse arg m, len
m.tok = scanLook(m, len)
m.scan.m.pos = m.scan.m.pos + length(m.tok)
return length(m.tok) > 0
endProcedure scanChar
/*--- scan the literal lit ------------------------------------------*/
scanLit: procedure expose m.
parse arg m, lit
if ^ abbrev(substr(m.scan.m.src, m.scan.m.pos), lit) then
return 0
m.scan.m.pos = m.scan.m.pos + length(lit)
m.tok = lit
return 1
endProcedure scanLit
/*--- scan a string with quote char qu -------------------------------*/
scanString: procedure expose m.
parse arg m, qu
m.val = ''
if qu = '' then
qu = "'"
if substr(m.scan.m.src, m.scan.m.pos, 1) ^== qu then
return 0
bx = m.scan.m.pos
qx = m.scan.m.pos + 1
do forever
px = pos(qu, m.scan.m.src, qx)
if px < 1 then
call scanErr m, 'ending Apostroph('qu') missing'
m.val = m.val || substr(m.scan.m.src, qx, px-qx)
if px >= length(m.scan.m.src) then
leave
else if substr(m.scan.m.src, px+1, 1) <> qu then
leave
qx = px+2
m.val = m.val || qu
end
m.tok = substr(m.scan.m.src, bx, px+1-bx)
m.scan.m.pos = px+1
return 1
endProcedure scanString
/*--- scan a string with quote char qu -------------------------------*/
scanStringML: procedure expose m.
parse arg m, qu
m.val = ''
if qu = '' then
qu = "'"
if substr(m.scan.m.src, m.scan.m.pos, 1) ^== qu then
return 0
bx = m.scan.m.pos
qx = m.scan.m.pos + 1
lCnt = 0
do forever
px = pos(qu, m.scan.m.src, qx)
if px < 1 then do
m.val = m.val || substr(m.scan.m.src, qx)
if lCnt == 9 | ^ scanNl(m, 1) then
call scanErr m, 'ending Apostroph('qu') missing multi'
qx = 1
bx = 1
end
else do
m.val = m.val || substr(m.scan.m.src, qx, px-qx)
if px >= length(m.scan.m.src) then
leave
else if substr(m.scan.m.src, px+1, 1) <> qu then
leave
qx = px+2
m.val = m.val || qu
end
end
m.tok = substr(m.scan.m.src, bx, px+1-bx)
m.scan.m.pos = px+1
return 1
endProcedure scanString
/*--- scan a Name, first char in *.name1, rest in *.name -------------*/
scanName: procedure expose m.
parse arg m
if pos(substr(m.scan.m.src, m.scan.m.pos, 1),
, m.scan.m.Name1) <= 0 then
return 0
bx = m.scan.m.pos
m.scan.m.pos = bx + 1
call scanVerify m, m.scan.m.Name
m.tok = substr(m.scan.m.src, bx, m.scan.m.pos - bx)
return 1
endProcedure scanName
/*--- scan with verify, vOpt is passed to verify ---------------------*/
scanVerify: procedure expose m.
parse arg m, alpha, vOpt
if vOpt == '' then /* empty string does not take default| */
nx = verify(m.scan.m.src, alpha, , m.scan.m.pos)
else
nx = verify(m.scan.m.src, alpha, vOpt, m.scan.m.pos)
if nx = 0 then
nx = length(m.scan.m.src) + 1
m.tok = substr(m.scan.m.src, m.scan.m.Pos, nx - m.scan.m.Pos)
if nx <= m.scan.m.pos then
return 0
m.scan.m.pos = nx
return 1
endProcedure scanVerify
/*--- scan a natural number (no sign, decpoint ...) ------------------*/
ScanNat: procedure expose m.
parse arg m
if ^ scanVerify(m, '0123456789') then
return 0
else if pos(substr(m.scan.m.src, m.scan.m.pos, 1), m.scan.m.name1) ,
> 0 then
call scanErr m, 'illegal number end'
return 1
endProcedure ScanNat
/*--- scan a word and put value into *.val
a word is either delimited by space or stopper
or a string (with single or double quotes -------*/
scanWord: procedure expose m.
parse arg m, stopper
if scanString(m, "'") then return 1
if scanString(m, """") then return 1
if ^scanVerify(m, ' 'stopper, 'm') then return 0
m.val = m.tok
return 1
endProcedure scanWord
scanBack: procedure expose m.
parse arg m, tok
if m.scan.m.pos <= length(tok) then
call scanErr sc, 'cannot back "'tok'" length'
cx = m.scan.m.pos - length(tok)
if substr(m.scan.m.src, cx, length(tok)) ^== tok then
call scanErr sc, 'cannot back "'tok'" value'
m.scan.m.pos = cx
return
endProcedure scanBack
/*--- scan a key = word phrase
put key into m.key and word into m.val -------*/
scanKeyValue: procedure expose m.
parse arg m, def
if ^ scanName(m) then
return 0
m.key = m.tok
if ^ scanLit(scanSkip(m), '=') then do
m.val = def
m.tok = ' no='
end
else if ^scanWord(scanSkip(m)) then
call scanErr(m, 'word expected after' m.key '=')
return 1
endProcedure scanKeyValue
scanLinePos: procedure expose m.
parse arg m
interpret 'return' m.scan.m.scanLinePos
endProcedure scanLinePos
/*--- emit an error with current scan pos ----------------------------*/
scanErr: procedure expose m.
parse arg m, txt
say 'scanErr' txt
say ' last token' m.tok 'scanPosition' ,
strip(left(substr(m.scan.m.src, m.scan.m.pos), 40), 't')
if m.scan.m.reading then
say scanLinePos(m)
else
say ' pos' m.scan.m.Pos 'in string' strip(m.scan.m.src, 't')
call err 'scanErr' txt
return
endProcedure scanErr
/*--- skip over spaces, nl and comments (if option set) --------------*/
scanSpaceNL: procedure expose m.
parse arg m
lastTok = m.tok
res = 0
do forever
if scanVerify(m, ' ') then nop
else if ^ scanNL(m) then leave
res = 1
end
m.tok = lastTok
return res
endProcedure scanSpaceNL
/*--- skip over space, nl and comments and return m -----------------*/
scanSkip: procedure expose m.
parse arg m
call scanSpaceNl m
return m
endProcedure scanSkip
/*--- begin scanning the lines of a reader ---------------------------*/
scanReader: procedure expose m.
parse arg m, m.scan.m.rdr
call scanInit m, 1
m.scan.m.atEnd = 0
m.scan.m.lineX = 0
m.scan.m.scanNl = 'return scanReaderNl(m, unCond)'
m.scan.m.scanAtEnd = 'return scanReaderAtEnd(m, what)'
m.scan.m.scanLinePos = "scanReaderLinePos(m)"
call scanReaderNl m, 1
return m
endProcedure scanReader
/*--- return true/false whether we are at the end of line / reader ---*/
scanReaderAtEnd: procedure expose m.
parse arg m, what
if m.scan.m.pos <= length(m.scan.m.src) then
return 0
if what == 'l' then
return 1
return m.scan.m.atEnd
endProcedure scanReaderAtEnd
scanReaderNL: procedure expose m.
parse arg m, unCond
if unCond == 1 then nop
else if unCond ^= 2 & m.scan.m.pos > length(m.scan.m.src) then nop
else if unCond ^= 0 & m.scan.m.comment ^== '' & abbrev(substr( ,
m.scan.m.src, m.scan.m.pos), m.scan.m.comment) then nop
else
return 0
if m.scan.m.atEnd then
return 0
m.scan.m.atEnd = ^ jRead(m.scan.m.rdr, 'SCAN.'m'.SRC')
if m.scan.m.atEnd then do
m.scan.m.pos = 1 + length(m.scan.m.src)
end
else do
m.scan.m.pos = 1
m.scan.m.lineX = m.scan.m.lineX + 1
end
return ^ m.scan.m.atEnd
endProcedure scanReaderNL
scanReaderLinePos: procedure expose m.
parse arg m
if m.scan.m.atEnd then
qq = 'atEnd after'
else
qq = 'pos' m.scan.m.pos 'in'
return qq 'line' m.scan.m.lineX':' strip(m.scan.m.src, 't')
endProcedure scanReaderLinePos
/* copy scan end ****************************************************/
/* copy j begin *******************************************************
the j framework
jReset
jOpen
jClose
jRead
jWrite
***********************************************************************/
jNew: procedure expose m.
if m.j.jIni ^== 1 then
call jIni
return 'J.'mInc(j)
endProcedure jNew
jFree: procedure expose m.
parse arg m
return
endProcedure jFree
jRead: procedure expose m.
parse arg m, arg
res = '?'
interpret m.j.m.read
return res
endProcedure jRead
jWrite: procedure expose m.
parse arg m, arg
interpret m.j.m.write
return
endProcedure jWrite
jReset: procedure expose m.
parse arg m, arg
interpret 'call' m.j.m.pref'Reset m, arg'
return m
endProcedure jOpen
jOpen: procedure expose m.
parse arg m, arg
interpret 'call' m.j.m.pref'Open m, arg'
return m
endProcedure jOpen
jClose: procedure expose m.
parse arg m
interpret 'call' m.j.m.pref'Close m'
m.j.m.read = 'call err "read('m') when closed"'
m.j.m.write = 'call err "write('m') when closed"'
return m
endProcedure jClose
jDefine: procedure expose m.
parse arg m, m.j.m.pref
m.j.m.read = 'call err "read('m') when closed"'
m.j.m.write = 'call err "write('m') when closed"'
return m
endProcedure jDefine
jDefRead: procedure expose m.
parse arg m, m.j.m.read
m.j.m.write = 'call err "write('m') when reading"'
return m
endProcedure jDeRead
jDefWrite: procedure expose m.
parse arg m, m.j.m.write
m.j.m.read = 'call err "read('m') when writing"'
return m
endProcedure jDeWrite
jOpt: procedure expose m.
parse arg src, alone, val
m.j.oOpt = ''
if left(src, 1) ^== '-' then do
m.j.oVal = src
return 0
end
sx = 2
if alone ^== '' then do
sx = verify(src, alone, 'n', sx)
if sx = 0 then
sx = length(src)+1
end
if length(src) < sx then
m.j.oVal = ''
else if val == '' then
call err 'bad opt "'src'" should contain only "'alone'"'
else if pos(substr(src, sx, 1), val) < 1 then
call err 'bad opt "'src'" should contain only "'alone'"' ,
'and/or 1 of "'val'" with value'
else do
sx = sx + 1
m.j.oVal = substr(src, sx)
end
m.j.oOpt = substr(src, 2, sx-2)
return 1
endProcedure jOpt
jIni: procedure expose m.
parse arg force
if m.j.jIni == 1 & force ^== 1 then
return
m.j.jIni = 1
m.j.0 = 0
m.j.defDD.0 = 0
m.j.jIn = jNew()
m.j.jOut = jNew()
call jDefine m.j.jIn, "jStdIOError "
call jDefRead m.j.jIn, "res = 0"
call jDefine m.j.jOut, "jStdIOError "
call jDefWrite m.j.jOut, "say arg"
return
endProcedure jIni
jStdIOError: procedure expose m.
parse arg fun m, arg
call err 'do not j'fun'('m',' arg') base stdIn/stdOut'
return
endSubroutine
jIn: procedure expose m.
parse arg arg
return jRead(m.j.jIn, arg)
endProcedur jIn
jOut: procedure expose m.
parse arg arg
call jWrite m.j.jOut, arg
return
endProcedure jOut
jBuf: procedure expose m.
m = jNew()
call jDefine m, "jBuf"
do ax=1 to arg()
m.j.m.buf.ax = arg(ax)
end
m.j.m.buf.0 = ax-1
return m
endProcedure jBuf
jBufReset: procedure expose m.
parse arg m
do ax=1 to arg() - 1
m.j.m.buf.ax = arg(ax+1)
end
m.j.m.buf.0 = ax-1
return m
endProcedure jBufReset
jBufOpen: procedure expose m.
parse arg m, opt
if opt == 'r' then do
call jDefRead m, "res = jBufRead(m , arg)"
m.j.m.bufIx = 0
return m
end
if opt == 'w' then
m.j.m.buf.0 = 0
else if opt ^== 'a' then
call err 'jBufOpen('m',' opt') with bad opt'
call jDefWrite m, "call mAdd 'J.'m'.BUF', arg"
return m
endProcedure jBufOpen
jBufClose:
return arg(1)
endProcedure jBufClose
jBufStem: procedure expose m.
parse arg m
return 'J.'m'.BUF'
endProcedure jBufStem
jBufRead: procedure expose m.
parse arg m, var
ix = m.j.m.bufIx + 1
if ix > m.j.m.buf.0 then
return 0
m.j.m.bufIx = ix
m.var = m.j.m.buf.ix
return 1
endProcedure jBufRead
jDsn: procedure expose m.
parse arg spec
m = jNew()
m.j.m.state = ''
call jDefine m, "jDsn"
m.j.m.defDD = 'J'mInc('J.DEFDD')
call jDsnReset m, spec
return m
endProcedure jDsn
jDsnReset: procedure expose m.
parse arg m, spec
call jClose m
m.j.m.dsnSpec = spec
return m
endProcedure jDsnReset
jDsnOpen: procedure expose m.
parse arg m, opt
call jDsnClose m
if opt == 'r' then do
aa = dsnAlloc(m.j.m.dsnSpec, 'SHR', m.j.m.defDD)
call readDDBegin word(aa, 1)
call jDefRead m, "res = jDsnRead(m , arg)"
end
else do
if opt == 'w' then
aa = dsnAlloc(m.j.m.dsnSpec, 'OLD', m.j.m.defDD)
else if opt == 'a' then
aa = dsnAlloc(m.j.m.dsnSpec, 'MOD', m.j.m.defDD)
else
call err 'jBufOpen('m',' opt') with bad opt'
call writeDDbegin word(aa, 1)
call jDefWrite m, "call jDsnWrite m , arg"
end
m.j.m.state = opt
m.j.m.dd = word(aa, 1)
m.j.m.free = subword(aa, 2)
return m
endProcedure jBufOpen
jDsnClose:
parse arg m
if m.j.m.state ^== '' then do
if m.j.m.state == 'r' then do
call readDDend m.j.m.dd
end
else do
if m.j.m.buf.0 > 0 then
call writeDD m.j.m.dd, 'M.J.'m'.BUF.'
call writeDDend m.j.m.dd
end
interpret m.j.m.free
end
m.j.m.buf.0 = 0
m.j.m.bufIx = 0
m.j.m.state = ''
m.j.m.free = ''
m.j.m.dd = ''
return m
endProcedure jDsnClose
jDsnRead: procedure expose m.
parse arg m, var
ix = m.j.m.bufIx + 1
if ix > m.j.m.buf.0 then do
res = readDD(m.j.m.dd, 'M.J.'m'.BUF.')
if ^ res then
return 0
ix = 1
end
m.j.m.bufIx = ix
m.var = m.j.m.buf.ix
return 1
endProcedure jDsnRead
jDsnWrite: procedure expose m.
parse arg m, var
ix = m.j.m.buf.0 + 1
m.j.m.buf.0 = ix
m.j.m.buf.ix = var
if ix > 99 then do
call writeDD m.j.m.dd, 'M.J.'m'.BUF.'
m.j.m.buf.0 = 0
end
return
endProcedure jDsnWrite
/* copy j end *********************************************************/
/* copy adrSql begin *************************************************/
/**********************************************************************
adrSql: execute sql thru the dsnRexx interface
***********************************************************************/
adrSql: /* no procedure, to keep variables sql... */
parse arg ggSqlStmt, ggRet, ggNo
if ggNo <> '1' then
ggSqlStmt = 'execSql' ggSqlStmt
address dsnRexx ggSqlStmt
/* say 'sqlCode' sqlCode 'rc' rc 'for' ggSqlStmt ggNo */
if rc = 0 then do
return 0
end
else if rc < 0 then do
if ggRet == '*' then nop
else if wordPos(sqlCode, ggRet) > 0 then nop
else
call err "sql rc" rc sqlmsg() ggNo
end
else if sqlWarn.0 ^== ' ' then do
say 'warning' sqlMsg() ggNo
end
return sqlCode
endSubroutine adrSql
adrSqlConnect: procedure
parse arg ggSys, ggRetCon
if adrTSO("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" ggSys, ggRetCon ,1
return
endProcedure adrSqlConnect
adrSqlDisconnect: procedure
parse arg ggRet
call adrSql "disconnect ", ggRet, 1
return
endProcedure adrSqlDisconnect
sqlFields: procedure
parse arg flds
sql = ''
do wx=1 to words(flds)
sql = sql', :'word(flds, wx)
end
if wx > 1 then
sql = substr(sql, 3)
return sql
endProcedure sqlFields
sqlMsg: /* no procedure, to keep variables sql... */
ggW = ''
do ggX=0 to 10
if sqlWarn.ggx <> '' then
ggw = ggw ggx'='sqlWarn.ggx
end
ggXX = pos(':', ggSqlStmt)
ggVV = ''
if ggXX > 0 then do
ggVV = word(substr(ggSqlStmt, ggXX + 1), 1)
ggXX = verify(ggVV, ' ,:+-*/&%?|', 'm')
if ggXX > 0 then
ggVV = left(ggVV, ggXX-1)
ggVV = 'with' ggVV '=' value(ggVV)
end
return 'sqlCode' sqlCode 'state' sqlState 'warn' ggW ,
'errMc' strip(translate(sqlerrmc, ',', 'FF'x)) ,
'stmt = ' ggSqlStmt ggVV
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 = adrTso('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
/* copy adrSql 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', "'")
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
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 -------------------------------------------*/
dsnAlloc: procedure expose m.
parse upper arg spec, disp, dd
ds = ''
if left(spec, 1) = '-' then
return strip(substr(spec, 2))
if left(spec, 1) = '&' then /* external spec is handled ok */
spec = strip(substr(spec, 2))
rest = ''
do wx=1 by 1
w = word(spec, wx)
if w = '' then
leave
if abbrev(w, '.') then do
rest = substr(subword(spec, wx), 2)
leave
end
if abbrev(w, ':') then do
nn = substr(subword(spec, wx), 2)
leave
end
if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
disp = w
else if w = 'CATALOG' then
disp = disp w
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if ds = '' then
ds = dsn2jcl(w)
else
leave
end
if dd = '' then
dd = 'DD' || ooNew()
if disp = '' | (disp = 'OLD' & pos('(', dsn) > 0) then
disp = 'SHR'
m.dsnAlloc.dsn = ds
if ds <> '' then
ds = "DSN('"ds"')"
alRc = adrTso('alloc dd('dd')' disp ds rest, '*')
if alRc ^== 0 then do
if nn = 'NN' | wordPos(disp, 'OLD SHR') < 1 ,
| sysDsn("'"m.dsnAlloc.dsn"'") ^== 'DATASET NOT FOUND' then
call err 'tsoAlloc rc' alRc 'for alloc dd('dd')' disp ds rest
say 'tsoAlloc rc' alRc 'for alloc dd('dd')' disp ds rest ,
'...trying to create'
call dsnAllocCreate m.dsnAlloc.dsn, nn
call adrTso 'alloc dd('dd')' disp ds rest
end
return dd 'call adrTso "free dd('dd')";'
endProcedure dsnAlloc
dsnAllocCreate: procedure expose m.
parse arg dsn, atts
if abbrev(atts, ':') then do
rl = substr(atts, 3)
if abbrev(atts, ':F') then do
if rl = '' then
rl = 80
atts = 'recfm(f b) lrecl('rl')' ,
'block(' (32760 - 32760 // rl)')'
end
else do
if rl = '' then
rl = 32756
atts = 'recfm('substr(atts, 2, 1) 'b) lrecl('rl')' ,
'block(32760)'
end
if pos('(', dsn) > 0 then
atts = atts 'dsntype(library) dsorg(po)' ,
"dsn('"dsnSetMbr(dsn)"')"
else
atts = atts "dsn('"dsn"')"
atts = 'new catalog' atts 'mgmtclas(s005y000) space(10, 1000)'
end
call adrTso 'alloc dd(dsnAlloc)' atts
call adrTso 'free dd(dsnAlloc)'
return
endProcedure dsnAllocCreate
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 m begin ********************************************************
stem and type handling
***********************************************************************/
/*--- increase m.a and return it (fail if undefined) -----------------*/
mInc: procedure expose m.
parse arg a
m.a.0 = m.a.0 + 1
return m.a.0
endProcedure mInc
mDefIfNot: procedure expose m.
parse arg a, put
if symbol('m.a') == 'VAR' then
return 0
m.a = put
return 1
endProcedure mDefIfNot
/*--- cut stem a to length len ---------------------------------------*/
mCut: procedure expose m.
parse arg a, len
m.a.0 = len
return a
endProcedure mCut
/*--- add one or several arguments to stem m.a -----------------------*/
mAdd: procedure expose m.
parse arg a
ix = m.a.0
do ax = 2 to arg()
ix = ix + 1
m.a.ix = arg(ax)
end
m.a.0 = ix
return a'.'ix
endProcedure mAdd
/*--- add to m.dst.* a (sub)sequence of m.src.* ----------------------*/
mAddSt: procedure expose m.
parse arg dst, src
dx = m.dst.0
do sx = 1 to m.src.0
dx = dx + 1
m.dst.dx = m.src.sx
end
m.dst.0 = dx
return
endProcedure mAddAt
/*--- put into stem a the fields flds from arguments -----------------*/
mPut: procedure expose m.
parse arg a, flds
do wx = 1 to words(flds)
f = word(flds, wx)
m.a.f = arg(wx+2)
end
return a
endProcedure mPut
/*--- put into stem a the fields flds from stem b --------------------*/
mPutSt: procedure expose m.
parse arg a, flds, b
do wx = 1 to words(flds)
f = word(flds, wx)
m.a.f = m.b.f
end
return a
endProcedure mPutSt
/*--- put into stem a the fields flds from variable pool -------------*/
mPutVars:
parse arg ggA, ggFlds
do ggWx = 1 to words(ggFlds)
ggF = word(ggFlds, ggWx)
m.ggA.ggF = value(ggF)
end
return ggA
endProcedure mPutVars
/*--- create a new map ----------------------------------------------*/
mapNew: procedure expose m.
if m.m.mIni ^== 1 then
call mIni
return mapReset(mAdd(m.map, 'map'))
endProcedure mapNew
/*--- make an empty map, opt=K means maintain a stem of keys ---------*/
mapReset: procedure expose m.
parse arg a, opt
if symbol('m.a.mapKey') == 'VAR' then
call mapClear a
m.a.mapKey = translate(opt) = 'K'
if m.a.mapKey then
m.a.mapKey.0 = 0
else
m.a.mapKey.0 = 'noMapKeys'
return a
endProcedure
mapClear: procedure expose m.
parse arg a
do kx=1 to m.a.mapKey.0
k = m.a.mapKey.kx
drop m.a.mapK2V.k m.a.mapKey.kx
end
m.a.mapKey.0 = 0
return a
endProcedure mapClear
mapKeys: procedure expose m.
parse arg a
return a'.'mapKey
endProcedure mapKeys
mapAdd: procedure expose m.
parse arg a, ky, val
if symbol('m.a.mapK2V.ky') == 'VAR' then
call err 'duplicate key in mAdd('a',' ky',' val')'
m.a.mapK2V.ky = val
if m.a.mapKey then
call mAdd a'.'mapKey, ky
return
endProcedure mapAdd
mapPut: procedure expose m.
parse arg m, ky, val
if m.m.mapKey then
if symbol('m.m.mapK2V.ky') ^== 'VAR' then
call mAdd m'.'mapKey, ky
m.m.mapK2V.ky = val
return
endProcedure mapPut
mapHasKey: procedure expose m.
parse arg m, ky
return symbol('m.m.mapK2V.ky') == 'VAR'
endProcedure mapHasKey
mapGet: procedure expose m.
parse arg m, ky
if symbol('m.m.mapK2V.ky') ^== 'VAR' then
call err 'missing key in mapGet('m',' ky')'
return m.m.mapK2V.ky
endProcedure mapGet
mapGetOr: procedure expose m.
parse arg m, ky, orDef
if symbol('m.m.mapK2V.ky') == 'VAR' then
return m.m.mapK2V.ky
else
return orDef
endProcedure mapGetOr
/*--- add to m.dst a (sub)tree of m.src.* ----------------------------*/
mGetType:
parse arg name
return mapGet(m.type, name)
endProcedure mGetType
mTypeNew: procedure expose m.
parse arg name, stem, flds, types
if m.m.ini ^== 1 then
call mIni
ty = mAdd(m.type, name)
call mapAdd m.type, name, ty
m.ty.ass = '='
m.ty.type = stem
m.ty.0 = words(flds)
m.ty.type.0 = m.ty.0
do y=1 to m.ty.0
m.ty.y = word(flds, y)
if word(types, y) = '' then
m.ty.type.y = m.type.1
else
m.ty.type.y = word(types, y)
end
return ty
endProcedure mTypeNew
mShow: procedure expose m.
parse arg ty, a, lv
if lv='' then
lv = 0
pr = a
if lv > 0 & lastPos('.', pr) > 0 then
pr = substr(pr, lastPos('.', pr))
say left('', lv)pr '=' m.a
do y=1 to m.ty.0
call mShow m.ty.type.y, a'.'m.ty.y, lv+1
end
if m.ty.type ^== '' then do
do y=1 to m.a.0
call mShow m.ty.type, a'.'y, lv+1
end
end
return
endProcedure mShow
mClear: procedure expose m.
parse arg ty, a, val
m.a = val
do y=1 to m.ty.0
call mClear m.ty.type.y, a'.'m.ty.y
end
if m.ty.type ^== '' then
m.a.0 = 0
return
endProcedure mClear
mTypeSay: procedure expose m.
parse arg t
say 'type' t'='m.t 'ass' m.t.ass '#' m.t.0 'tys' m.t.type
return
endProcedure mInit
mTypeCopy: procedure expose m.
parse arg ty, t, f
if m.ty.ass == '=' then
m.t = m.f
else
call err 'type.ass' m.ty.ass 'not supported'
do x = 1 to m.ty.0
fld = m.ty.x
call mTypeCopy m.ty.type.x, t'.'fld, f'.'fld
end
if m.ty.type ^== '' then do
do y = 1 to m.f.0
call mTypeCopy m.ty.type, t'.'y, f'.'y
end
m.t.0 = m.f.0
end
return t
endProcedure mTypeCopy
mIni: procedure expose m.
m.m.ini = 1
m.m.type.0 = 0
m.m.map.0 = 0
call mapReset m.type
call mapReset m.vars
siTy = mTypeNew('Simple')
stTy = mTypeNew('Stem', siTy)
tyTy = mTypeNew('Type', siTy, 'ASS TYS', siTy stTy)
ttTy = mTypeNew('StemType', tyTy)
return
endProcedure mIni
mTest: procedure
call mIni
siTy = mGetType('Simple')
tyTy = mGetType('Type')
ttTy = mGetType('StemType')
say 'siTy' siTy 'tyTy' tyTy 'stTyTy' ttTy
call mTypeSay siTy
call mTypeCopy siTy, nnn, siTy'.'ass
say 'm.nnn nach copy' m.nnn
call mTypeCopy tyTy, mmm, siTy
call mTypeSay mmm
call mTypeCopy tyTy, qqq, tyTy
call mTypeSay qqq
call mShow tyTy, qqq
call mShow ttTy, m.type
return
endProcedure mTest
/* copy m 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 *****************************************************/
}¢--- A540769.WK.REXX(NAKJOB) cre=2010-01-20 mod=2010-01-20-12.18.09 A540769 ---
/* rexx ****************************************************************
nak what fun
***********************************************************************/
parse upper arg what fun
if what = '' then
parse upper value 'tst 1' with what fun
call mIni
m.tas3 = left(what, 2)right(what, 1)
m.task = 'NAK'what
nPre = 'DSN.'m.task
m.skels = 'A540769.wk.skels'
nLctl = nPre'.LCTL'
if sysvar('SYSNODE') = 'RZ1' then do
m.dbSys = 'DBAF'
newCreator = 'TSTNAKNE'
call envPut 'MGMTCLAS', 'D035Y000'
m.dPre = 'A540769.TMPNAK.'m.task
end
else if 0 then do /* rz2 proc */
m.dbSys = 'DBOF'
newCreator = 'OA1P'
call envPut 'MGMTCLAS', 'D035Y000'
m.dPre = 'DSN.'m.task
end
else do /* transfer rz2 --> rz1 */
m.dbSys = 'DBOF'
newCreator = 'OA1P'
call envPut 'MGMTCLAS', 'D008Y000'
m.dPre = 'SHR21.DIV.P021.'m.task
end
if fun = 9 then do
call testExp
exit
end
m.job.0 = 0
m.jobFlds = 'JOB CR TB DB TS NCR NTB NDB NTS'
call mTypeNew 'StemJob', mTypeNew('Job', '', m.jobFlds)
call adrSqlConnect m.dbSys
if fun = 1 then do
call function1 newCreator, nPre, nLctl
end
else if fun = 2 then do
call unload 'UNL', nLctl'(unload)'
call loadLines m.dPre'.ULI'
call load 'LOA', nLctl'(load)'
end
else
call err 'bad fun' fun
call adrSqlDisConnect m.dbSys
exit
function1: procedure expose m.
parse arg newCreator, nPre, nLctl
call infoDb nLctl'(DB)'
if 0 then
call mShow mGetType('StemDB'), db
call infoTS
if 0 then
call mShow mGetType('StemTS'), ts
if 0 then
do x=1 to m.ts.0
say m.ts.x.db'.'m.ts.x.ts m.ts.x.bp m.ts.x.used
end
call mapReset crNa
call infoTB
if 0 then
call mShow mGetType('StemTB'), tb
if 0 then
do x=1 to m.tb.0
n = m.tb.x.tsNd
say m.tb.x.cr'.'m.tb.x.tb m.tb.x.db'.'m.tb.x.ts n '->' m.n
end
call infoDep
if 0 then
call mShow mGetType('StemDep'), dep
if 0 then
do x=1 to m.dep.0
say m.dep.x.ty m.dep.x.cr'.'m.dep.x.na,
m.dep.x.bTy m.dep.x.bCr'.'m.dep.x.bNa
end
call infoNeu nLctl'(ddlNeu)'
if 0 then
call mShow mGetType('StemNN'), nn
call mapAltNeu newCreator
if 0 then
call mShow mGetType('StemTB'), tb
if 0 then
call mShow mGetType('StemDep'), dep
if 0 then
call mShow mGetType('StemNN'), nn
if 1 then
call mShow mGetType('StemJob'), job
call infoRI
if 0 then
call mShow mGetType('StemRI'), ri
call showAltNeu nLctl'(info)'
call showJob nLctl'(job)'
if 1 then
call mShow mGetType('StemJob'), job
call alias nLctl'(alia)'
call unload 'ULI', nLctl'(unloLim0)'
call err 'check not yet'
call check 'CHK', nLctl'(check)'
return
endProcedure function0
infoDB: procedure expose m.
parse arg inp
call readDsn inp, c.
dbII = 'in ('
call mapReset(db.a2n)
call mapReset(db.n2a)
call mTypeNew 'StemDB', mTypeNew(db, '', 'ALT NEU')
m.db.0 = 0
do c=1 to c.0
dbAlt = word(c.c, 1)
dbNeu = word(c.c, 2)
dd = mAdd(db, dbAlt'->'dbNeu)
m.dd.alt = dbAlt
m.dd.neu = dbNeu
call mapPut db.a2n, dbAlt, dbNeu
call mapPut db.n2a, dbNeu, dbAlt
if c>1 then
dbII = dbII', '
dbII = dbII"'"dbAlt"'"
end
m.dbIn = dbII')'
say m.db.0 'db' m.dbIn
return
endProcedure infoDB
infoTS: procedure expose m.
root = 'TS'
flds = DB TS NTB PARTS BP USED
if mDefIfNot(root'.'0, 0) then do
call mTypeNew 'StemTS', mTypeNew(ts, '', flds)
call mapReset root
end
sqlFlds = sqlFields(flds)
sql = "select dbName, name, nTables, partitions," ,
"bPool, float(nActive)*pgSize*1024" ,
"from sysibm.systablespace",
"where dbname" m.dbIn ,
"order by 1, 2 "
call adrSql 'prepare s1 from :sql'
call adrSql "declare c1 cursor for s1"
call adrSql 'open c1'
do c=1 by 1
call adrSql 'fetch c1 into' sqlFlds
if sqlCode = 100 then
leave
call stripVars flds
used = format(used,2,3,2,0)
nd = mPutVars(mAdd(root, db'.'ts), flds)
call mapAdd root, db'.'ts, nd
end
call adrSql 'close c1'
say m.root.0 'tablespaces'
return
endProcedure infoTS
infoTB: procedure expose m.
root = tb
flds = cr tb db ts
xFlds = tsNd newNd
if mDefIfNot(root'.'0, 0) then do
call mTypeNew 'StemTB', mTypeNew(tb, '', flds xflds)
call mapReset root
end
newNd = ''
sqlFlds = sqlFields(flds)
sql = "select creator, name, dbName, tsName",
"from sysibm.systables",
"where dbname" m.dbIn "and type = 'T'"
call adrSql 'prepare s1 from :sql'
call adrSql "declare c1 cursor for s1"
call adrSql 'open c1'
do forever
call adrSql 'fetch c1 into' sqlFlds
if sqlCode = 100 then
leave
call stripVars flds
ts = strip(ts)
tsNd = mapGet('TS', db'.'ts)
nd = mPutVars(mAdd(root, cr'.'tb), flds xFlds)
if mapHasKey(root, tb) then
say '??? duplicate table' cr'.'tb
else
call mapAdd root, tb, nd
call mapAdd crNa, cr'.'tb, nd
end
call adrSql 'close c1'
say m.root.0 'tables'
return
endProcedure infoTb
stripVars:
parse arg ggList
do ggX=1 to words(ggList)
ggW = word(ggList, ggX)
x=value(ggW, strip(value(ggW)))
end
return
endSubroutine stripVars
infoDep: procedure expose m.
flds = ty cr na bTy bCr bNa
if mDefIfNot(dep'.'0, 0) then
call mTypeNew 'StemDep', mTypeNew('Dep', '', flds 'NEWND ACT')
sqlFlds = sqlFields(flds)
newNd = ''
act = ''
sql = ,
"with o (lev, dType, dCreator, dName, bType, bCreator, bName) as",
"( select 0, t.type, creator, name, '.', '', t.dbName",
"from sysibm.sysTables t",
"where t.dbname" m.dbIn,
"union all select o.lev+1, d.dType, d.dCreator, d.dName,",
"o.dType, o.dCreator, o.dName",
"from o, sysibm.sysviewdep d",
"where d.bcreator = o.dCreator and d.bName = o.dName",
"and o.lev < 999999",
"union all select o.lev+1, a.Type, a.creator, a.name,",
"o.dType, o.dCreator, o.dName",
"from o, sysibm.systables a",
"where a.tbCreator = o.dCreator and a.tbName = o.dName",
"and a.type = 'A' and o.lev < 999999",
") select dType, dCreator, dName, bType, bCreator, bName",
"from o"
call adrSql 'prepare s1 from :sql'
call adrSql "declare c1 cursor for s1"
call adrSql 'open c1'
do forever
call adrSql 'fetch c1 into' sqlFlds
if sqlCode = 100 then
leave
call stripVars flds
if mapHasKey(crNa, cr'.'na) then do
qTy = 'TY'
qBTy = 'BTY'
qbCr = 'BCR'
qbNa = 'BNA'
oo = mapGet(crNa, cr'.'na)
if left(oo, 3) = 'TB.' then do
if ty = 'T' & bTy = '.' & bNa = m.oo.db then
nop /* say 'old table in dep' cr'.'na */
else
call err 'dep with name of old table' ty cr'.'na
end
else if ty ^== m.oo.qTy then
call err 'new dep' m.oo.qTy cr'.'na 'mismatches old' ,
m.oo.qTy m.oo
else if ty == 'A' & ^ (bTy == m.oo.qBty & bCr == m.oo.qBcr ,
& bNa == m.oo.qBNa) then
call err 'dep with duplicate different alias' cr'.'na ,
'b' bTy bCr'.'bNa ,
'oo' m.oo.qBty m.oo.qBcr'.'m.oo.qBNa
else if 0 then
say 'skipping duplicate' cr'.'na
end
else do
nd = mPutVars(mAdd(dep, cr'.'na), flds 'NEWND' 'ACT')
call mapAdd crNa, cr'.'na, nd
end
end
call adrSql 'close c1'
say m.dep.0 'dependencies'
return
endProcedure oldInfo
infoNeu: procedure expose m.
parse arg ddlNeu
flds = cr na ty for oldNd oldAl
if mDefIfNot(nn.0, 0) then do
call mapReset(nn)
call mTypeNew 'StemNN', mTypeNew('NN', '', flds)
end
oldNd = ''
oldAl = ''
r = jDsn(ddlNeu)
call jOpen r, 'r'
call scanSqlReader s, r
lastX = 0
do forever
if lastX = m.scan.s.lineX then
if ^ scanNl(s, 1) then
leave
lastX = m.scan.s.lineX
if pos('CREATE', translate(m.scan.s.src)) < 1 then
iterate
fnd = 0
do while lastX = m.scan.s.lineX & ^fnd
if scanSql(scanSkip(s)) = '' then
leave
fnd = m.sqlType = 'i' & m.val == 'CREATE'
end
if ^ fnd then do
say 'no create, ignoring line' lastx strip(m.scan.s.src)
iterate
end
if scanSqlId(scanSkip(s)) == '' then do
say 'no sqlId, ignoring line' lastx strip(m.scan.s.src)
iterate
end
subTy = ''
if wordPos(m.val, 'UNIQUE LARGE LOB') > 0 then do
subTy = m.val
plus = ''
if subTy = 'UNIQUE' then
plus = 'WHERE NOT NULL'
do wx=1 by 1
if scanSqlId(scanSkip(s)) == '' then
call scanErr s, 'no sqlId after create' subTy
else if m.val = word(plus, wx) then
subTy = subTy m.val
else if wx=1 | wx > words(plus) then
leave
else
call scanErr s, 'stopped in middle of' plus
end
end
ty = m.val
m.scan.m.sqlBrackets = 0
if scanSqlQuId(scanSkip(s)) == '' then
call scanErr s, 'no qualId after create' subTy ty
na = m.val
na1 = m.val.1
na2 = m.val.2
for = '-'
if ty = 'ALIAS' then do
if scanSqlId(scanSkip(s)) ^== 'FOR' then
call scanErr s, 'IN expected after create' ty
if scanSqlQuId(scanSkip(s)) == '' then
call scanErr s, 'table name expected after create' ty na
for = m.val
ty = 'A'
end
else if ty = 'INDEX' then do
if scanSqlId(scanSkip(s)) ^== 'ON' then
call scanErr s, 'IN expected after create' ty
if scanSqlQuId(scanSkip(s)) == '' then
call scanErr s, 'table name expected after create' ty na
for = m.val
ty = 'X'
end
else if ty = 'TABLE' then do
do while ^ (m.scan.s.sqlBrackets = 0 & m.sqlType = 'i' ,
& m.val == 'IN')
if scanSql(scanSkip(s)) = '' | m.tok == ';' then
call scanErr s, 'in database expected'
end
if scanSqlQuId(scanSkip(s)) == '' | m.val = 'DATABASE' then
call scanErr s, 'ts name expected after create' ty na
for = m.val
ty = 'T'
end
else if ty = 'TABLESPACE' then do
if scanSqlId(scanSkip(s)) ^== 'IN' then
call scanErr s, 'IN expected after create' ty
if scanSqlDeId(scanSkip(s)) == '' then
call scanErr s, 'db name expected after create' ty
na = m.val'.'na
ty = 'S'
end
else if ty = 'VIEW' then do
ty = 'V'
for = ''
end
if 0 then
say 'create' subTy ty 'name' na 'for' for
if for ^== '-' then do
nd = mPut(mAdd(nn, na), flds, na1, na2, ty, for)
call mapAdd nn, na, nd
end
end
call jClose r
return
endProcedure infoNeu
infoRI: procedure expose m.
parse arg ddlNeu
flds = cr tb db bCr bTS bTb bDb bTS rNa
if mDefIfNot(ri.0, 0) then
call mTypeNew 'StemRI', mTypeNew('RI', '', flds)
sql = "select r.creator, r.tbName, td.dbName, td.tsName" ,
", refTbcreator, refTbName, tr.dbName, tr.tsName, relName",
"from sysibm.sysrels r, sysibm.sysTables td, sysibm.sysTables tr",
"where r.creator = td.creator and r.tbName = td.name",
"and r.refTbcreator = tr.creator and r.reftbName = tr.name",
"and (td.dbname" m.dbIn "or tr.dbname" m.dbIn")"
/*
select char(td.dbName, 8),
char(strip(r.creator) ||'.'|| strip(r.tbName), 20) "dep",
char(case when td.dbName = tr.dbName then '=' else tr.dbName end
, 8),
char(strip(refTbcreator) ||'.'|| strip(refTbName), 20) "ref par",
char(relName, 30)
from sysibm.sysrels r, sysibm.sysTables td, sysibm.sysTables tr
where r.creator = td.creator and r.tbName = td.name
and r.refTbcreator = tr.creator and r.reftbName = tr.name
and (td.dbname like 'BJAA_0001'
or td.dbname = 'DBJ01' or td.dbname like 'DNF%'
or tr.dbname like 'BJAA_0001'
or tr.dbname = 'DBJ01' or tr.dbname like 'DNF%')
*/
sqlFlds = sqlFields(flds)
call adrSql 'prepare s1 from :sql'
call adrSql "declare c1 cursor for s1"
call adrSql 'open c1'
do forever
call adrSql 'fetch c1 into' sqlFlds
if sqlCode = 100 then
leave
call stripVars flds
nd = mPutVars(mAdd(ri, cr'.'tb'.'rNa), flds)
end
call adrSql 'close c1'
say m.ri.0 'references'
return
endProcedure infoRI
mapAltNeu: procedure expose m.
parse arg newCr
do tx=1 to m.tb.0
cc = tb'.'tx
if ^ mapHasKey(nn, newCr'.'m.cc.tb) then
call err 'old table' m.cc 'has no corr. new'
dd = mapGet(nn, newCr'.'m.cc.tb)
if ^mapHasKey(db.a2n, m.cc.db) then
call err 'old table' m.cc 'ts in bad db' m.cc.db'.'m.cc.ts
if m.dd.oldNd ^== '' then
call err 'old table' m.cc 'maps to new' m.dd ,
'which already maps to' m.dd.oldNd
nTs = m.dd.for
if mapGet(db.a2n, m.cc.db) <> left(nTs, pos('.', nTs)-1) then
call err 'new table' m.dd 'in wrong db' nTs
m.cc.newNd = dd
m.dd.oldNd = cc
end
do dx=1 to m.dep.0
dd = dep'.'dx
if ^ mapHasKey(nn, newCr'.'m.dd.na) then
call err 'old dep' m.dd.ty m.dd 'has no corr. new'
ww = mapGet(nn, newCr'.'m.dd.na)
a = m.dd.ty
if a == 'V' then do
if m.ww.ty ^== 'V' then
call err 'old view' m.dd 'maps to' m.ww.ty m.ww
if m.ww.oldNd ^== '' then
call err 'old view' m.dd 'maps to' m.ww.ty m.ww ,
'which is already mapped to' m.ww.oldNd
m.ww.oldNd = dd
m.dd.newNd = ww
end
else if a == 'A' then do
if m.dd.na ^== m.dd.bNa then
call err 'bad old alias' m.dd ,
'for' m.dd.bCr'.'m.dd.bNa
m.ww.oldAl = m.ww.oldAl m.dd
end
else do
call err 'bad dep type' m.dd.ty m.dd
end
end
do nx=1 to m.nn.0
ww = nn'.'nx
if m.ww.ty = 'T' | m.ww.ty = 'V' then do
oo = m.ww.oldNd
if oo == '' then
call err 'no old for new' m.ww.ty m.ww
else if m.oo.cr ^== newCr & m.ww.oldAl = '' then
say '*warn: no old alias for new obj' m.ww.ty m.ww
end
end
bLim = 1E+9
tLim = 30
tbs = 0
bys = 0
jobNo = 1
do tx=1 to m.ts.0
tt = ts'.'tx
if tbs > 0 & (bys + m.tt.used > bLim ,
| tbs + m.tt.nTb > tLim) then do
jobNo = jobNo + 1
bys = 0
tbs = 0
end
bys = bys + m.tt.used
tbs = tbs + m.tt.nTb
m.tt.job = jobNo
end
do ox=1 to m.tb.0
ot = tb'.'ox
os = m.ot.tsNd
nt = m.ot.newNd
ns = m.nt.for
if symbol('os.os') ^== 'VAR' then
os.os = ns
else if wordPos(ns, os.os) < 1 then
os.os = os.os ns
if symbol('ns.ns') ^== 'VAR' then do
ns.ns = os
nt.ns = nt
end
else do
if ns.ns ^== os then
call err 'new TS maps to old' ns.ns 'and' os
if wordPos(nt, nt.ns) < 1 then
nt.ns = nt.ns nt
end
end
do ox=1 to m.ts.0
os = ts'.'ox
do nx=1 to words(os.os)
ns = word(os.os, nx)
do ny=1 to words(nt.ns)
nt = word(nt.ns, ny)
ot = m.nt.oldNd
say 'old' m.ot.cr m.ot.tb m.os.db m.os.ts ,
'new' m.nt.cr m.nt.na ns
nq = pos('.', ns)
call mPut mAdd(job, m.ot), m.jobFlds, m.os.job,
, m.ot.cr, m.ot.tb, m.os.db, m.os.ts,
, m.nt.cr, m.nt.na, left(ns,nq-1), substr(ns,nq+1)
end
end
end
return
endProcedure mapAltNeu
showAltNeu: procedure expose m.
parse arg out
m.o.0 = 0
do dx=1 to m.db.0
dd = db'.'dx
call mAdd o, 'mD' left(m.dd.alt, 20)left(m.dd.neu, 20)
end
do tx=1 to m.tb.0
tt = tb'.'tx
ss = m.tt.tsNd
l = 'oT' left(m.tt, 20)left(m.ss, 20) ,
|| right(m.ss.job, 4) m.ss.used,
|| right(m.ss.ntb, 4) || right(m.ss.parts, 4) m.ss.bp
call mAdd o, l
end
do tx=1 to m.tb.0
tt = tb'.'tx
ww = m.tt.newNd
l = 'mt' left(m.tt, 20)left(m.ww, 20),
|| left(m.tt.ts, 8) m.ww.for
call mAdd o, l
end
do dx=1 to m.dep.0
dd = dep'.'dx
ww = m.dd.newNd
if m.dd.ty == 'V' then
l = 'mV' left(m.dd, 20)left(m.ww, 20)
else if m.dd.ty == 'A' then
l = 'dA' left(m.dd, 20)left(m.dd.bCr'.'m.dd.bNa, 20)
else
call err 'bad ty in dep' m.dd.ty m.dd
call mAdd o, l
end
do rx=1 to m.ri.0
rr = ri'.'rx
if ^mapHasKey(db.a2n, m.rr.db) ,
| ^mapHasKey(db.a2n, m.rr.bDb) then
q = '|f'
else if m.rr.db <> m.rr.bDb then
q = '|d'
else
q = '= '
call mAdd o, 'mR' left(m.rr.cr'.'m.rr.tb, 20) ,
|| left(m.rr.bCr'.'m.rr.bTb, 20) q m.rr.rNa
end
call writeDsn out, m.o., ,1
return
endProcedure showAltNeu
showJob: procedure expose m.
parse arg out
m.o.0 = 0
do jx=1 to m.job.0
jj = 'JOB.'jx
call mAdd o, right(m.jj.job, 4) ,
left(m.jj, 20) left(m.jj.db'.'m.jj.ts, 17) ,
left(m.jj.nCr, 10) left(m.jj.nDb'.'m.jj.nTs, 17)
end
call writeDsn out, m.o., ,1
call loadJob out
return
endProcedure showAltNeu
loadJob: procedure expose m.
parse arg inp
call readDsn inp, i.
do i=1 to i.0
parse var i.i job cr '.' tb db '.' ts nCr nDb '.' nTs .
call stripVars 'CR DB NDB'
nTb = tb
say job cr'.'tb db'.'ts 'old' nCr'.'tb nDb'.'nTs
call mPutVars mAdd('JOB', cr'.'db), m.jobFlds
end
return
endProcedure loadJob
alias: procedure expose m.
parse arg out
m.dr.0 = 0
m.cr.0 = 0
c = 0
call sqlId cr, dr
do dx=1 to m.dep.0
dd = dep'.'dx
if m.dd.ty ^== 'A' then
iterate
c = c + 1;
if c // 50 = 0 then
call commit cr, dr
call mAdd dr, 'DROP ALIAS' m.dd';'
call mAdd cr, 'CREATE ALIAS' m.dd 'FOR' m.dd.bCr'.'m.dd.bNa';'
end
call commit cr, dr
call writeDsn dsnSetMbr(out, dsnGetMbr(out) || 'CREA'), m.cr., ,1
call writeDsn dsnSetMbr(out, dsnGetMbr(out) || 'DROP'), m.dr., ,1
return
endProcedure alias
commit: procedure expose m.
do ax=1 to arg()
call mAdd arg(ax), 'COMMIT;'
end
return
endProcedure commit
sqlId: procedure expose m.
do ax=1 to arg()
call mAdd arg(ax), "SET CURRENT SQLID = 'S100447';"
end
return
endProcedure sqlId
unload: procedure expose m.
parse arg fun, out
call readDsn m.skels'(nakJobCa)', m.jc.
call readDsn m.skels'(nak'fun'Ut)', m.skSt.
call readDsn m.skels'(nak'fun'TS)', m.skTs.
call readDsn m.skels'(nak'fun'Tb)', m.skTb.
m.o.0 = 0
jj = ''
call envPut 'STEP', 'S01'
call envPut 'DBSYS', m.dbSys
call envPut 'DSNPRE', m.dPre'.'fun
do sx=1 to m.ts.0
ss = ts'.'sx
if jj <> m.ss.job then do
jj = m.ss.job
call envPut 'JOBNAME', 'Y' || m.tas3 || fun || jj
call envExpAll o, jc
call envExpAll o, skSt
end
call envPut 'TS', m.ss
if m.ss.parts = 0 then
call envPut 'PARTONE', ''
else
call envPut 'PARTONE', 'PART 1'
call envExpAll o, skTS
do tx=1 to m.tb.0
tt = tb'.'tx
if m.tt.tsNd ^== ss then
iterate
call envPut 'TB', m.tt.cr'.'m.tt.tb
call envExpAll o, skTb
say 'job' jj 'ts' m.ss 'tb' m.tt
end
end
call writeDsn out, m.o., ,1
return
endProcedure unload
loadLines: procedure expose m.
parse arg punPre
do sx=1 to m.ts.0
ss = ts'.'sx
pun = punPre'.'m.ss.ts'.PUN'
call readDsn pun, p.
wh = ''
tbCnt = 0
do p=1 to p.0
w1 = word(p.p, 1)
if w1 = 'LOAD' then do
wh = 'l'
end
else if w1 = 'INTO' then do
wh = 'i'
if word(p.p, 2) ^== 'TABLE' then
call err 'TABLE expected in line' p 'in' pun':' p.p
w3 = word(p.p, 3)
dx = pos('.', w3)
if dx < 1 then
call err '. expected in w3 line' p 'in' pun':' p.p
crTb = strip(left(w3, dx-1), 'b', '"')'.',
||strip(substr(w3, dx+1), 'b', '"')
if ^ mapHasKey(crNa, crTb) then
call err 'old table' crTb 'not found' ,
'for punchLine' p 'in' pun':' p.p
tt = mapGet(crNa, crTb)
if m.tt.tsNd ^== ss then
call err 'old table' crTb ,
'wrong ts' m.tt.db'.'m.tt.ts,
'for punchLine' p 'in' pun':' p.p
if ^mDefIfNot(tt'.LO.0', 0) then
call err 'already loaded table' crTb ,
'for punchLine' p 'in' pun':' p.p
tbCnt = tbCnt + 1
end
else if w1 = ')' then do
if strip(p.p) <> ')' then
call err 'bad ) line' p 'in' pun':' p.p
if wh <> 'i' then
call err ') in state' wh 'line' p 'in' pun':' p.p
call mAdd tt'.LO', p.p
wh = ''
end
else if wh == 'i' then do
call mAdd tt'.LO', p.p
end
else if wh == 'l' then do
if w1 ^== 'EBCDIC' then
call err 'bad line after load' ,
'in punchLine' p 'in' pun':' p.p
end
end
if wh ^== '' then
call err 'punch' pun 'ends in state' wh
if tbCnt <> m.ss.nTb then
call err tbCnt 'tables not' m.ss.nTb 'loaded for' m.ss
say 'loadCards for' tbCnt 'tables for' m.ss
end
return
endProcedure loadLines
load: procedure expose m.
parse arg fun, out
call readDsn m.skels'(nakJobCa)', m.jc.
call readDsn m.skels'(nak'fun'Ut)', m.skSt.
call readDsn m.skels'(nak'fun'TS)', m.skTs.
call readDsn m.skels'(nak'fun'Tb)', m.skTb.
m.o.0 = 0
jj = ''
call envPut 'STEP', 'S01'
call envPut 'DBSYS', m.dbSys
call envPut 'DSNPRE', m.dPre'.UNL'
do nx=1 to m.newTs.0
ns = newTs'.'nx
if jj <> m.ns.job then do
jj = m.ns.job
call envPut 'JOBNAME', 'Y' || m.tas3 || fun || jj
call envExpAll o, jc
call envExpAll o, skSt
end
call envPut 'TREC', TREC || nx
call envPut 'TS', m.ns
tt = word(m.ns.tbNds, 1)
oo = m.tt.oldNd
call envPut 'OLDTS', m.oo.ts
call envExpAll o, skTS
do tx=1 to words(m.ns.tbNds)
tt = word(m.ns.tbNds, tx)
call envPut 'TB', m.tt
call envExpAll o, skTb
call mAddSt o, m.tt.oldNd'.LO'
say 'job' jj 'ts' m.ns 'tb' m.tt
end
end
call writeDsn out, m.o., ,1
return
endProcedure load
check: procedure expose m.
parse arg out
call readDsn m.skels'(nakJobCa)', m.jc.
call readDsn m.skels'(nakChKSt)', m.skut.
call readDsn m.skels'(nakChKTb)', m.sktb.
call envPut 'STEP', 'S01'
call envPut 'DBSYS', m.dbSys
call envPut 'JOBNAME', 'Y' || m.tas3 || 'CHK' || jj
m.o.0 = 0
call envExpAll o, jc
call envExpAll o, skCh
do rx=1 to m.ri.0
rr = 'RI.'rx
dbTs = m.rr.db'.'m.rr.ts
if R.dbTs == 1 then
iterate
R.dbTs = 1
call envPut 'TS', dbTs
call envExpAll o, skTb
end
call writeDsn out, m.o., ,1
return
endProcedure check
err:
call errA arg(1), 1
endSubroutine err
envPut: procedure expose m.
parse arg na, va
call mapPut m.vars, na, va
return
endProcedure envPut
envIsDefined: procedure expose m.
parse arg na
return mapHasKey(m.vars, na)
endProcedure envIsDefined
envGet: procedure expose m.
parse arg na
return mapGet(m.vars, na)
endProcedure envGet
envRemove: procedure expose m.
parse arg na
return mapRemove(env.vars, na)
endProcedure envRemove
envExpand: procedure expose m.
parse arg src
cx = pos('$', src)
if cx < 1 then
return strip(src, 't')
res = left(src, cx-1)
do forever
if substr(src, cx+1, 1) = '{' then do
ex = pos('}', src, cx+2)
if ex < 1 then
call err 'missing } after' substr(src, cx) 'in' src
res = res || envGet(substr(src, cx+2, ex-cx-2))
ex = ex + 1
end
else do
ex = verify(src, 'ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_',
|| 'abcdefghijklmnopqrstuvwxyz', 'n', cx+1)
if ex < 1 then
return strip(res || envGet(substr(src, cx+1)), 't')
res = res || envGet(substr(src, cx+1, ex-cx-1))
end
cx = pos('$', src, ex)
if cx < 1 then
return strip(res || substr(src, ex), 't')
res = res || substr(src, ex, cx-ex)
end
endProcedure envExpand
envExpAll: procedure expose m.
parse arg dst, src
dx = m.dst.0
do sx = 1 to m.src.0
dx = dx+1
m.dst.dx = envExpand(m.src.sx)
end
m.dst.0 = dx
return
endProcedure envExpAll
testExp: procedure
call mIni
m.xx.0 = 0
call envPut 'v1', eins
call envPut 'v2', zwei
call testExp1 'ohne variabeln'
call testExp1 '$v1 variabeln'
call testExp1 'mit $v1 iabeln'
call testExp1 'mit variab$v1'
call testExp1 '${v2}variabeln'
call testExp1 'mit vari${v1}'
call testExp1 'mit v${v2}eln'
call testExp1 'mit v${v1}eln'
call testExp1 'mit $v1 viel${v2}+$v1-vars${v2}'
call envExpAll mCut(yy, 0), xx
do x=1 to m.yy.0
say 'tesStem exp' m.yy.x'|'
end
return
endProcedure testExp
testExp1: procedure expose m.
parse arg src
call mAdd xx, src
say 'testExp src' src'|'
say 'testExp exp' envExpand(src)'|'
return
endProcedure testExp1
/* copy scanSql begin *************************************************/
/*--- initialize with reader inRdr ----------------------------------*/
scanSqlReader: procedure expose m.
parse arg m, inRdr
call scanReader m, inRdr
call scanOptions m, , '0123456789_' , '--'
m.scan.m.sqlBrackets = 0
return m
endProcedure scanSqlReader
scanSqlSeekId: procedure expose m.
parse arg m, lx, cmd
call adrEdit "cursor =" lx
do while adrEdit("seek" cmd 'word', 4) = 0 /* find each command*/
call adrEdit "(fx) = cursor"
call debug 'scanSqlSeekId after' lx 'found' cmd 'at' fx
call editReadDefine m, fx
call scanSqlReader m, m
do while m.m.editReadLx <= fx
if scanSql(scanSkip(m)) = '' then
return -1
if m.sqlType = 'i' & m.val == cmd then
return fx
end
end
return -1
endProcedure scanSqlSeekId
ePos: procedure expose m.
parse arg m
return m.m.editReadLx m.scan.m.pos
endProcedure ePos
/*--- scan a sql token put type in m.sqltype:
'i': ordinary identifier e.g. Name
'd': delimited identifier e.g. "Delimited"
'q': quantified identifier e.g. abc."efg"
'u': integer units e.g. 8G
'n': number e.g. -234
"'": string e.g. 'abc''ef'
'' : at end
: any other character e.g. ;
----------------------------------------------------------------*/
scanSql: procedure expose m.
parse arg m
if scanAtEnd(m) then do
m.sqlType = ''
m.val = ''
end
else if scanString(m, "'") then
m.sqlType = "'"
else if scanSqlQuId(m) ^== '' then
nop
else if scanSqlNumUnit(m, 1) ^== '' then
nop
else if scanChar(m, 1) then do
m.sqlType = m.tok
m.val = ''
if m.tok = '(' then
m.scan.m.sqlBrackets = m.scan.m.sqlBrackets + 1
else if m.tok = ')' then
m.scan.m.sqlBrackets = m.scan.m.sqlBrackets - 1
end
else
call scanErr m, 'cannot scan sql'
return m.sqlType
endProcedure scanSql
/*--- scan an ordinary sql identifier e.g. abc, ef_12 ----------------*/
scanSqlId: procedure expose m.
parse arg m
if ^ scanName(m) then
return ''
m.val = translate(m.tok)
m.sqlType = 'i'
return m.val
endProcedure scanSqlId
/*--- scan a delimited or ordinay sql identifier ---------------------*/
scanSqlDeId: procedure expose m.
parse arg m
if scanSqlId(m) == '' then do
if scanString(m, '"') then do
val = strip(val, 't')
m.sqlType = 'd'
end
end
return m.val
endProcedure scansqlDeId
/*--- scan a qualified sql identifier --------------------------------*/
scanSqlQuId: procedure expose m.
parse arg m
if scanSqlDeId(m) == '' then
return ''
res = ''
do qx=1 by 1
m.val.qx = m.val
res = res'.'m.val
if ^ scanLit(scanSkip(m), '.') then do
m.val.0 = qx
if qx > 1 then
m.sqlType = 'q'
m.val = substr(res, 2)
return m.val
end
if scansqlDeId(scanSkip(m)) == '' then
call scanErr m, 'id expected after .'
end
endProcedure scanSqlQuId
/*--- scan a sql number ----------------------------------------------*/
scanSqlNum: procedure expose m.
parse arg m, checkEnd
c3 = left(scanLook(m, 3), 3)
p = left(c3, 1) == '+' | left(c3, 1) == '-'
p = p + (substr(c3, p + 1, 1) == '.')
if pos(substr(c3, p+1, 1), '0123456789') < 1 then
return ''
n = ''
if p > 0 & left(c3, 1) ^== '.' then do
call scanChar m, 1
n = m.tok
end
if scanVerify(m, '0123456789') then
n = n || m.tok
if scanLit(m, '.') then do
n = n'.'
if scanVerify(m, '0123456789') then
n = n || m.tok
end
c3 = left(translate(scanLook(m, 3)), 3)
if left(c3, 1) == 'E' then do
p = substr(c3, 2, 1) == '+' | substr(c3, 2, 1) == '-'
if pos(substr(c3, p+2, 1), '0123456789') > 0 then do
call scanChar m, p+1
n = n || m.tok
if scanVerify(m, '0123456789') then
n = n || m.tok
c3 = scanLook(m, 1)
end
end
if checkEnd ^= 0 then
if pos(left(c3, 1), m.scan.m.name) > 0 then
call scanErr m, 'end of number' n 'expected'
m.val = n
return n
endProcedure scanSqlNum
/*--- scan a sql number with unit K M or G ---------------------------*/
scanSqlNumUnit: procedure expose m.
parse arg m, both
nu = scanSqlNum(m, 0)
if nu = '' then
return ''
sp = scanSpaceNl(m)
af = translate(scanSqlId(m))
if wordPos(af, "K M G") > 0 then do
m.sqlType = 'u'
m.val = nu || af
return m.val
end
else if af <> '' & ^ sp then
call scanErr m, 'end of number' nu 'expected'
if both ^== 1 then
call scanErr m, 'unit K M or G expected'
else if af ^== '' then
call scanBack m, m.tok
m.sqlType = 'n'
m.val = nu
return nu
endProcedure scanSqlNumUnit
scanSqlskipBrackets: procedure expose m.
parse arg m, br
call scanSpaceNl m
if br ^== '' then
nop
else if ^ scanLit(m, '(') then
return 0
else
br = 1
do forever
t = scanSql(scanSpaceNl(m))
if t = '' | t = ';' then
call scanErr m, 'closing )'
else if t = '(' then
br = br + 1
else if t ^== ')' then
nop
else if br > 1 then
br = br - 1
else if br = 1 then
return 1
else
call scanErr m, 'skipBrackets bad br' br
end
endProcedure skipBrackets
/* copy scanSql end *************************************************/
/* copy scan begin ****************************************************
Scan: scan an input:
scanLine(m,ln) : begin scanning a single line (string)
scanReader(m,ln): begin scanning all lines of an opened reader
scanAtEnd(m) : returns whether we reached end of input
scanLit(m,lit) : scan Literal lit if present or return 0
scanChar(m,n) : scan next n characters
scanName(m) : scan a name
ScanNat(m) : scan a natural number (without sign)
scanString(m,q): scan a String with quote q. (with doubble = 1)
scanVerify(m,c,o): verify(...,c,o,...)
scanKeyValue(m): scan a key = value clause (with spaces)
scanWord(m,u) : scan a space delimited word or a string,
if u=1 then uppercase non-strings
scanErr(m, txt): error with current scan location
m is an adress, to store our state
if a scan function succeeds, the scan posititon is moved
returns: true if scanned, false otherwise
m.tok ==> last token
m.val ==> last value for scanString/Word/KeyValue
m.key ==> key for scanKeyValue
m.scan.m.pos ==> scan position
m.scan.m.src ==> scan source
***********************************************************************/
/*--- begin scanning a single line -----------------------------------*/
scanLine: procedure expose m.
parse arg m, m.scan.m.src
m.scan.m.pos = 1
if symbol('m.scan.m.name') ^== 'VAR' then
call scanInit m
return m
endProcedure scanLine
/*--- switch to next line if atEnd of line or unCond=1 ---------------*/
scanNL: procedure expose m.
parse arg m, unCond
if m.scan.m.reading then do
interpret m.scan.m.scanNl
end
else do
np = 1 + length(m.scan.m.src)
if np <= m.scan.m.pos then
return 0
if unCond == 1 then nop
else if unCond ^= 0 & m.scan.m.comment ^== '' ,
& abbrev(m.scan.m.src, m.scan.m.comment) then nop
else
return 0
m.scan.m.pos = np
return 1
end
endProcedure scanNL
scanAtEnd: procedure expose m.
parse arg m, what
if m.scan.m.reading then
interpret m.scan.m.scanAtEnd
else
return m.scan.m.pos > length(m.scan.m.src)
endProcedure scanAtEnd
/*--- initialize scanner for m --------------------------------------*/
scanInit: procedure expose m.
parse arg m, rdng
m.scan.m.reading = rdng == 1
m.tok = ''
m.val = ''
m.key = ''
m.scan.LC = 'abcdefghijklmnopqurstuvwxyz'
m.scan.UC = 'ABCDEFGHIJKLMNOPQURSTUVWXYZ'
m.scan.Alpha = m.scan.LC || m.scan.UC
m.scan.AlNum = '0123456789' || m.scan.ALPHA
m.scan.m.Name1 = m.scan.ALPHA
m.scan.m.Name = m.scan.ALNUM
m.scan.m.comment = ''
return
endProcedure scanInit
/*--- set options name characters, comment characters ----------------*/
scanOptions: procedure expose m.
parse arg m, nameOne, namePlus, m.scan.m.comment
if symbol('m.scan.m.Name') ^== 'VAR' then
call scanInit m
if nameOne ^== '' then do
m.scan.m.Name1 = nameOne
m.scan.m.name = m.scan.m.name1 || '0123456789'
end
if namePlus ^== '' then
m.scan.m.name = m.scan.m.name1 || namePlus
return
endProcedure scanOptions
/*--- return the next len characters ---------------------------------*/
scanLook: procedure expose m.
parse arg m, len
nx = 1 + length(m.scan.m.src)
if len ^== '' then
if nx > m.scan.m.pos + len then
nx = m.scan.m.pos + len
return substr(m.scan.m.src, m.scan.m.pos, nx - m.scan.m.pos)
endProcedure scanLit
/*--- scan the next len characters -----------------------------------*/
scanChar: procedure expose m.
parse arg m, len
m.tok = scanLook(m, len)
m.scan.m.pos = m.scan.m.pos + length(m.tok)
return length(m.tok) > 0
endProcedure scanChar
/*--- scan the literal lit ------------------------------------------*/
scanLit: procedure expose m.
parse arg m, lit
if ^ abbrev(substr(m.scan.m.src, m.scan.m.pos), lit) then
return 0
m.scan.m.pos = m.scan.m.pos + length(lit)
m.tok = lit
return 1
endProcedure scanLit
/*--- scan a string with quote char qu -------------------------------*/
scanString: procedure expose m.
parse arg m, qu
m.val = ''
if qu = '' then
qu = "'"
if substr(m.scan.m.src, m.scan.m.pos, 1) ^== qu then
return 0
bx = m.scan.m.pos
qx = m.scan.m.pos + 1
do forever
px = pos(qu, m.scan.m.src, qx)
if px < 1 then
call scanErr m, 'ending Apostroph('qu') missing'
m.val = m.val || substr(m.scan.m.src, qx, px-qx)
if px >= length(m.scan.m.src) then
leave
else if substr(m.scan.m.src, px+1, 1) <> qu then
leave
qx = px+2
m.val = m.val || qu
end
m.tok = substr(m.scan.m.src, bx, px+1-bx)
m.scan.m.pos = px+1
return 1
endProcedure scanString
/*--- scan a Name, first char in *.name1, rest in *.name -------------*/
scanName: procedure expose m.
parse arg m
if pos(substr(m.scan.m.src, m.scan.m.pos, 1),
, m.scan.m.Name1) <= 0 then
return 0
bx = m.scan.m.pos
m.scan.m.pos = bx + 1
call scanVerify m, m.scan.m.Name
m.tok = substr(m.scan.m.src, bx, m.scan.m.pos - bx)
return 1
endProcedure scanName
/*--- scan with verify, vOpt is passed to verify ---------------------*/
scanVerify: procedure expose m.
parse arg m, alpha, vOpt
if vOpt == '' then /* empty string does not take default| */
nx = verify(m.scan.m.src, alpha, , m.scan.m.pos)
else
nx = verify(m.scan.m.src, alpha, vOpt, m.scan.m.pos)
if nx = 0 then
nx = length(m.scan.m.src) + 1
m.tok = substr(m.scan.m.src, m.scan.m.Pos, nx - m.scan.m.Pos)
if nx <= m.scan.m.pos then
return 0
m.scan.m.pos = nx
return 1
endProcedure scanVerify
/*--- scan a natural number (no sign, decpoint ...) ------------------*/
ScanNat: procedure expose m.
parse arg m
if ^ scanVerify(m, '0123456789') then
return 0
else if pos(substr(m.scan.m.src, m.scan.m.pos, 1), m.scan.m.name1) ,
> 0 then
call scanErr m, 'illegal number end'
return 1
endProcedure ScanNat
/*--- scan a word and put value into *.val
a word is either delimited by space or stopper
or a string (with single or double quotes -------*/
scanWord: procedure expose m.
parse arg m, stopper
if scanString(m, "'") then return 1
if scanString(m, """") then return 1
if ^scanVerify(m, ' 'stopper, 'm') then return 0
m.val = m.tok
return 1
endProcedure scanWord
scanBack: procedure expose m.
parse arg m, tok
if m.scan.m.pos <= length(tok) then
call scanErr sc, 'cannot back "'tok'" length'
cx = m.scan.m.pos - length(tok)
if substr(m.scan.m.src, cx, length(tok)) ^== tok then
call scanErr sc, 'cannot back "'tok'" value'
m.scan.m.pos = cx
return
endProcedure scanBack
/*--- scan a key = word phrase
put key into m.key and word into m.val -------*/
scanKeyValue: procedure expose m.
parse arg m, def
if ^ scanName(m) then
return 0
m.key = m.tok
if ^ scanLit(scanSkip(m), '=') then do
m.val = def
m.tok = ' no='
end
else if ^scanWord(scanSkip(m)) then
call scanErr(m, 'word expected after' m.key '=')
return 1
endProcedure scanKeyValue
/*--- emit an error with current scan pos ----------------------------*/
scanErr: procedure expose m.
parse arg m, txt
say 'scanErr' txt
say ' last token' m.tok 'scanPosition' ,
strip(left(substr(m.scan.m.src, m.scan.m.pos), 40), 't')
if m.scan.m.reading then
interpret 'say " "' m.scan.m.scanLinePos
else
say ' pos' m.scan.m.Pos 'in string' strip(m.scan.m.src, 't')
call err 'scanErr' txt
return
endProcedure scanErr
/*--- skip over spaces, nl and comments (if option set) --------------*/
scanSpaceNL: procedure expose m.
parse arg m
lastTok = m.tok
res = 0
do forever
if scanVerify(m, ' ') then nop
else if ^ scanNL(m) then leave
res = 1
end
m.tok = lastTok
return res
endProcedure scanSpaceNL
/*--- skip over space, nl and comments and return m -----------------*/
scanSkip: procedure expose m.
parse arg m
call scanSpaceNl m
return m
endProcedure scanSkip
/*--- begin scanning the lines of a reader ---------------------------*/
scanReader: procedure expose m.
parse arg m, m.scan.m.rdr
call scanInit m, 1
m.scan.m.atEnd = 0
m.scan.m.lineX = 0
m.scan.m.scanNl = 'return scanReaderNl(m, unCond)'
m.scan.m.scanAtEnd = 'return scanReaderAtEnd(m, what)'
m.scan.m.scanLinePos = "scanReaderLinePos(m)"
call scanReaderNl m, 1
return m
endProcedure scanReader
/*--- return true/false whether we are at the end of line / reader ---*/
scanReaderAtEnd: procedure expose m.
parse arg m, what
if m.scan.m.pos <= length(m.scan.m.src) then
return 0
if what == 'l' then
return 1
return m.scan.m.atEnd
endProcedure scanReaderAtEnd
scanReaderNL: procedure expose m.
parse arg m, unCond
if unCond == 1 then nop
else if unCond ^= 2 & m.scan.m.pos > length(m.scan.m.src) then nop
else if unCond ^= 0 & m.scan.m.comment ^== '' & abbrev(substr( ,
m.scan.m.src, m.scan.m.pos), m.scan.m.comment) then nop
else
return 0
if m.scan.m.atEnd then
return 0
m.scan.m.atEnd = ^ jRead(m.scan.m.rdr, 'SCAN.'m'.SRC')
if m.scan.m.atEnd then do
m.scan.m.pos = 1 + length(m.scan.m.src)
end
else do
m.scan.m.pos = 1
m.scan.m.lineX = m.scan.m.lineX + 1
end
return ^ m.scan.m.atEnd
endProcedure scanReaderNL
scanReaderLinePos: procedure expose m.
parse arg m
if m.scan.m.atEnd then
qq = 'atEnd after'
else
qq = 'pos' m.scan.m.pos 'in'
return qq 'line' m.scan.m.lineX':' strip(m.scan.m.src, 't')
endProcedure scanReaderLinePos
/* copy scan end ****************************************************/
/* copy j begin *******************************************************
the j framework
jReset
jOpen
jClose
jRead
jWrite
***********************************************************************/
jNew: procedure expose m.
if m.j.jIni ^== 1 then
call jIni
return 'J.'mInc(j)
endProcedure jNew
jFree: procedure expose m.
parse arg m
return
endProcedure jFree
jRead: procedure expose m.
parse arg m, arg
res = '?'
interpret m.j.m.read
return res
endProcedure jRead
jWrite: procedure expose m.
parse arg m, arg
interpret m.j.m.write
return
endProcedure jWrite
jReset: procedure expose m.
parse arg m, arg
interpret 'call' m.j.m.pref'Reset m, arg'
return m
endProcedure jOpen
jOpen: procedure expose m.
parse arg m, arg
interpret 'call' m.j.m.pref'Open m, arg'
return m
endProcedure jOpen
jClose: procedure expose m.
parse arg m
interpret 'call' m.j.m.pref'Close m'
m.j.m.read = 'call err "read('m') when closed"'
m.j.m.write = 'call err "write('m') when closed"'
return m
endProcedure jClose
jDefine: procedure expose m.
parse arg m, m.j.m.pref
m.j.m.read = 'call err "read('m') when closed"'
m.j.m.write = 'call err "write('m') when closed"'
return m
endProcedure jDefine
jDefRead: procedure expose m.
parse arg m, m.j.m.read
m.j.m.write = 'call err "write('m') when reading"'
return m
endProcedure jDeRead
jDefWrite: procedure expose m.
parse arg m, m.j.m.write
m.j.m.read = 'call err "read('m') when writing"'
return m
endProcedure jDeWrite
jOpt: procedure expose m.
parse arg src, alone, val
m.j.oOpt = ''
if left(src, 1) ^== '-' then do
m.j.oVal = src
return 0
end
sx = 2
if alone ^== '' then do
sx = verify(src, alone, 'n', sx)
if sx = 0 then
sx = length(src)+1
end
if length(src) < sx then
m.j.oVal = ''
else if val == '' then
call err 'bad opt "'src'" should contain only "'alone'"'
else if pos(substr(src, sx, 1), val) < 1 then
call err 'bad opt "'src'" should contain only "'alone'"' ,
'and/or 1 of "'val'" with value'
else do
sx = sx + 1
m.j.oVal = substr(src, sx)
end
m.j.oOpt = substr(src, 2, sx-2)
return 1
endProcedure jOpt
jIni: procedure expose m.
parse arg force
if m.j.jIni == 1 & force ^== 1 then
return
m.j.jIni = 1
m.j.0 = 0
m.j.defDD.0 = 0
m.j.jIn = jNew()
m.j.jOut = jNew()
call jDefine m.j.jIn, "jStdIOError "
call jDefRead m.j.jIn, "res = 0"
call jDefine m.j.jOut, "jStdIOError "
call jDefWrite m.j.jOut, "say arg"
return
endProcedure jIni
jStdIOError: procedure expose m.
parse arg fun m, arg
call err 'do not j'fun'('m',' arg') base stdIn/stdOut'
return
endSubroutine
jIn: procedure expose m.
parse arg arg
return jRead(m.j.jIn, arg)
endProcedur jIn
jOut: procedure expose m.
parse arg arg
call jWrite m.j.jOut, arg
return
endProcedure jOut
jBuf: procedure expose m.
m = jNew()
call jDefine m, "jBuf"
do ax=1 to arg()
m.j.m.buf.ax = arg(ax)
end
m.j.m.buf.0 = ax-1
return m
endProcedure jBuf
jBufReset: procedure expose m.
parse arg m
do ax=1 to arg() - 1
m.j.m.buf.ax = arg(ax+1)
end
m.j.m.buf.0 = ax-1
return m
endProcedure jBufReset
jBufOpen: procedure expose m.
parse arg m, opt
if opt == 'r' then do
call jDefRead m, "res = jBufRead(m , arg)"
m.j.m.bufIx = 0
return m
end
if opt == 'w' then
m.j.m.buf.0 = 0
else if opt ^== 'a' then
call err 'jBufOpen('m',' opt') with bad opt'
call jDefWrite m, "call mAdd 'J.'m'.BUF', arg"
return m
endProcedure jBufOpen
jBufClose:
return arg(1)
endProcedure jBufClose
jBufStem: procedure expose m.
parse arg m
return 'J.'m'.BUF'
endProcedure jBufStem
jBufRead: procedure expose m.
parse arg m, var
ix = m.j.m.bufIx + 1
if ix > m.j.m.buf.0 then
return 0
m.j.m.bufIx = ix
m.var = m.j.m.buf.ix
return 1
endProcedure jBufRead
jDsn: procedure expose m.
parse arg spec
m = jNew()
m.j.m.state = ''
call jDefine m, "jDsn"
m.j.m.defDD = 'J'mInc('J.DEFDD')
call jDsnReset m, spec
return m
endProcedure jDsn
jDsnReset: procedure expose m.
parse arg m, spec
call jClose m
m.j.m.dsnSpec = spec
return m
endProcedure jDsnReset
jDsnOpen: procedure expose m.
parse arg m, opt
call jDsnClose m
if opt == 'r' then do
aa = dsnAlloc(m.j.m.dsnSpec, 'SHR', m.j.m.defDD)
call readDDBegin word(aa, 1)
call jDefRead m, "res = jDsnRead(m , arg)"
end
else do
if opt == 'w' then
aa = dsnAlloc(m.j.m.dsnSpec, 'OLD', m.j.m.defDD)
else if opt == 'a' then
aa = dsnAlloc(m.j.m.dsnSpec, 'MOD', m.j.m.defDD)
else
call err 'jBufOpen('m',' opt') with bad opt'
call writeDDbegin word(aa, 1)
call jDefWrite m, "call jDsnWrite m , arg"
end
m.j.m.state = opt
m.j.m.dd = word(aa, 1)
m.j.m.free = subword(aa, 2)
return m
endProcedure jBufOpen
jDsnClose:
parse arg m
if m.j.m.state ^== '' then do
if m.j.m.state == 'r' then do
call readDDend m.j.m.dd
end
else do
if m.j.m.buf.0 > 0 then
call writeDD m.j.m.dd, 'M.J.'m'.BUF.'
call writeDDend m.j.m.dd
end
interpret m.j.m.free
end
m.j.m.buf.0 = 0
m.j.m.bufIx = 0
m.j.m.state = ''
m.j.m.free = ''
m.j.m.dd = ''
return m
endProcedure jDsnClose
jDsnRead: procedure expose m.
parse arg m, var
ix = m.j.m.bufIx + 1
if ix > m.j.m.buf.0 then do
res = readDD(m.j.m.dd, 'M.J.'m'.BUF.')
if ^ res then
return 0
ix = 1
end
m.j.m.bufIx = ix
m.var = m.j.m.buf.ix
return 1
endProcedure jDsnRead
jDsnWrite: procedure expose m.
parse arg m, var
ix = m.j.m.buf.0 + 1
m.j.m.buf.0 = ix
m.j.m.buf.ix = var
if ix > 99 then do
call writeDD m.j.m.dd, 'M.J.'m'.BUF.'
m.j.m.buf.0 = 0
end
return
endProcedure jDsnWrite
/* copy j end *********************************************************/
/* copy adrSql begin *************************************************/
/**********************************************************************
adrSql: execute sql thru the dsnRexx interface
***********************************************************************/
adrSql: /* no procedure, to keep variables sql... */
parse arg ggSqlStmt, ggRet, ggNo
if ggNo <> '1' then
ggSqlStmt = 'execSql' ggSqlStmt
address dsnRexx ggSqlStmt
/* say 'sqlCode' sqlCode 'rc' rc 'for' ggSqlStmt ggNo */
if rc = 0 then do
return 0
end
else if rc < 0 then do
if ggRet == '*' then nop
else if wordPos(sqlCode, ggRet) > 0 then nop
else
call err "sql rc" rc sqlmsg() ggNo
end
else if sqlWarn.0 ^== ' ' then do
say 'warning' sqlMsg() ggNo
end
return sqlCode
endSubroutine adrSql
adrSqlConnect: procedure
parse arg ggSys, ggRetCon
if adrTSO("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" ggSys, ggRetCon ,1
return
endProcedure adrSqlConnect
adrSqlDisconnect: procedure
parse arg ggRet
call adrSql "disconnect ", ggRet, 1
return
endProcedure adrSqlDisconnect
sqlFields: procedure
parse arg flds
sql = ''
do wx=1 to words(flds)
sql = sql', :'word(flds, wx)
end
if wx > 1 then
sql = substr(sql, 3)
return sql
endProcedure sqlFields
sqlMsg: /* no procedure, to keep variables sql... */
ggW = ''
do ggX=0 to 10
if sqlWarn.ggx <> '' then
ggw = ggw ggx'='sqlWarn.ggx
end
ggXX = pos(':', ggSqlStmt)
ggVV = ''
if ggXX > 0 then do
ggVV = word(substr(ggSqlStmt, ggXX + 1), 1)
ggXX = verify(ggVV, ' ,:+-*/&%?|', 'm')
if ggXX > 0 then
ggVV = left(ggVV, ggXX-1)
ggVV = 'with' ggVV '=' value(ggVV)
end
return 'sqlCode' sqlCode 'state' sqlState 'warn' ggW ,
'errMc' strip(translate(sqlerrmc, ',', 'FF'x)) ,
'stmt = ' ggSqlStmt ggVV
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 = adrTso('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
/* copy adrSql 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', "'")
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
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 -------------------------------------------*/
dsnAlloc: procedure expose m.
parse upper arg spec, disp, dd
ds = ''
if left(spec, 1) = '-' then
return strip(substr(spec, 2))
if left(spec, 1) = '&' then /* external spec is handled ok */
spec = strip(substr(spec, 2))
rest = ''
do wx=1 by 1
w = word(spec, wx)
if w = '' then
leave
if abbrev(w, '.') then do
rest = substr(subword(spec, wx), 2)
leave
end
if abbrev(w, ':') then do
nn = substr(subword(spec, wx), 2)
leave
end
if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
disp = w
else if w = 'CATALOG' then
disp = disp w
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if ds = '' then
ds = dsn2jcl(w)
else
leave
end
if dd = '' then
dd = 'DD' || ooNew()
if disp = '' | (disp = 'OLD' & pos('(', dsn) > 0) then
disp = 'SHR'
m.dsnAlloc.dsn = ds
if ds <> '' then
ds = "DSN('"ds"')"
alRc = adrTso('alloc dd('dd')' disp ds rest, '*')
if alRc ^== 0 then do
if nn = 'NN' | wordPos(disp, 'OLD SHR') < 1 ,
| sysDsn("'"m.dsnAlloc.dsn"'") ^== 'DATASET NOT FOUND' then
call err 'tsoAlloc rc' alRc 'for alloc dd('dd')' disp ds rest
say 'tsoAlloc rc' alRc 'for alloc dd('dd')' disp ds rest ,
'...trying to create'
call dsnAllocCreate m.dsnAlloc.dsn, nn
call adrTso 'alloc dd('dd')' disp ds rest
end
return dd 'call adrTso "free dd('dd')";'
endProcedure dsnAlloc
dsnAllocCreate: procedure expose m.
parse arg dsn, atts
if abbrev(atts, ':') then do
rl = substr(atts, 3)
if abbrev(atts, ':F') then do
if rl = '' then
rl = 80
atts = 'recfm(f b) lrecl('rl')' ,
'block(' (32760 - 32760 // rl)')'
end
else do
if rl = '' then
rl = 32756
atts = 'recfm('substr(atts, 2, 1) 'b) lrecl('rl')' ,
'block(32760)'
end
if pos('(', dsn) > 0 then
atts = atts 'dsntype(library) dsorg(po)' ,
"dsn('"dsnSetMbr(dsn)"')"
else
atts = atts "dsn('"dsn"')"
atts = 'new catalog' atts 'mgmtclas(s005y000) space(10, 1000)'
call adrTso 'alloc dd(dsnAlloc)' atts
call adrTso 'free dd(dsnAlloc)'
return
endProcedure dsnAllocCreate
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 m begin ********************************************************
stem and type handling
***********************************************************************/
/*--- increase m.a and return it (fail if undefined) -----------------*/
mInc: procedure expose m.
parse arg a
m.a.0 = m.a.0 + 1
return m.a.0
endProcedure mInc
mDefIfNot: procedure expose m.
parse arg a, put
if symbol('m.a') == 'VAR' then
return 0
m.a = put
return 1
endProcedure mDefIfNot
/*--- cut stem a to length len ---------------------------------------*/
mCut: procedure expose m.
parse arg a, len
m.a.0 = len
return a
endProcedure mCut
/*--- add one or several arguments to stem m.a -----------------------*/
mAdd: procedure expose m.
parse arg a
ix = m.a.0
do ax = 2 to arg()
ix = ix + 1
m.a.ix = arg(ax)
end
m.a.0 = ix
return a'.'ix
endProcedure mAdd
/*--- add to m.dst.* a (sub)sequence of m.src.* ----------------------*/
mAddSt: procedure expose m.
parse arg dst, src
dx = m.dst.0
do sx = 1 to m.src.0
dx = dx + 1
m.dst.dx = m.src.sx
end
m.dst.0 = dx
return
endProcedure mAddAt
/*--- put into stem a the fields flds from arguments -----------------*/
mPut: procedure expose m.
parse arg a, flds
do wx = 1 to words(flds)
f = word(flds, wx)
m.a.f = arg(wx+2)
end
return a
endProcedure mPut
/*--- put into stem a the fields flds from stem b --------------------*/
mPutSt: procedure expose m.
parse arg a, flds, b
do wx = 1 to words(flds)
f = word(flds, wx)
m.a.f = m.b.f
end
return a
endProcedure mPutSt
/*--- put into stem a the fields flds from variable pool -------------*/
mPutVars:
parse arg ggA, ggFlds
do ggWx = 1 to words(ggFlds)
ggF = word(ggFlds, ggWx)
m.ggA.ggF = value(ggF)
end
return ggA
endProcedure mPutVars
/*--- create a new map ----------------------------------------------*/
mapNew: procedure expose m.
if m.m.mIni ^== 1 then
call mIni
return mapReset(mAdd(m.map, 'map'))
endProcedure mapNew
/*--- make an empty map, opt=K means maintain a stem of keys ---------*/
mapReset: procedure expose m.
parse arg a, opt
if symbol('m.a.mapKey') == 'VAR' then
call mapClear a
m.a.mapKey = translate(opt) = 'K'
if m.a.mapKey then
m.a.mapKey.0 = 0
else
m.a.mapKey.0 = 'noMapKeys'
return a
endProcedure
mapClear: procedure expose m.
parse arg a
do kx=1 to m.a.mapKey.0
k = m.a.mapKey.kx
drop m.a.mapK2V.k m.a.mapKey.kx
end
m.a.mapKey.0 = 0
return a
endProcedure mapClear
mapAdd: procedure expose m.
parse arg a, ky, val
if symbol('m.a.mapK2V.ky') == 'VAR' then
call err 'duplicate key in mAdd('a',' ky',' val')'
m.a.mapK2V.ky = val
if m.a.mapKey then
call mAdd a.mapKey, ky
return
endProcedure mapAdd
mapPut: procedure expose m.
parse arg m, ky, val
if m.m.mapKey then
if symbol('m.m.mapK2V.ky') ^== 'VAR' then
call mAdd m.mapKey, ky
m.m.mapK2V.ky = val
return
endProcedure mapPut
mapHasKey: procedure expose m.
parse arg m, ky
return symbol('m.m.mapK2V.ky') == 'VAR'
endProcedure mapHasKey
mapGet: procedure expose m.
parse arg m, ky
if symbol('m.m.mapK2V.ky') ^== 'VAR' then
call err 'missing key in mapGet('m',' ky')'
return m.m.mapK2V.ky
endProcedure mapGet
mapGetOr: procedure expose m.
parse arg m, ky, orDef
if symbol('m.m.mapK2V.ky') == 'VAR' then
return m.m.mapK2V.ky
else
return orDef
endProcedure mapGetOr
/*--- add to m.dst a (sub)tree of m.src.* ----------------------------*/
mGetType:
parse arg name
return mapGet(m.type, name)
endProcedure mGetType
mTypeNew: procedure expose m.
parse arg name, stem, flds, types
if m.m.ini ^== 1 then
call mIni
ty = mAdd(m.type, name)
call mapAdd m.type, name, ty
m.ty.ass = '='
m.ty.type = stem
m.ty.0 = words(flds)
m.ty.type.0 = m.ty.0
do y=1 to m.ty.0
m.ty.y = word(flds, y)
if word(types, y) = '' then
m.ty.type.y = m.type.1
else
m.ty.type.y = word(types, y)
end
return ty
endProcedure mTypeNew
mShow: procedure expose m.
parse arg ty, a, lv
if lv='' then
lv = 0
pr = a
if lv > 0 & lastPos('.', pr) > 0 then
pr = substr(pr, lastPos('.', pr))
say left('', lv)pr '=' m.a
do y=1 to m.ty.0
call mShow m.ty.type.y, a'.'m.ty.y, lv+1
end
if m.ty.type ^== '' then do
do y=1 to m.a.0
call mShow m.ty.type, a'.'y, lv+1
end
end
return
endProcedure mShow
mClear: procedure expose m.
parse arg ty, a, val
m.a = val
do y=1 to m.ty.0
call mClear m.ty.type.y, a'.'m.ty.y
end
if m.ty.type ^== '' then
m.a.0 = 0
return
endProcedure mClear
mTypeSay: procedure expose m.
parse arg t
say 'type' t'='m.t 'ass' m.t.ass '#' m.t.0 'tys' m.t.type
return
endProcedure mInit
mTypeCopy: procedure expose m.
parse arg ty, t, f
if m.ty.ass == '=' then
m.t = m.f
else
call err 'type.ass' m.ty.ass 'not supported'
do x = 1 to m.ty.0
fld = m.ty.x
call mTypeCopy m.ty.type.x, t'.'fld, f'.'fld
end
if m.ty.type ^== '' then do
do y = 1 to m.f.0
call mTypeCopy m.ty.type, t'.'y, f'.'y
end
m.t.0 = m.f.0
end
return t
endProcedure mTypeCopy
mIni: procedure expose m.
m.m.ini = 1
m.m.type.0 = 0
m.m.map.0 = 0
call mapReset m.type
call mapReset m.vars
siTy = mTypeNew('Simple')
stTy = mTypeNew('Stem', siTy)
tyTy = mTypeNew('Type', siTy, 'ASS TYS', siTy stTy)
ttTy = mTypeNew('StemType', tyTy)
return
endProcedure mIni
mTest: procedure
call mIni
siTy = mGetType('Simple')
tyTy = mGetType('Type')
ttTy = mGetType('StemType')
say 'siTy' siTy 'tyTy' tyTy 'stTyTy' ttTy
call mTypeSay siTy
call mTypeCopy siTy, nnn, siTy'.'ass
say 'm.nnn nach copy' m.nnn
call mTypeCopy tyTy, mmm, siTy
call mTypeSay mmm
call mTypeCopy tyTy, qqq, tyTy
call mTypeSay qqq
call mShow tyTy, qqq
call mShow ttTy, m.type
return
endProcedure mTest
/* copy m 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 *****************************************************/
}¢--- A540769.WK.REXX(ND) cre=2016-03-24 mod=2016-03-24-15.08.32 A540769 -------
/* rexx
nd = next diff
scroll to next difference
*/
call errReset 'hi'
call adrEdit 'macro'
call adrEdit '(li co) = cursor'
lim = -1
do forever
if li > lim then do
say 'cursor='li co
lim = li + 100
end
call adrEdit '(l1) = line' li
call adrEdit '(l2) = line' (li+1)
le = min(length(l1), length(l2))
if co < 1 then
lx = 1
else do lx=co to le while substr(l1,lx,1) \== substr(l2,lx,1)
end
do ly=lx to le while substr(l1,ly,1) == substr(l2,ly,1)
end
if ly <= le then do
say '\==' co'..., ==' lx'..., \==' ly', end='le
call adrEdit 'cursor =' li min(le, ly)
exit
end
li = li+2
co = 0
end
exit
/* rexx ****************************************************************
wsh: walter's rexx shell version 5.0
interfaces: 12. 1.16
edit macro: for adhoc evaluation or programming
either block selection: q or qq and b or a
oder mit Directives ($#...) im Text
wsh i: tso interpreter
batch: input in dd wsh
docu: http://chw20025641/host/db2wiki/pmwiki.php?n=Main.Wsh
syntax: http://chw20025641/host/db2wiki/pmwiki.php?n=Main.WshSyn
|||achtung $@.sqlRdr() funktioniert nicht nur $@..¢sqlRdr() $!
||| sqlSel schreib !$#out |||||
||| einheitliches sql select/rdr syntax in wsh (mit ftab oder ohne|)
|||sql select aus rz2 muss wie csmExRx erfolgen (via WSH) ||||
--- history ------------------------------------------------------------
23.12.15 dsnList, dsnCopy und dsnDel
*********/ /*** end of help ********************************************
16. 1.15 f: get/put read/write in/out Object/Strings transparent weiter
17.11.14 f: iirz2p ==> plex Buchstaben
17.06.14 f: %tS %tT und %tN mit MicroSekunden
16.06.14 csmCopy auch für LoadModule usw.
30.05.14 fix sql4obj fuer rcm profex
14.04.14 class vor obj, mit lazy
19.03.14 ii = installation Info
9.01.14 walter: redesign formatting (fmt eliminiert), csm.div.p0.exec
3.12.13 walter: db2 interface radikal geputzt
3.10.13 walter: uCount fuer TSO <-> unitCount fuer Csm
23. 9.13 walter: ws2 syntax
6. 2.13 w.keller csmCopy aendert mgmtClas für neue lokale Files
23. 1.13 w.keller sqlErrHandler sowie sqlRx und sql
11. 6.12 w.keller sqlUpdComLoop
23. 5.12 w.keller fix sqlStmt: drop accepts -204
31. 3.12 w.keller sql Query interface incl. sql über CSM
10. 2.12 w.keller div catTb* und eLong
2. 6.11 w.keller sql error with current location and dsnTiar
2. 5.11 w.keller sqlStmt etc..
16. 3.11 w.keller basic new r '' ==> r m.class_O
28. 2.11 w.keller compFile by exprBlock, fix $@do forever, |
7. 2.11 w.keller cleanup block / with sqlPush....
2. 2.11 w.keller simplified syntax, ast for blocks, ? for help
19. 6.10 w.keller open/close stacked mit jUsers, framed eliminiert
19. 5.10 w.keller class wird direkt erzeugt ohne temporary
18. 4.10 w.keller scanUtilInto ==> testCase noch einbauen
17. 4.10 w.keller oMutate in fileTsoList eingebaut
14. 1.10 w.keller batch interface no longer dies on openIfNotYet
CSM.RZ1.P0.EXEC korrigiert
***********************************************************************/
if 0 then do
do y = left(date('s'), 4) - 17 to left(date('s'), 4) + 7
say y timeYear2Y(y) timeY2Year(timeYear2Y(y))
end
do y = left(date('s'), 4) - 69 to left(date('s'), 4) + 30
say y timeYear24(substr(y, 3))
end
d = date('s')
say d 'b' date('b', d , 's')
say d 'b' date('b', 20150101, 's') 'jul' date('j')
say d 'l14' date('b', 20150101, 's') - date('b', 20140101, 's')
say d 'l16' date('b', 20170101, 's') - date('b', 20160101, 's')
exit
end
/*--- main code wsh --------------------------------------------------*/
call errReset 'hI'
numeric digits 12 /* full int precision, but not bigInt | */
m.myLib = 'A540769.WK.REXX'
m.myVers = 'v50 27.10.15'
call wshLog
parse arg spec
isEdit = 0
if spec = '' & m.err.ispf then do /* z/OS edit macro */
isEdit = adrEdit('macro (spec) NOPROCESS', '*') == 0
if isEdit then do
call adrEdit '(d) = dataset'
call adrEdit '(m) = member'
m.editDsn = dsnSetMbr(d, m)
if spec = '' & abbrev(m.editDsn, 'A540769.WK.REXX(WS') ,
& length(dsnGetMbr(m.editDsn)) <= 4 then do
spec = 't'
isEdit = 0
end
end
end
spec = strip(spec)
if spec = '?' then
return help()
else if translate(word(spec, 1)) == 'T' then
return wshTst(subword(spec, 2))
else if spec <> '' & \ abbrev(spec, '$#') then
spec = '$#'spec
rest = ''
inp = ''
out = ''
call wshIni
if m.err.os == 'TSO' then do
if isEdit then do
parse value wshEditBegin(spec) with inp out
end
else if sysvar('sysEnv') = 'FORE' then do
end
else do
inp = file('dd(wsh)')
useOut = listDsi('OUT FILE')
if \ (useOut = 16 & sysReason = 2) then
out = file('dd(out)')
end
end
else if m.err.os == 'LINUX' then do
inp = file('&in')
out = file('&out')
end
else
call err 'implement wsh for os' m.err.os
m.wshInfo = 'compile'
m.wsh_exitCC = 0
call compRun spec, inp, out, wshInfo
if isEdit then
call wshEditEnd
exit m.wsh_exitCC
wshLog: procedure expose m.
parse arg msg, st
lNm = 'tss.ska.db2.wshlog'
f1 = dsnAlloc('dd(log) mod' lNm '::f', , , '*')
if datatype(f1, 'n') then do
lN2 = lNm'.R' || ( random() // 19)
f1 = dsnAlloc('dd(log) old' lN2 '::f', , , '*')
if datatype(f1, 'n') then do
say 'could not allocate log' lNm lN2
return
end
end
parse source . . s3 .
o.1 = m.myLib'('s3')' word(m.myVers, 1) sysvar(sysnode) ,
'j='mvsvar('symdef', 'jobname') ,
'u='userid() date('s') time()
if msg <> '' then
o.2 = left(msg, 80)
ox = 1 + (msg <> '')
if st <> '' then do sx=1 to m.st.0
ox = ox+1
o.ox = left(m.st.sx, 80)
end
call writedd log, o., ox
call tsoClose log
call tsoFree log
return
endProcedure wshLog
/*--- test hook ----------------------------------------------------*/
wshHook_T: procedure expose m.
parse arg cmp
rest = strip(scanLook(m.cmp.scan))
call compEnd cmp
return wshTst(rest)
endProcedure wshHook_t
wshTst: procedure expose m.
parse arg rest
m.tst_csmRz = 'RZZ'
m.tst_csmDbSys = 'RZZ/DE0G'
if rest = '' then do /* default */
say funits(3e7, 'd')
call err tstEnd
call tstfTst
call sqlConnect DBAF
call catColCom 'cmnBatch', 'DSN_PGROUP_TABLE',
, 'cmnBatch', 'DSN_PGROUP_TABLE_new'
call sqlDisConnect
return 0
end
c = ''
do wx=1 to words(rest)
c = c 'call tst'word(rest, wx)';'
end
if wx > 2 then
c = c 'call tstTotal;'
say 'wsh interpreting' c
interpret c
exit 0
endProcedure wshTst
/*--- i hook: interpret user input: rexx, expr, data or shell -------*/
wshHook_I: procedure expose m.
parse arg cmp
inp = strip(scanLook(m.cmp.scan))
call scanClose m.cmp.scan
mode = '*'
do forever
if pos(left(inp, 1), '/;:*@.-=') > 0 then
parse var inp mode 2 inp
if mode == '/' then
exit 0
mode = translate(mode, ';', ':')
if inp <> '' then do
say 'as' mode 'interpreting' inp
if mode = ';' then
interpret inp
else if mode = '*' then
interpret 'say' inp
else do
call errReset 'h', 'say "******* intercepting error";',
'call errSay ggTxt; return "";'
call oRun compile(comp(jBuf(inp)), mode)
call errReset 'h'
end
end
say 'enter' mode 'expression, / for end, ; or * for Rexx' ,
'@ . - = for wsh'
parse pull inp
end
endProcedure wshInter
/*--- sql hook -----------------------------------------------------*/
wshHook_S: procedure expose m.
parse arg cmp
s = m.cmp.scan
ki = '='
call scanVerify s, m.comp_chSpa
if scanVerify(s, m.comp_chKind) then
ki = left(m.s.tok, 1)
call scanChar s
rest = strip(m.s.tok)
call scanNl s
dbSy = word(rest, 1)
if abbrev(dbSy, '-') | \ (length(dbSy) = 4 ,
| (length(dbsy) = 8 & substr(dbSy,4,1) == '/')) then
dbSy = ''
else
rest = subWord(rest, 2)
res = compAST(cmp, 'P', ' f', '',
, compAstAddOp(cmp, compUnit(cmp, ki, '$#'), '@'))
call mAdd res, compAst(cmp, ';', ,
, compAst(cmp, '+', "call sqlConnect '"dbSy"'",
"; if \ sqlStmts( , 'rb ret', '"rest"') then m.wsh_exitCC=8" ,
"; call sqlDisConnect;" ))
return res
endProcedure wshHook_s
wshEditBegin: procedure expose m.
parse arg spec
dst = ''
li = ''
m.wsh.editHdr = 1
pc = adrEdit("process dest range Q", 0 4 8 12 16)
if pc = 16 then
call err 'bad range must be q'
if pc = 0 | pc = 8 then do
call adrEdit "(rFi) = lineNum .zFrange"
call adrEdit "(rLa) = lineNum .zLrange"
/* say 'range' rFi '-' rLa */
end
else do
rFi = ''
/* say 'no range' */
end
if pc = 0 | pc = 4 then do
call adrEdit "(dst) = lineNum .zDest"
/* say 'dest' dst */
dst = dst + 1
end
else do
/* say 'no dest' */
if adrEdit("find first '$#out' 1", 4) = 0 then do
call adrEdit "(dst) = cursor"
/* say '$#out' dst */
call adrEdit "(li) = line" dst
m.wsh.editHdr = 1
end
end
m.wsh.editDst = dst
m.wsh.editOut = ''
if dst \== '' then do
call adrEdit '(recl) = LRECL'
eo = jOpen(jText(jBuf(), recL), '>')
m.wsh.editOut = eo
if m.wsh.editHdr then
call jWrite eo, left(li, 50) date('s') time()
end
if rFi == '' then do
call adrEdit "(zLa) = lineNum .zl"
if adrEdit("find first '$#' 1", 4) = 0 then do
call adrEdit "(rFi) = cursor"
call adrEdit "(li) = line" rFi
if abbrev(li, '$#out') | abbrev(li, '$#end') then
rFi = 1
if rFi < dst & dst \== '' then
rLa = dst-1
else
rLa = zLa
end
else do
rFi = 1
rLa = zLa
end
end
/* say 'range' c1 'rc' pc':' rFi '-' rLa 'after' dst */
m.wsh.editIn = jOpen(jBuf(), m.j.cWri)
do lx=rFi to rLa
call adrEdit "(li) = line" lx
call jWrite m.wsh.editIn, li
end
call errReset 'h',
, 'return wshEditErrH(ggTxt, ' rFi',' rLa')'
return jClose(m.wsh.editIn) m.wsh.editOut
endProcedure wshEditBegin
wshEditEnd: procedure expose m.
call errReset 'h'
if m.wsh.editOut == '' then
return 0
eo = jClose(m.wsh.editOut)
lab = wshEditInsLinSt(m.wsh.editDst, 0, , m.eo.deleg'.BUF')
call wshEditLocate max(1, m.wsh.editDst-7)
return 1
endProcedure wshEditEnd
wshEditLocate: procedure
parse arg ln
call adrEdit '(la) = linenum .zl'
call adrEdit 'locate ' max(1, min(ln, la - 37))
return
endProcedure wshEditLocate
wshEditErrH: procedure expose m.
parse arg ggTxt, rFi, rLa
call errCleanup
call errReset 'h'
call splitNl err, errMsg(' }'ggTxt)
call mMove err, 1, 2
isScan = 0
if wordPos("pos", m.err.4) > 0 ,
& pos(" in line ", m.err.4) > 0 then do
parse var m.err.4 "pos " pos . " in line " lin":"
if pos = '' then do
parse var m.err.4 " line " lin":"
pos = 0
end
isScan = lin \== ''
end
m.err.1 = '***' m.wshInfo 'error ***'
if m.wshInfo=='compile' & isScan then do
do sx=1 to m.err.0
call out m.err.sx
end
lab = rFi + lin
if pos \= '' then
lab = wshEditInsLin(lab, 'msgline', right('*',pos))
lab = wshEditInsLinSt((rFi+lin),0, 'msgline', err)
call wshEditLocate rFi+lin-25
end
else do
if m.wsh.editOut \== '' then do
do sx=1 to m.err.0
call jWrite m.wsh.editOut, m.err.sx
end
lab = wshEditInsLinSt(m.wsh.editDst, 0, ,
, m.wsh.editOut'.BUF')
call wshEditInsLinSt m.wsh.editDst, m.wsh.editHdr,
, msgline, err
call wshEditLocate max(1, m.wsh.editDst-7)
end
else do
do sx=1 to m.err.0
say m.err.sx
end
end
end
call errCleanup
exit
endSubroutine wshEditErrH
wshEditInsLinCmd: procedure
parse arg wh
if dataType(wh, 'n') then do
if adrEdit("label" wh "= .a", 0 8 12) \= 12 then
return 'line_before .a ='
else
return 'line_after .zl ='
end
else if left(wh, 1) == '.' then
return 'line_before' wh '='
else
return wh
endProcedure wshEditInsLinCmd
wshEditInsLin: procedure
parse arg wh, type
cmd = wshEditInsLinCmd(wh)
do ax=3 to arg()
li = strip(arg(ax), 't')
/* if li == '' then nein, leere Zeilen doch anzeigen | */
if translate(type) = 'MSGLINE' then do while length(li) > 72
sx = lastPos(' ', li, 72)
if sx < 10 then
sx = 72
one = left(li, sx)
li = ' 'strip(substr(li, sx))
call adrEdit cmd type "(one)"
end
call adrEdit cmd type "(li)", 0 4
end
return cmd
endProcedure wshEditInsLin
wshEditInsLinSt: procedure expose m.
parse arg wh, pl, type, st
if wh == '' then do
do ox=1 to m.st.0
say m.st.ox
end
return ''
end
wh = wh + pl
cmd = wshEditInsLinCmd(wh)
do ax=1 to m.st.0
call wshEditInsLin cmd, type, m.st.ax
end
return cmd
endProcedure wshEditInsLinSt
/*** end wsh, begin all copies ****************************************/
/*** abub compatibility ***********************************************/
loadCols: procedure expose m.
if (\ in()) | word(m.in, 1) <> 'LOAD' then
call err 'not load but' m.l1
do while in() & strip(m.in) \== '('
end
if strip(m.in) \== '(' then
call err '( not found in load:' m.in
m.in = '-'
do while in() & strip(m.in) \== ')'
call out m.in
end
if strip(m.in) \== ')' then
call err ') not found in load:' m.in
return 1
endProcedure
/*** end abub compatibility *******************************************/
/* copy tstAll begin *************************************************/
/*----------- neu, noch versorgen |||||-------------------------------*/
tstRts: procedure expose m.
call wshIni
call sqlConnect dbaf
call sqlQuery 3, "select * from sysibm.sysTableSpaceSTats" ,
"where dbName = 'MF01A1A' and name = 'A150A'",
"order by partition asc"
do while sqlFetch(3, rr)
say f('@.DBNAME%-8C.@NAME%-8C @PARTITION %4C' ,rr)
end
call sqlDisconnect
endProcedure tstRts
tstWiki:
call mapReset docs, 'k'
call addFiles docs, 'n', '/media/wkData/literature/notes'
call addFiles docs, 'd', '/media/wkData/literature/docs'
in = jOpen(file('wiki.old'), '<')
out = jOpen(file('wiki.new'), '>')
abc = '(:abc: %l%'
do cx=1 to length(m.ut_lc)
c1 = substr(m.ut_lc, cx, 1)
abc = abc '¢¢#'c1 '|' c1'!!'
end
call jWrite out, abc ':)'
inTxt = 0
li = m.i
do lx=1 while jReadVar(in, i)
if 0 then
say length(m.i) m.i
if m.i = '' then
iterate
li = m.i
do forever
bx = pos('¢=', li)
if bx < 1 then
leave
ex = pos('=!', li)
if ex <= bx then
call err '=! before ¢= in' lx li
li = left(li, bx-1)substr(li,bx+2, ex-bx-2)substr(li,ex+2)
end
li = strip(li)
if abbrev(li, '|') then do
w = word(substr(li, 2), 1)
call jWrite out, '¢¢#'w'!! {$:abc}'
call jWrite out, '|||' substr(li, 2)
inTxt=1
iterate
end
if \ inTxt then do
call jWrite out, li
iterate
end
if \ (abbrev(li, '->') | abbrev(li, '#') ,
| abbrev(li, '¢')) then do
call jWrite out, '-<' li
iterate
end
cx = 1
if substr(li, cx, 2) == '->' then
cx = verify(li, ' ', 'n', cx+2)
hasCross = substr(li, cx, 1) == '#'
if hasCross then
cx = verify(li, ' ', 'n', cx+1)
ex = verify(li, '!:\, ', 'm', cx)
ex = ex - (substr(li, ex, 1) \== '!')
hasBr = substr(li, cx, 1) == '¢'
if \ hasBr then
w = substr(li, cx, ex+1-cx)
else if substr(li, ex, 1) == '!' then
w = substr(li, cx+1, ex-1-cx)
else
call err 'br not closed' substr(w, cx+1, ex-1-cx) 'in' lx li
hasPdf = right(w, 4) == '.pdf'
if hasPdf then
w = left(w, length(w)-4)
if verify(w, '#?', 'm') > 0 then do
w = translate(w, '__', '#?')
say '*** changing to' w 'in' lx li
end
o = '-< {def+'w'}'
o = '-< ¢¢'w'!!'
k = translate(w)
if k.k == 1 then
say '*** doppelter key' k 'in:' lx left(li,80)
k.k = 1
dT = ''
if mapHasKey(docs, k) then do
parse value mapGet(docs, k) with dT dC dN
call mapPut docs, k, dT (dC+1) dN
do tx=1 to length(dT)
t1 = substr(dT, tx, 1)
o = o '¢¢Lit'translate(t1)':'word(dN, tx) '|' t1 '!!'
end
end
qSeq = 'nd'
qq = left(qSeq, 1)
qx = 0
do forever
qx = pos('@'qq, li, qx+1)
if qx < 1 then do
qq = substr(qSeq, 1 + pos(qq, qSeq), 1)
qx=0
if qq = '' then
leave
else
iterate
end
if pos(qq, dT) < 1 then do
say '*** @'qq 'document not found:' lx li
iterate
end
do qb = qx-1 by -1 while substr(li, qb, 1) == ' '
end
do qe = qx+2 by 1 while substr(li, qe, 1) == ' '
end
if substr(li, qb, 1) == '.' & substr(li, qe, 1) == '.' then
li = left(li, qb)substr(li, qe+1)
else
li = left(li, qb) substr(li, qe)
end
o = o':' strip(substr(li, ex+1+(substr(li,ex+1,1)==':')))
if 0 then say left(li, 30) '==>' left(o, 30)
call jWrite out, o
end
dk = mapKeys(docs)
do dx=1 to m.dk.0
parse value mapGet(docs, m.dk.dx) with dT dC dN
if dC < 1 then
say '*** document not used:' dT dC dn
end
call jClose in
call jClose out
return
endProcedure tstWiki
addFiles: procedure expose m.
parse arg m, ty, file
fl = jOpen(fileList(file(file)), '<')
do while jRead(fl)
nm = substr(m.fl, lastPos('/', m.fl)+1)
k = translate(left(nm, pos('.', nm)-1))
if \ mapHasKey(m, k) then do
call mapAdd m, k, ty 0 nm
end
else do
parse value mapGet(m, k) with dT dC dN
call mapPut m, k, dT || ty 0 dN nm
end
end
call jClose fl
return
endProcedure addFiles
tstAll: procedure expose m.
say 'tstAll ws2 25.2.13...............'
call tstBase
call tstComp
call tstDiv
if m.err.os = 'TSO' then do
call tstZos
call tstTut0
end
return 0
endProcedure tstAll
/****** tstZos ********************************************************/
tstZOs:
call tstTime
call tstTime2Tst
call tstII
call sqlIni
call tstSqlRx
call tstSql
if m.tst_csmRZ \== '' then
call tstSqlCsm
call scanReadIni
call tstSqlC
call tstSqlCsv
call tstSqlRxUpd
call tstSqlUpd
call tstSqlUpdPre
call tstSqlE
call tstSqlB
call tstSqlO1
call tstSqlO2
call tstSqlStmt
call tstSqlStmts
call tstSqlUpdComLoop
call tstSqls1
call tstSqlO
call tstSqlFTab
call tstSqlFTab2
call tstSqlFTab3
call tstSqlFTab4
call tstsql4obj
call tstTotal
return
endProcedure tstZOs
tstWshBatch:
call adrTso 'alloc dd(WSH) shr dsn(WK.TEXT(WSHBATCH))'
call wshBatch
return adrTso('free dd(WSH)')
tstLmdTiming:
parse arg lev
say timing() lev
call lmdBegin abc, lev
c = 0
do while lmdNext(abc, st.)
c = c + st.0
end
call lmdEnd abc
say timing() lev 'with group - without reading' c
call adrIsp 'lmdinit listid(lmdId) level('lev')'
do c=0 while adrIsp('lmdlist listid(&lmdId) dataset(abc)', 8) = 0
end
call adrIsp 'lmdfree listid(&lmdId)'
say timing() lev 'with list' c
return
endProcedure lmdTiming
tstCsi: procedure expose m.
if 0 then do
call lmd 'A540769.*K'
call tstCsiCla 'A540769.WK.REXX'
call tstCsiCla 'A540769.AAA.DATASETS'
call tstCsiCla 'A540769.RRR.DATASETS'
end
if 0 then do
call tstCsiOpNx 'A540769.WK.*E*'
call tstCsiOpNx 'A540769.AAA.DATASETS'
call tstCsiOpNx 'A540769.RRR.DATASETS'
end
if 1 then do
call tstCsiNxCl 'A540769.WK.**'
call tstCsiNxCl 'DBTF.M*.**'
call tstCsiNxCl 'DBTF.BE*.**'
end
return
tstCsi: procedure expose m.
/* call lmd 'A540769.*K' */
call tstCsi1 'A540769.WK.REXX'
call tstCsi1 'A540769.AAA.DATASETS'
call tstCsi1 'A540769.RRR.DATASETS'
return
tstCsiCla:
parse arg ds
say ds '-->' csiCla(ds)
return
tstCsiOpNx: procedure expose m.
parse arg ds
m = 'NUE123'
s = 'res89'
flds = 'devtyp volser mgmtclas comudsiz NOBYTTRK UDATASIZ HARBA'
say 'csiOpen' ds
call csiOpen m, ds, flds
do while csiNext(m, s)
say m.s 'dev' c2x(m.s.devTyp) ,
'vol' m.s.volSer 'cla' m.s.mgmtclas,
'comuDsiz' m.s.comuDsiz 'noBytTrk' m.s.noBytTrk,
'udatasiz' c2x(m.s.udatasiz) ,
'harba' c2x(m.s.harba)
end
return
tstCsiNxCl: procedure expose m.
parse arg ds
m = 'ABC123'
s = 'efg89'
flds = 'devtyp volser mgmtclas'
say 'csiOpen' ds
call csiOpen m, ds, flds
say timing() 'begin'
do i=1 while csiNext(m, s)
nn = csiArcTape(m.s.volser, m.s.mgmtClas, m.s.devtyp, m.s)
/* oo = csiCla(strip(m.s))
if oo <> nn then
say nn '<>' oo m.s
*/ if i // 1000 = 0 then
say timing() i nn m.s
end
say timing() (i-1) nn m.s
return
endProcedure tstCsiNxCl
listCatClass: procedure expose m.
parse upper arg dsn
rt = adrTso("listcat volume entry('"dsn"')", 4)
/* say 'listct rc =' rt 'lines' m.tso_trap.0 */
cl = ''
vo = ''
if word(m.tso_trap.1, 3) \== dsn then
call out 'err ??? for dsn' dsn 'bad first line' m.tso_trap.1
else if pos('NOT FOUND', m.tso_trap.1) > 0 then
return 'notFound'
else if word(m.tso_trap.1, 1)\== 'NONVSAM' then
call out 'err ??? for dsn' dsn 'bad first line' m.tso_trap.1
do tx=2 to m.tso_trap.0 while vo = '' ,
& left(m.tso_trap.tx, 1) = ' '
/* say m.tso_trap.tx */
p = pos('MANAGEMENTCLASS-', m.tso_trap.tx)
if p > 0 then
vo = strip(word(substr(m.tso_trap.tx, p+16), 1), 'l', '-')
p = pos('VOLSER--', m.tso_trap.tx)
if p > 0 then
vo = strip(word(substr(m.tso_trap.tx, p+6), 1), 'l', '-')
p = pos('DEVCLASS--', m.tso_trap.tx)
dt = strip(word(substr(m.tso_trap.tx, p+8), 1), 'l', '-')
end
/* say 'lc' cl 'vo' vo 'dt' dt 'dsn' dsn */
if vo = '' then
call out '??? err no volume for dsn' dsn
else if vo = 'ARCIVE' then
res = 'arcive'
else if cl = '' then
res = 'tape'
else
res = cl
if abbrev(res, 'ar') \= abbrev(dt, "X'0") ,
| abbrev(res, 'ta') \= abbrev(dt, "X'7") ,
| (left(res, 1) >= 'A') \= abbrev(dt, "X'3") then
call out 'err ??? mismatch cl' cl 'vo' vo 'dt' dt 'dsn' dsn
return res
endProcedure listCatClass
tstMbrList: procedure expose m.
/*
$=/tstMbrList/
### start tst tstMbrList ##########################################
*** err: adrTso rc=8 stmt=LISTDS 'A540769.TMP.TST.MBRLIST' MEMBERS+
. .
. e 1: A540769.TMP.TST.MBRLIST
. e 2: IKJ58503I DATA SET 'A540769.TMP.TST.MBRLIST' NOT IN CATAL+
OG
#noPds: 0 mbrs in A540769.TMP.TST.MBRLIST
#1: 1 mbrs in A540769.TMP.TST.MBRLIST
1 EINS
#0: 0 mbrs in A540769.TMP.TST.MBRLIST
#4: 4 mbrs in A540769.TMP.TST.MBRLIST
1 DREI
2 FUENF
3 VIER
4 ZWEI
#*IE*: 3 mbrs in A540769.TMP.TST.MBRLIST( *IE* )
1 IE
2 NNNIE
3 VIER
#*_IE*: 2 mbrs in A540769.TMP.TST.MBRLIST( *?IE* )
1 NNNIE
2 VIER
$/tstMbrList/
*/
call tst t, 'tstMbrList'
/* call tstMbrList1 "RZ2/A540769.WK.REXX(*DA?*)" */
pds = tstFileName('MbrList', 'r')
da.1 = '2ine eins'
call tstMbrList1 pds, '#noPds'
call writeDsn pds'(eins) ::f', da., 1
call tstMbrList1 pds, '#1'
call adrTso "delete '"pds"(eins)'"
call tstMbrList1 pds, '#0'
call writeDsn pds'(zwei) ::f', da., 1
call writeDsn pds'(drei) ::f', da., 1
call writeDsn pds'(vier) ::f', da., 1
call writeDsn pds'(fuenf) ::f', da., 1
call tstMbrList1 pds, '#4'
call writeDsn pds'(ie) ::f', da., 1
call writeDsn pds'(nnnie) ::f', da., 1
call tstMbrList1 pds"( *IE* )", '#*IE*'
call tstMbrList1 pds"( *?IE* )", '#*_IE*'
call adrTso "delete '"pds"'"
call tstEnd t
return
endProcedure tstMbrList
tstMbrList1: procedure expose m.
parse arg pds, txt
call tstOut t, txt':' mbrList(tstMbrList, pds) 'mbrs in' pds
do mx=1 to m.tstMbrList.0
call tstOut t, mx m.tstMbrList.mx
end
return
endProdecure tstMbrList1
/****** tstDiv ********************************************************/
tstDiv:
call tstSort
call tstMat
call tstMatch
call tstTotal
return
endProcedure tstDiv
tstSort: procedure expose m.
call tstSortComp
call tstSortComp '<<='
call tstSortComp 'm.aLe <<= m.aRi'
call tstSortComp 'if 1 then cmp = m.aLe <<= m.aRi; else call err sd'
return
endProcedure tstSort
tstSortComp: procedure expose m.
parse arg cmp
/*
$=/tstSort/
### start tst tstSort #############################################
sort 29 c ACHT DREI DREIZEHN EINS ELF FUENF M.I.25 M.I.26 M.I.27 M+
..I.29 NEUN SECHS SIEBEN VIER VIERZEHN ZEHN ZWEI ZWOELF 0 1 1 1 2 2+
. 3 3 4 4
sort 22 c ACHT DREIZEHN ELF M.I.25 M.I.26 M.I.27 M.I.29 NEUN VIERZ+
EHN ZEHN ZWOELF 0 1 1 1 2 2 3 3 4 4
sort 15 c M.I.25 M.I.26 M.I.27 M.I.29 0 1 1 1 2 2 3 3 4 4
sort 8 c M.I.25 M.I.26 M.I.27 M.I.29 0 1 1
sort 1 M.I.29
sortWords(also als a 05 4 1e2, cmp) a als also 05 1e2 4
sortWords(also als a 05 4, cmp) a als also 05 4
sortWords(also als a 05, cmp) a als also 05
sortWords(also als a, cmp) a als also
sortWords(also als, cmp) als also
sortWords(also, cmp) also
sortWords(, cmp) .
sortWords(also als a 05 4 1e2, <) a als also 4 05 1e2
sortWords(also als a 05 4 1e2, >) 1e2 05 4 also als a
$/tstSort/ */
/*
$=/tstSortAscii/
### start tst tstSortAscii ########################################
sort 29 0 1 1 1 2 2 3 3 4 4 ACHT DREI DREIZEHN EINS ELF FUENF M.I.+
25 M.I.26 M.I.27 M.I.29 NEUN SECHS SIEBEN VIER VIERZEHN ZEHN ZWEI Z+
WOELF c
sort 22 0 1 1 1 2 2 3 3 4 4 ACHT DREIZEHN ELF M.I.25 M.I.26 M.I.27+
. M.I.29 NEUN VIERZEHN ZEHN ZWOELF c
sort 15 0 1 1 1 2 2 3 3 4 4 M.I.25 M.I.26 M.I.27 M.I.29 c
sort 8 0 1 1 M.I.25 M.I.26 M.I.27 M.I.29 c
sort 1 M.I.29
$/tstSortAscii/ */
say '### start with comparator' cmp '###'
if m.err.os == 'LINUX' then
call tst t, "tstSortAscii"
else
call tst t, "tstSort"
call mAdd mCut(i, 0), eins, zwei, drei, vier, fuenf, sechs,
,sieben, acht, neun, zehn, elf, zwoelf, dreizehn, vierzehn
call mAdd i, 1, 2, 3, 4, 4, 3, 2, 1, 0, 1,
, 'M.I.25', 'M.I.26', 'M.I.27', 'c', 'M.I.29'
do yy = m.i.0 by -1 to 1
do x = 0 to yy
m.i.0 = x
call sort i, o, cmp
m = ''
la = ''
if x <> m.o.0 then
call err 'size mismatch' x '<>' m.o.0
do y=1 to m.o.0
m = m m.o.y
if \ (la << m.o.y) then
call err 'sort mismatch' yy x y '\' la '<<' m.o.y
end
end
if yy // 7 = 1 then
call tstOut t, 'sort' yy m
do x = 2 to yy
x1 = x-1
m.i.x1 = m.i.x
end
end
wi = 'also als a 05 4 1e2'
do l=words(wi) by -1 to 0
call tstOut t, 'sortWords('subWord(wi, 1, l)', cmp)' ,
sortWords(subWord(wi, 1, l), cmp)
end
call tstOut t, 'sortWords('wi', <)' sortWords(wi, '<')
call tstOut t, 'sortWords('wi', >)' sortWords(wi, '>')
call tstEnd t
return
endProcedure tstSort
tstMatch: procedure expose m.
/*
$=/tstMatch/
### start tst tstMatch ############################################
match(eins, e?n*) 1 1 2,i,s trans(E?N*) EiNs
match(eins, eins) 1 1 0 trans(EINS) EINS
match(e1nss, e?n*) 1 1 2,1,ss trans(?*) 1ss
match(eiinss, e?n*) 0 0 -9 trans(E?N*) .
match(einss, e?n *) 0 0 -9 trans(E?N *) .
match(ein s, e?n *) 1 1 2,i,s trans(E?N *) EiN s
match(ein abss , ?i*b*) 1 1 3,e,n a,ss trans(?I*B*) eIn aBss .
match(ein abss wie gehtsssxdirx und auch , ) 0 0 -9 trans() .
match(ies000, *000) 1 1 1,ies trans(*000) ies000
match(xx0x0000, *000) 1 1 1,xx0x0 trans(*000) xx0x0000
match(000x00000xx, 000*) 1 1 1,x00000xx trans(000*) 000x00000xx
match(000xx, *0*) 1 1 2,00,xx trans(ab*cd*ef) ab00cdxxef
match(abcdef, *abcdef*) 1 1 2,, trans(*ABCDEF*) ABCDEF
match(abcdef, **abcdef***) 1 1 5,,,,, trans(**ABCDEF***) ABCDEF
match(abcdef, *cd*) 1 1 2,ab,ef trans(*CD*) abCDef
match(abcdef, *abc*def*) 1 1 3,,, trans(*ABC*DEF*) ABCDEF
match(abcdef, *bc*e*) 1 1 3,a,d,f trans(*BC*E*) aBCdEf
match(abcdef, **bc**ef**) 1 1 6,a,,d,,, trans(**BC**EF**) aBCdEF
$/tstMatch/
*/
call tst t, "tstMatch"
call tstOut t, tstMatch1('eins', 'e?n*' )
call tstOut t, tstMatch1('eins', 'eins' )
call tstOut t, tstMatch1('e1nss', 'e?n*', '?*' )
call tstOut t, tstMatch1('eiinss', 'e?n*' )
call tstOut t, tstMatch1('einss', 'e?n *' )
call tstOut t, tstMatch1('ein s', 'e?n *' )
call tstOut t, tstMatch1('ein abss ', '?i*b*' )
call tstOut t, tstMatch1('ein abss wie gehtsssxdirx und auch ' )
call tstOut t, tstMatch1('ies000', '*000' )
call tstOut t, tstMatch1('xx0x0000', '*000' )
call tstOut t, tstMatch1('000x00000xx', '000*' )
call tstOut t, tstMatch1('000xx', '*0*', 'ab*cd*ef' )
call tstOut t, tstMatch1('abcdef', '*abcdef*' )
call tstOut t, tstMatch1('abcdef', '**abcdef***' )
call tstOut t, tstMatch1('abcdef', '*cd*' )
call tstOut t, tstMatch1('abcdef', '*abc*def*' )
call tstOut t, tstMatch1('abcdef', '*bc*e*' )
call tstOut t, tstMatch1('abcdef', '**bc**ef**' )
call tstEnd t
return
tstMatch1:
parse arg w, m, m2
r = 'match('w',' m')' match(w, m) matchVars(w, m, vv) m.vv.0
do x=1 to m.vv.0
r = r','m.vv.x
end
if m2 = '' then
m2 = translate(m)
r = r 'trans('m2')' matchRep(w, m, m2)
return r
endProcedure tstMatch1
tstIntRdr: procedure expose m.
i.1 = "//A540769J JOB (CP00,KE50),'DB2 REO',"
i.2 = "// MSGCLASS=T,TIME=1440,"
i.3 = "// NOTIFY=&SYSUID,REGION=0M,SCHENV=DB2"
i.4 = "//*MAIN CLASS=LOG"
i.5 = "//S1 EXEC PGM=IEFBR14"
call writeDsn 'RR2/intRdr', i., 5, 1
return
endProcedure tstIntRdr
tstII: procedure expose m.
/*
$=/tstII/
### start tst tstII ###############################################
iiDs(org) ORG.U0009.B0106.KLEM43
iiDs(db2) DSN.DB2
iiRz2C(RZ2) 2
*** err: no key=R?Y in II_RZ2C
iiRz2C(R?Y) 0
iiRz2C(RZY) Y
iiDbSys2C(de0G) E
*** err: no key=D??? in II_DB2C
iiDbSys2C(d???) 0
iiDbSys2C(DBOF) F
iiSys2RZ(S27) RZ2
iiMbr2DbSys(DBP5) DVBP
ii_rz RZX RZY RZZ RQ2 RR2 RZ2 RZ4
ii_rz2db.rzx DE0G DEVG DX0G DPXG
rr2/dvbp RR2 R p=R d=RZ2, db DVBP P 1
iiixPut 1: RZ2 2 p=B d=RZ2, db DBOF F 0
iiixPut 1: RZ2 2 p=B d=RZ2, db DVBP P 1
iiixPut 1: RZ2 2 p=B d=RZ2, db DP2G Q 0
*** err: no key=M6R in II_MBR2DB
errHan======= mbr2DbSys(m6r?) 0
errHandlerPush Mbr2DbSys(m7r?) ?no?dbSys?
*** err: no key=M8R in II_MBR2DB
errHandlerPop Mbr2DbSys(m8r?) 0
$/tstII/
*/
call tst t, 'tstII'
call tstOut t, 'iiDs(org) ' iiDs('oRg')
call tstOut t, 'iiDs(db2) ' iiDs(db2)
call tstOut t, 'iiRz2C(RZ2) ' iiRz2C(RZ2)
call tstOut t, 'iiRz2C(R?Y) ' iiRz2C(R?Y)
call tstOut t, 'iiRz2C(RZY) ' iiRz2C(RZY)
call tstOut t, 'iiDbSys2C(de0G) ' iiDbSys2C('de0G')
call tstOut t, 'iiDbSys2C(d???) ' iiDbSys2C('d???')
call tstOut t, 'iiDbSys2C(DBOF) ' iiDbSys2C('DBOF')
call tstOut t, 'iiSys2RZ(S27) ' iiSys2RZ(S27)
call tstOut t, 'iiMbr2DbSys(DBP5)' iiMbr2DbSys(DBP5)
call tstOut t, 'ii_rz ' m.ii_rz
call tstOut t, 'ii_rz2db.rzx ' m.ii_rz2db.rzx
call pipeIni
call iiPut 'rr2/ DvBp '
call tstOut t, 'rr2/dvbp ' ,
vGet('rz') vget('rzC') 'p='vget('rzP') 'd='vget('rzD'),
|| ', db' vGet('dbSys') vGet('dbSysC') vGet('dbSysElar')
w1 = wordPos('RZ2/DBOF', m.ii_rzDb)
do wx=w1 to w1+2
call tstOut t, 'iiixPut' iiIxPut(wx)':' ,
vGet('rz') vget('rzC') 'p='vget('rzP') 'd='vget('rzD'),
|| ', db' vGet('dbSys') vGet('dbSysC') vGet('dbSysElar')
end
call tstOut t, "errHan======= mbr2DbSys(m6r?)" iiMbr2DbSys('m6r?')
call errHandlerPushRet "?no?dbSys?"
call tstOut t, "errHandlerPush Mbr2DbSys(m7r?)" iiMbr2DbSys('m7r?')
call errHandlerPop
call tstOut t, "errHandlerPop Mbr2DbSys(m8r?)" iiMbr2DbSys('m8r?')
call tstEnd t
return
endProcedure tstII
tstTime2tst: procedure expose m.
/*
$=/tstTime2tst/
### start tst tstTime2tst #########################################
2015-05-13-23.45.57.987654 ==> 735730.99025448673611 ==> 2015-05-13+
-23.45.57.987654 1
1956-04-01-23.59.59.999999 ==> 714139.99999999998843 ==> 1956-04-01+
-23.59.59.999999 1
2016-02-29-12.34.56.789087 ==> 736022.52426839221065 ==> 2016-02-29+
-12.34.56.789087 1
1567-08-23-19.59.59.999999 ==> 572203.83333333332176 ==> 1567-08-23+
-19.59.59.999999 1
$/tstTime2tst/
*/
call tst t, 'tstTime2tst'
l = '2015-05-13-23.45.57.987654 1956-04-01-23.59.59.999999' ,
'2016-02-29-12.34.56.789087 1567-08-23-19.59.59.999999'
do lx=1 to 4
v = word(l, lx)
w = timeDays2tst(timestamp2days(v))
call tstOut t, v '==>' timestamp2days(v) '==>' w (v = w)
end
call tstEnd t
return
endProcedure tstTime2tst
tstTime: procedure
/* Winterzeit dez 2011
$=/tstTime/
### start tst tstTime #############################################
05-28-00.00 2days 735745
05-28-04.00 2days 735745.16666666666667
05-28-21.00 2days 735745.9
05-29-00.00 2days 735746
16-05-28-00 2days 736111
16...12 - 15...06 366.25000000000000
2016-05-28-12.23.45 .
2016-05-28-12-23.45 bad timestamp 2016-05-28-12-23
2016.05-28-12.23.45 bad timestamp 2016.05-28-12.23
2016-05-28-12.23.45.987654 .
2016-0b-28-12.23.45 bad timestamp 2016-0b-28-12.23
2016-05-28-12.23.45.9876543 bad timestamp 2016-05-28-12.23
2016-05-28-12.23.45.98-654 bad timestamp 2016-05-28-12.23
2016-00-28-12.23.45 bad month in timestamp 2016-00
2016-05-28-13.23.45 .
2016-15-28-12.23.45 bad month in timestamp 2016-15
2016-05-31-12.23.45 .
2016-04-31-13.23.45 bad day in timestamp 2016-04-3
2015-04-30-12.23.45 .
2016-02-30-12.23.45 bad day in timestamp 2016-02-3
2016-02-29-13.23.45 .
2015-02-29-12.23.45 bad day in timestamp 2015-02-2
2016-07-30-25.00.00 bad hour in timestamp 2016-07-
2016-04-07-24.00.00.0 .
2015-02-19-24.00.01 bad hour in timestamp 2015-02-
Lrsn2Lzt(00C5E963363741000000) 2010-05-01-11.34.54.789008
Achtung: output haengt von Winter/SommerZ & LeapSecs ab
stckUnit = 0.000000000244140625
timeLeap = 00000018CBA80000 = 106496000000 = 26.000 secs
timeZone = 00000D693A400000 = 14745600000000 = 3600.000 secs
timeUQZero = 207090001374976
timeUQDigis = 35 digits ABCDEFGHIJKLMNOPQRSTUVWXYZ012345678
2jul(2011-03-31-14.35.01.234567) 11090
Lrsn2TAI10(00C5E963363741000000) 2010-05-01-10.35.20.789008
Lrsn2Lzt(00C5E963363741000000) 2010-05-01-11.34.54.789008
TAI102Lrsn(2011-03-31-14.35.01.234567) 00C78D87B86E38700000
lzt2Lrsn(2011-03-31-14.35.01.234567) 00C78D7A67FFA0700000
Lrsn2TAI10(TAI102Lrsn(2011-03-31-14.35.01.234567) +
2011-03-31-14.35.01.234567
TAI102Lrsn(Lrsn2TAI10(00C5E963363741000000) 00C5E963363741000000
Lrsn2LZt(LZt2Lrsn(2011-03-31-14.35.01.234567) 2011-03-31-14.35.01.2+
34567
LZt2Stc(Lrsn2LZt(00C5E963363741000000) 00C5E963363741000000
Lrsn2uniq(00C5E963363741000000) CTNR6S7T back 00C5E963363740000000
Lrsn2LZt(LZt2Lrsn(2051-10-31-14.35.01.234567) 2051-10-31-14.35.01+
..234567
Lrsn2TAI10(01010000000000000000) 2043-04-09-14.36.53.414912
$/tstTime/
*/
call jIni
call timeIni
call tst t, 'tstTime'
call out '05-28-00.00 2days ' timestamp2days('2015-05-28-00.00.00')
call out '05-28-04.00 2days ' timestamp2days('2015-05-28-04.00.00')
call out '05-28-21.00 2days ' timestamp2days('2015-05-28-21.36.00')
call out '05-29-00.00 2days ' timestamp2days('2015-05-29-00.00.00')
call out '16-05-28-00 2days ' timestamp2days('2016-05-28-00.00.00')
call out '16...12 - 15...06 ' timestampDiff( '2016-05-28-12.23.45',
, '2015-05-28-06.23.45')
l = '2016-05-28-12.23.45 2016-05-28-12-23.45 2016.05-28-12.23.45',
'2016-05-28-12.23.45.987654 2016-0b-28-12.23.45' ,
'2016-05-28-12.23.45.9876543 2016-05-28-12.23.45.98-654' ,
'2016-00-28-12.23.45 2016-05-28-13.23.45 2016-15-28-12.23.45',
'2016-05-31-12.23.45 2016-04-31-13.23.45 2015-04-30-12.23.45',
'2016-02-30-12.23.45 2016-02-29-13.23.45 2015-02-29-12.23.45',
'2016-07-30-25.00.00 2016-04-07-24.00.00.0 2015-02-19-24.00.01'
do lx=1 to words(l)
call out left(word(l, lx), 30),
strip(left(timestampCheck(word(l, lx)), 30), 't')
end
t1 = '2011-03-31-14.35.01.234567'
t2 = '2051-10-31-14.35.01.234567'
s1 = timeLrsnExp('C5E963363741')
s2 = timeLrsnExp('0101')
call out 'Lrsn2Lzt('s1')' timeLrsn2Lzt(s1)
call out 'Achtung: output haengt von Winter/SommerZ & LeapSecs ab'
numeric digits 15
call out 'stckUnit =' m.time_StckUnit
call out 'timeLeap =' d2x(m.time_Leap,16) '=' m.time_Leap ,
'=' format(m.time_Leap * m.time_StckUnit,9,3) 'secs'
call out 'timeZone =' d2x(m.time_Zone,16) '=' m.time_Zone,
'=' format(m.time_Zone * m.time_StckUnit,6,3) 'secs'
/* call out "cvtext2_adr =" d2x(cvtExt2A, 8) */
call out 'timeUQZero =' m.time_UQZero
call out 'timeUQDigis =' ,
length(m.time_UQDigits) 'digits' m.time_UQDigits
call out '2jul('t1') ' time2jul(t1)
call out 'Lrsn2TAI10('s1')' timelrsn2TAI10(s1)
call out 'Lrsn2Lzt('s1')' timeLrsn2Lzt(s1)
call out 'TAI102Lrsn('t1')' timeTAI102Lrsn(t1)
call out 'lzt2Lrsn('t1')' timeLzt2Lrsn(t1)
call out 'Lrsn2TAI10(TAI102Lrsn('t1')' ,
timeLrsn2TAI10(timeTAI102Lrsn(t1))
call out 'TAI102Lrsn(Lrsn2TAI10('s1')' ,
timeTAI102Lrsn(timelrsn2TAI10(s1))
call out 'Lrsn2LZt(LZt2Lrsn('t1')' timeLrsn2LZt(timeLZt2Lrsn(t1))
call out 'LZt2Stc(Lrsn2LZt('s1')' timeLZt2Lrsn(timeLrsn2LZt(s1))
call out 'Lrsn2uniq('s1')' timeLrsn2Uniq(s1) ,
'back' timeUniq2Lrsn(timeLrsn2Uniq(s1))
call out 'Lrsn2LZt(LZt2Lrsn('t2')' timeLrsn2LZt(timeLZt2Lrsn(t2))
call out 'Lrsn2TAI10('s2')' timelrsn2TAI10(s2)
call tstEnd t
return
endProcedure tstTime
tstMat: procedure expose m.
/*
$=/tstMat/
### start tst tstMat ##############################################
. 0 sqrt 0 isPrime 0 nxPrime 3 permut 1 > 1 2 3 4 5
. 1 sqrt 1 isPrime 0 nxPrime 3 permut 2 > 2 1 3 4 5
. 2 sqrt 1 isPrime 1 nxPrime 3 permut 3 > 1 3 2 4 5
. 3 sqrt 1 isPrime 1 nxPrime 3 permut 3 > 2 3 1 4 5
. 4 sqrt 2 isPrime 0 nxPrime 5 permut 3 > 3 2 1 4 5
. 5 sqrt 2 isPrime 1 nxPrime 5 permut 3 > 3 1 2 4 5
. 6 sqrt 2 isPrime 0 nxPrime 7 permut 4 > 1 2 4 3 5
. 7 sqrt 2 isPrime 1 nxPrime 7 permut 4 > 2 1 4 3 5
. 8 sqrt 2 isPrime 0 nxPrime 11 permut 4 > 1 3 4 2 5
. 9 sqrt 3 isPrime 0 nxPrime 11 permut 4 > 2 3 4 1 5
. 10 sqrt 3 isPrime 0 nxPrime 11 permut 4 > 3 2 4 1 5
. 11 sqrt 3 isPrime 1 nxPrime 11 permut 4 > 3 1 4 2 5
. 12 sqrt 3 isPrime 0 nxPrime 13 permut 4 > 1 4 3 2 5
. 13 sqrt 3 isPrime 1 nxPrime 13 permut 4 > 2 4 3 1 5
. 14 sqrt 3 isPrime 0 nxPrime 17 permut 4 > 1 4 2 3 5
. 15 sqrt 3 isPrime 0 nxPrime 17 permut 4 > 2 4 1 3 5
. 16 sqrt 4 isPrime 0 nxPrime 17 permut 4 > 3 4 1 2 5
. 17 sqrt 4 isPrime 1 nxPrime 17 permut 4 > 3 4 2 1 5
. 18 sqrt 4 isPrime 0 nxPrime 19 permut 4 > 4 2 3 1 5
$/tstMat/
$/tstMat/
*/
call tst t, 'tstMat'
q = 'tst_Mat'
do qx=1 to 20
m.q.qx = qx
end
do i=0 to 18
call permut q, i
call tstOut t, right(i,4) 'sqrt' right(sqrt(i), 2) ,
'isPrime' isPrime(i) 'nxPrime' right(nxPrime(i), 4) ,
'permut' m.q.0 '>' m.q.1 m.q.2 m.q.3 m.q.4 m.q.5
end
call tstEnd t
return
endProcedure tstMat
/****** tstSql ********************************************************/
tstSqlUtils: procedure expose m.
call sqlConnect 'DBAF'
id = 'A540769.dsnUtils'
rst = 'NO'
retcode = -9876
e = ''
z = 0
st = "TEMPLATE TCOPYD",
"DSN('&SSID..&JO..&US..P&PART(2)..D&DATE(3)..T&TIME.')",
"DATACLAS(NULL12) MGMTCLAS(COM#A011) STORCLAS(FAR$N)",
"SPACE (150,3750) TRK UNCNT 59;",
"listdef abc include tablespace DA540769.A002* partlevel;",
"listdef mf include tablespace MF01A1A.A110A partlevel;",
"copy list abc copyddn(tcopyd) shrlevel change;"
st = translate(st)
call sqlExec "call SYSPROC.DSNUTILS ( :id, :rst,",
":st,:retcode, :ANY" copies(',:e,:e,:z',12) ")"
call sqlExec ,
'ASSOCIATE LOCATOR (:RESULTS) WITH PROCEDURE SYSPROC.DSNUTILS'
say 'results' results
call sqlExec 'ALLOCATE C111 CURSOR FOR RESULT SET :RESULTS'
say 'allocated c111'
do while sqlExec('fetch c111 into :seq, :txt', 0 100) = 0
say 'sysPrint' seq strip(txt, 't')
end
call sqlExec 'close c111'
say 'closed'
call sqlDisconnect
exit
endProcedure tstSqlUtils
tstSqlStored: procedure expose m.
call sqlConnect 'DBAF'
rst = 'NO'
retcode = -9876
e = ''
z = 0
st = "abc"
call sqlExec "call SYSPROC.COMMAND ( :st, :rst)"
say 'after call st='st 'rst='rst
call sqlExec ,
'ASSOCIATE LOCATOR (:RESULTS) WITH PROCEDURE SYSPROC.COMMAND'
say 'results' results
call sqlExec 'ALLOCATE C111 CURSOR FOR RESULT SET :RESULTS'
say 'allocated c111'
do while sqlExec('fetch c111 into :seq, :txt', 0 100) = 0
say 'sysPrint' seq strip(txt, 't')
end
call sqlExec 'close c111'
say 'closed'
call sqlDisconnect
return
endProcedure tstSqlStored
tstSqlStoredWK: procedure expose m.
call sqlConnect 'DBAF'
/* st = "direct wkUtiSub"
rst = 'NO'
say 'before call st='st 'rst='rst
call sqlExec "call A540769.WKUTILSUB ( :st, :rst)"
say 'after call st='st 'rst='rst
*/ rst = 'NO'
retcode = -9876
e = ''
z = 0
prc = 'DB2UTIL.DB2UTIL'
st = "DA540769.A2*" /* DA540769.A1*" */
say "call" prc "("st", ...)"
call sqlExec "call" prc "(:st, :rst)"
say 'after call st='st 'rst='rst
call sqlExec ,
'ASSOCIATE LOCATOR (:RESULTS) WITH PROCEDURE' prc
/* say 'results' results */
call sqlExec 'ALLOCATE C111 CURSOR FOR RESULT SET :RESULTS'
say ''
say '***** utility output'
do while sqlExec('fetch c111 into :seq, :txt', 0 100) = 0
say 'sysPrint' seq strip(txt, 't')
end
call sqlExec 'close c111'
say '***** end output'
call sqlDisconnect
return 0
endProcedure tstSqlStoredWK
tstSqlStoredSQL1: procedure expose m.
call sqlConnect 'DBIA'
rst = 'NO'
retcode = -9876
e = ''
z = 0
st = "DA540769.A2* DA540769.A1*"
call sqlExec "call A540769.WKSQL1 ( :st, :rst)"
say 'after call st='st 'rst='rst
call sqlExec ,
'ASSOCIATE LOCATOR (:RESULTS) WITH PROCEDURE A540769.WKUTIL'
say 'results' results
call sqlExec 'ALLOCATE C111 CURSOR FOR RESULT SET :RESULTS'
say 'allocated c111'
do while sqlExec('fetch c111 into :seq, :txt', 0 100) = 0
say 'sysPrint' seq strip(txt, 't')
end
call sqlExec 'close c111'
say 'closed'
call sqlDisconnect
return
endProcedure tstSqlStoredSQL1
tstSqlTriggerTiming:
parse upper arg tb ni
m.noInsert = ni == 0
cnt = 200000
if tb = '' then
TB = 'GDB9998.TWK511TRI'
call sqlConnect dbaf
say timing() 'noInsert' m.noInsert 'tb' tb
call sql2St 'select max(pri) MX from' tb, cc
if m.cc.1.mx == m.sqlNull then
m.cc.1.mx = 0
von = m.cc.1.mx + 1
bis = m.cc.1.mx + cnt
say m.cc.0 'max' m.cc.1.mx 'von' von 'bis' bis 'count' cnt tb
if right(tb, 2) = 'A1' then do
call sqlPrepare 3, 'insert into' tb '(pri, short, long, par)' ,
'values (?, ?, ?, ?)'
do ax=von to bis
call sqlExecute 3, ax,
, ax 'wsh short', ax 'wsh long long long long long ',
, (ax-1) // 1000 + 1
end
end
else do
call sqlPrepare 3, 'insert into' tb '(pri, short, long)' ,
'values (?, ?, ?)'
do ax=von to bis
call sqlExecute 3, ax,
, ax 'wsh short', ax 'wsh long long long long long ',
, (ax-1) // 1000 + 1
end
end
/* call sqlLn 5,,, 'select * from' tb 'where pri >=' von */
call sqlCommit
say timing()
call sqlDisconnect
return
endProcedure tstSqlTriggerTiming
tstSqlRx: procedure expose m.
/*
$=/tstSqlRx/
### start tst tstSqlRx ############################################
*** err: SQLCODE = -204: A540769.SYSDUMMY IS AN UNDEFINED NAME
. e 1: sql = select * from sysdummy
. e 2: stmt = prepare s7 into :M.SQL.7.D from :src
. e 3: with into :M.SQL.7.D = M.SQL.7.D
fetchA 1 ab=m.abcdef.123.AB=abc ef=efg
fetchA 0 ab=m.abcdef.123.AB=abc ef=efg
fetchB 1 ab=a cd=2 ef=--- ind=-1 gh=d ind=0
fetchB 0 ab=a cd=2 ef=--- ind=-1 gh=d ind=0
fetchC 1 a=a b=2 c=--- d=d
fetchC 0 a=a b=2 c=--- d=d
fetchBT 1 SYSTABLES
fetchBT 0 SYSTABLES
fetchBi 1 SYSINDEXES
fetchBi 0 SYSINDEXES
$/tstSqlRx/ */
call jIni
call tst t, "tstSqlRx"
call sqlRxConnect
cx = 7
call sqlRxQuery cx, 'select * from sysdummy'
call sqlRxQuery cx, "select 'abc' , 'efg'",
'from sysibm.sysDummy1', ':m.dst.ab, :m.dst.ef'
a = 'abcdef'
b = 123
drop m.a.b.ab m.a.b.ef
do i=1 to 2
call out 'fetchA' sqlRxFetch(cx, a || '.' || b) ,
'ab=m.'a'.'||b'.'ab'='m.a.b.ab 'ef='m.a.b.ef
end
call sqlRxClose cx
drop m.a.b.ab m.a.ab.ef a b c
sql = "select 'a' a, 2 b, case when 1=0 then 1 else null end c",
", case when 1=1 then 'd' else null end d",
"from sysibm.sysDummy1"
call sqlRxQuery cx, sql, 'AB CD EF GH'
st = 'abc.Def.123'
drop m.st.ab m.st.cd m.st.ef m.st.ef.sqlInd m.st.gh m.st.gh.sqlInd
do i=1 to 2
call out 'fetchB' sqlRxFetch(cx, st) ,
'ab='m.st.ab 'cd='m.st.cd 'ef='m.st.ef 'ind='m.st.ef.sqlInd,
'gh='m.st.gh 'ind='m.st.gh.sqlInd
end
call sqlRxClose cx
drop m.st.ab m.st.bc m.st.df m.st.df.sqlInd
call sqlRxQuery cx, sql
st = 'abc.Def.123'
drop m.st.a m.st.b m.st.c m.st.d
do i=1 to 2
call out 'fetchC' sqlRxFetch(cx, st) ,
'a='m.st.a 'b='m.st.b 'c='m.st.c 'd='m.st.d
end
drop m.st.a m.st.b m.st.c m.st.d
call sqlRxClose cx
drop m.st.1.a m.st.1.b m.st.1.c m.st.1.d m.st.0
call sqlQueryPrepare cx, "select name" ,
"from sysibm.sysTables" ,
"where creator = 'SYSIBM' and name = ?",':m.nm'
call sqlQueryExecute cx, 'SYSTABLES'
call out 'fetchBT' sqlRxFetch(cx) m.nm
call out 'fetchBT' sqlRxFetch(cx) m.nm
call sqlRxClose cx
call sqlQueryExecute cx, 'SYSINDEXES'
call out 'fetchBi' sqlRxFetch(cx) m.nm
call out 'fetchBi' sqlRxFetch(cx) m.nm
call tstEnd t
call sqlRxDisconnect
return
endProcedure tstSqlRx
tstSql: procedure expose m.
/*
$=/tstSql/
### start tst tstSql ##############################################
*** err: SQLCODE = -204: A540769.SYSDUMMY IS AN UNDEFINED NAME
. e 1: sql = select * from sysdummy
. e 2: stmt = prepare s7 into :M.SQL.7.D from :src
. e 3: with into :M.SQL.7.D = M.SQL.7.D
fetchA 1 ab=m.abcdef.123.AB=abc ef=efg
fetchA 0 ab=m.abcdef.123.AB=abc ef=efg
fetchB 1 ab=a cd=2 ef=--- ind=-1 gh=d ind=0
fetchB 0 ab=a cd=2 ef=--- ind=-1 gh=d ind=0
fetchC 1 a=a b=2 c=--- d=d
fetchC 0 a=a b=2 c=--- d=d
sql2St 1 st.0=1
sql2St:1 a=a b=2 c=--- d=d
sql2One a
sql2One a=a b=2 c=--- d=d
fetchBT 1 SYSTABLES
fetchBT 0 SYSTABLES
fetchBi 1 SYSINDEXES
fetchBi 0 SYSINDEXES
$/tstSql/ */
call jIni
call tst t, "tstSql"
call sqlConnect
cx = 7
call sqlQuery cx, 'select * from sysdummy'
call sqlQuery cx, "select 'abc' , 'efg'",
'from sysibm.sysDummy1', ':m.dst.ab, :m.dst.ef'
a = 'abcdef'
b = 123
drop m.a.b.ab m.a.b.ef
do i=1 to 2
call out 'fetchA' sqlFetch(cx, a || '.' || b) ,
'ab=m.'a'.'||b'.'ab'='m.a.b.ab 'ef='m.a.b.ef
end
call sqlClose cx
drop m.a.b.ab m.a.ab.ef a b c
sql = "select 'a' a, 2 b, case when 1=0 then 1 else null end c",
", case when 1=1 then 'd' else null end d",
"from sysibm.sysDummy1"
call sqlQuery cx, sql, 'AB CD EF GH'
st = 'abc.Def.123'
drop m.st.ab m.st.cd m.st.ef m.st.ef.sqlInd m.st.gh m.st.gh.sqlInd
do i=1 to 2
call out 'fetchB' sqlFetch(cx, st) ,
'ab='m.st.ab 'cd='m.st.cd 'ef='m.st.ef 'ind='m.st.ef.sqlInd,
'gh='m.st.gh 'ind='m.st.gh.sqlInd
end
call sqlClose cx
drop m.st.ab m.st.bc m.st.df m.st.df.sqlInd
call sqlQuery cx, sql
st = 'abc.Def.123'
drop m.st.a m.st.b m.st.c m.st.d
do i=1 to 2
call out 'fetchC' sqlFetch(cx, st) ,
'a='m.st.a 'b='m.st.b 'c='m.st.c 'd='m.st.d
end
drop m.st.a m.st.b m.st.c m.st.d
call sqlClose cx
drop m.st.1.a m.st.1.b m.st.1.c m.st.1.d m.st.0
call out 'sql2St' sql2St(sql, st) 'st.0='m.st.0
do i=1 to m.st.0
call out 'sql2St:'i ,
'a='m.st.i.a 'b='m.st.i.b 'c='m.st.i.c 'd='m.st.i.d
end
drop m.st.1.a m.st.1.b m.st.1.c m.st.1.d m.st.0
drop m.st.a m.st.b m.st.c m.st.d m.st.0
call out 'sql2One' sql2One(sql, st)
call out 'sql2One' ,
'a='m.st.a 'b='m.st.b 'c='m.st.c 'd='m.st.d
drop m.st.a m.st.b m.st.c m.st.d m.st.0
call sqlQueryPrepare cx, "select name" ,
"from sysibm.sysTables" ,
"where creator = 'SYSIBM' and name = ?",':m.nm'
call sqlQueryExecute cx, 'SYSTABLES'
call out 'fetchBT' sqlFetch(cx) m.nm
call out 'fetchBT' sqlFetch(cx) m.nm
call sqlClose cx
call sqlQueryExecute cx, 'SYSINDEXES'
call out 'fetchBi' sqlFetch(cx) m.nm
call out 'fetchBi' sqlFetch(cx) m.nm
call tstEnd t
call sqlDisconnect
return
endProcedure tstSql
tstSqlCsm: procedure expose m.
/*
$=/tstSqlCsm/
### start tst tstSqlCsm ###########################################
*** err: SQLCODE = -204: S100447.SYSDUMMY IS AN UNDEFINED NAME
. e 1: sql = select * from sysdummy
. e 2: subsys = DE0G, host = RZZ
*** err: implement sqlCmsQuery fetchVars ? or : :m.dst.ab, :m.dst.ef
fetchA 0 ab=m.abcdef.123.AB=M.abcdef.123.AB ef=M.abcdef.123.EF
fetchA 0 ab=m.abcdef.123.AB=M.abcdef.123.AB ef=M.abcdef.123.EF
fetchB 1 ab=a cd=2 ef=--- ind=M.abc.Def.123.EF.SQLIND gh=d ind=M.ab+
c.Def.123.GH.SQLIND
fetchB 0 ab=a cd=2 ef=--- ind=M.abc.Def.123.EF.SQLIND gh=d ind=M.ab+
c.Def.123.GH.SQLIND
fetchC 1 a=a b=2 c=--- d=d
fetchC 0 a=a b=2 c=--- d=d
$/tstSqlCsm/ */
call pipeIni
call tst t, "tstSqlCsm"
call sqlConnect m.tst_csmDbSys
cx = 7
call sqlCsmQuery cx, 'select * from sysdummy'
call sqlCsmQuery cx, "select 'abc' , 'efg'",
'from sysibm.sysDummy1', ':m.dst.ab, :m.dst.ef'
a = 'abcdef'
b = 123
drop m.a.b.ab m.a.b.ef
do i=1 to 2
call out 'fetchA' sqlCsmFetch(cx, a || '.' || b) ,
'ab=m.'a'.'||b'.'ab'='m.a.b.ab 'ef='m.a.b.ef
end
drop m.a.b.ab m.a.ab.ef a b c
sql = "select 'a' a, 2 b, case when 1=0 then 1 else null end c",
", case when 1=1 then 'd' else null end d",
"from sysibm.sysDummy1"
call sqlCsmQuery cx, sql, 'AB CD EF GH'
st = 'abc.Def.123'
drop m.st.ab m.st.cd m.st.ef m.st.ef.sqlInd m.st.gh m.st.gh.sqlInd
do i=1 to 2
call out 'fetchB' sqlCsmFetch(cx, st) ,
'ab='m.st.ab 'cd='m.st.cd 'ef='m.st.ef 'ind='m.st.ef.sqlInd,
'gh='m.st.gh 'ind='m.st.gh.sqlInd
end
drop m.st.ab m.st.bc m.st.df m.st.df.sqlInd
call sqlCsmQuery cx, sql
st = 'abc.Def.123'
drop m.st.a m.st.b m.st.c m.st.d
do i=1 to 2
call out 'fetchC' sqlCsmFetch(cx, st) ,
'a='m.st.a 'b='m.st.b 'c='m.st.c 'd='m.st.d
end
drop m.st.a m.st.b m.st.c m.st.d
drop m.st.1.a m.st.1.b m.st.1.c m.st.1.d m.st.0
call tstEnd t
call sqlDisconnect
return
endProcedure tstsqlCsm
tstSqlCSV: procedure expose m.
/*
$=/tstSqlCSV/
### start tst tstSqlCSV ###########################################
NAME,CREATOR,MITCOM,MITQUO,MITNU,COL6
SYSTABLES,SYSIBM ,"a,b","a""b",1,8
SYSTABLESPACE,SYSIBM ,"a,b","a""b",---,8
SYSTABLESPACESTATS,SYSIBM,"a,b","a""b",---,6
$/tstSqlCSV/ */
call csvIni
call scanReadIni
call sqlConnect
call tst t, "tstSqlCSV"
r = csvWrt(sqlRdr("select name, creator, 'a,b' mitCom",
", 'a""b' mitQuo" ,
", case when name='SYSTABLES' then 1 else null end mitNu" ,
",length(creator)" ,
"from sysibm.sysTables" ,
"where creator = 'SYSIBM' and name like 'SYSTABLES%'",
"fetch first 3 rows only"))
call pipeWriteAll r
call sqlDisConnect
call tstEnd t
return
endProcedure tstSqlCsv
tstSqlB: procedure expose m.
/*
$=/tstSqlB/
### start tst tstSqlB #############################################
#jIn 1# select strip(name) "tb", strip(creator) cr
#jIn 2# , case when name = 'SYSTABLES' then 1 else null end
#jIn 3# from sysibm.sysTables
#jIn 4# where creator = 'SYSIBM' and name like 'SYSTABLES%'
#jIn 5# .
#jIn 6# order by name
#jIn 7# fetch first 3 rows only
#jIn eof 8#
dest1.fet: SYSTABLES SYSIBM 1
dest2.fet: SYSTABLESPACE SYSIBM ---
dest3.fet: SYSTABLESPACESTATS SYSIBM ---
$/tstSqlB/ */
call pipeIni
call tst t, "tstSqlB"
cx = 9
call sqlConnect
call jIni
call mAdd mCut(t'.IN', 0),
, 'select strip(name) "tb", strip(creator) cr' ,
, ", case when name = 'SYSTABLES' then 1 else null end" ,
, "from sysibm.sysTables" ,
, "where creator = 'SYSIBM' and name like 'SYSTABLES%'", ,
, "order by name",
, "fetch first 3 rows only"
call sqlQuery cx, in2Str(,' ')
do qx=1 while sqlFetch(cx, 'dest'qx'.fet')
dst = 'dest'qx'.fet'
call out dst':' m.dst.tb m.dst.cr m.dst.col3
drop m.dst.tb m.dst.cr m.dst.col3
end
call sqlClose cx
call sqlDisconnect
call tstEnd t
return
endProcedure tstSqlB
tstSqlFTab: procedure expose m.
/*
$=/tstSqlFTab/
### start tst tstSqlFTab ##########################################
UPDATESTATSTIME----------------NACTIVE------NPAGES-EXTENT-LOADRLAST+
TIME--------------REORGLASTTIME--------------REORGINSERT-REORGDELET+
E-REORGUPDATE-REORGUNCLUS-REORGDISORG-REORGMASSDE-REORGNEARIN-REORG+
FARIND-STATSLASTTIME--------------STATSINSERT-STATSDELETE-STATSUPDA+
TE-STATSMASSDE-COPYLASTTIME---------------COPYUPDATED-COPYCHANGES-C+
OPYUPDATE-COPYUPDATETIME-------------I---DBID---PSID-PARTIT-INSTAN-+
--SPACE-TOTALRO-DATASIZ-UNCOMPR-DBNAME-------NAME---------REORGCL-R+
EORGSC-REORGHA-HASHLASTUS-DRI-L-STATS01-UPDATES-LASTDATACHANGE-----+
----------
--- modified
allg vorher others vorher
db-------ts---------part---inst-UPDATESTATSTIME----------------NACT+
IVE------NPAGES-EXTENT-LOADRLASTTIME--------------REORGLASTTIME----+
----------REORGINSERT-REORGDELETE-REORGUPDATE-REORGUNCLUS-REORGDISO+
RG-REORGMASSDE-REORGNEARIN-REORGFARIND-STATSLASTTIME--------------S+
TATSINSERT-STATSDELETE-STATSUPDATE-STATSMASSDE-COPYLASTTIME--------+
-------COPYUPDATED-COPYCHANGES-COPYUPDATE-COPYUPDATETIME-----------+
--I---DBID---PSID---SPACE-TOTALRO-DATASIZ-UNCOMPR-REORGCL-REORGSC-R+
EORGHA-HASHLASTUS-DRI-L-STATS01-UPDATES-LASTDATACHANGE-------------+
--
db-------ts---------part---inst-UPDATESTATSTIME----------------NACT+
IVE------NPAGES-EXTENT-LOADRLASTTIME--------------REORGLASTTIME----+
----------REORGINSERT-REORGDELETE-REORGUPDATE-REORGUNCLUS-REORGDISO+
RG-REORGMASSDE-REORGNEARIN-REORGFARIND-STATSLASTTIME--------------S+
TATSINSERT-STATSDELETE-STATSUPDATE-STATSMASSDE-COPYLASTTIME--------+
-------COPYUPDATED-COPYCHANGES-COPYUPDATE-COPYUPDATETIME-----------+
--I---DBID---PSID---SPACE-TOTALRO-DATASIZ-UNCOMPR-REORGCL-REORGSC-R+
EORGHA-HASHLASTUS-DRI-L-STATS01-UPDATES-LASTDATACHANGE-------------+
--
allg nachher others nachher
DBNAME INSTANCE +
. NPAGES REORGLASTTIME +
. REORGUPDATES +
. REORGMASSDELETE STATSLASTTIME +
. STATSUPDATES +
. COPYUPDATEDPAGES COPYUPDATETIME +
. PSID DATASIZE REO+
RGSCANACCESS DRIVETYPE UPDATESIZE
. NAME UPDATESTATSTIME +
. EXTENTS +
. REORGINSERTS REORGUNCLUSTINS +
. REORGNEARINDREF +
. STATSINSERTS STATSMASSDELETE +
. COPYCHANGES +
. IBMREQD SPACE UNCOMPRESSEDDATASI+
ZE REORGHASHACCESS LPFACILITY LASTDATACHANGE
. PARTITION NACTIVE+
. LOADRLASTTIME +
. REORGDELETES REORGD+
ISORGLOB REORGFARINDREF +
. STATSDELETES COPYLASTTIME +
. COPYUPDATELRSN +
. DBID TOTALROWS REORGCLUSTE+
RSENS HASHLASTUSED STATS01
$/tstSqlFTab/
*/
call pipeIni
call tst t, 'tstSqlFTab'
call sqlConnect
call sqlQuery 17, 'select * from sysibm.sysTablespaceStats' ,
"where dbName = 'xxxDB06' and name = 'SYSTSTAB'"
call sqlFTabOpts fTabReset(abc, 1, ,'-'), 17, 12
call sqlFTabDef abc, 492, '%7e'
call sqlFTabOthers abc
call sqlfTab abc
call sqlClose 17
call out '--- modified'
call sqlQuery 17, 'select * from sysibm.sysTablespaceStats' ,
"where dbName = 'xxxDB06' and name = 'SYSTSTAB'"
call sqlFTabOpts fTabReset(abc, 2 1, 1 3 'c', '-'), 17, 12
call sqlFTabDef abc, 492, '%7e'
call sqlFTabAdd abc, DBNAME, '%-8C', 'db', 'allg vorher' ,
, 'allg nachher'
call sqlFTabAdd abc, NAME , '%-8C', 'ts'
call sqlFTabAdd abc, PARTITION , , 'part'
call sqlFTabAdd abc, INSTANCE , , 'inst'
ox = m.abc.0 + 1
call sqlFTabOthers abc
call fTabAddTit abc, ox, 2, 'others vorher'
call fTabAddTit abc, ox, 3, 'others nachher'
call sqlFTab abc
call sqlClose 17
call tstEnd t
call sqlDisConnect
return
endProcedure tstSqlFTab
tstSqlFTab2: procedure expose m.
/*
$=/tstSqlFTab2/
### start tst tstSqlFTab2 #########################################
Und Eins Oder
. zw aber
Und Eins---------------zw aber---
. und eins 22223
. und eins 22224
Und Eins---------------zw aber---
Und Eins Oder
. zw aber
a-------------b---
aaa 222
a-------------b---
--- row 1 ---------------------------------------------------------+
-------------
. Und Eins Oder und eins
. zw aber 2.2223000e04 22223
--- row 2 ---------------------------------------------------------+
-------------
. Und Eins Oder und eins
. zw aber 2.2224000e04 22224
--- end of 2 rows -------------------------------------------------+
-------------
$/tstSqlFTab2/
*/
call pipeIni
call tst t, 'tstSqlFTab2'
call sqlConnect
sq1 = 'select '' und eins'' "Und Eins Oder"',
', 22222 + row_number() over() "zw aber" ',
'from sysibm.sysTables fetch first 2 rows only'
call sqlQuery 17, sq1
call sqlFTab sqlFTabOthers(sqlfTabReset(tstSqlFtab2, 17))
call sqlClose 17
sq2 = 'select ''aaa'' "a", 222 "b"' ,
'from sysibm.sysTables fetch first 1 rows only'
call sqlQuery 17, sq2
call sqlFTab sqlFTabOthers(sqlfTabReset(tstSqlFtab2, 17))
call sqlClose 17
call sqlQuery 15, sq1
call sqlFTabCol sqlFTabOthers(sqlfTabReset(tstSqlFtab5, 15))
call sqlClose 15
call tstEnd t
call sqlDisConnect
return
endProcedure tstSqlFTab2
tstSqlFTab3: procedure expose m.
/*
$=/tstSqlFTab3/
### start tst tstSqlFTab3 #########################################
Und Eins Oder
. zw aber
Und Eins--z---
. und eins 1
. und eins 2
Und Eins--z---
Und Eins Oder
. zw aber
a-----b---
aaa 222
a-----b---
$/tstSqlFTab3/
*/
call pipeIni
call tst t, 'tstSqlFTab3'
call sqlConnect
sq1 = 'select '' und eins'' "Und Eins Oder"',
', row_number() over() "zw aber" ',
'from sysibm.sysTables fetch first 2 rows only'
r = jOpen(sqlRdr(sq1), '<')
f = sqlRdrfTabReset(r, 'tstSqFTab3')
b = in2Buf(r)
call sqlFTabDetect f, b'.BUF'
call fTab f, b
call jClose r
sq2 = 'select ''aaa'' "a", 222 "b"' ,
'from sysibm.sysTables fetch first 1 rows only'
call sqlQuery 17, sq2
f = sqlfTabReset('tstSqFTab3t', 17)
st = 'tstSqFTab3st'
call sqlFetch2St 17, st
s2 = 'tstSqFTab3s2'
do sx=1 to m.st.0
m.s2.sx = st'.'sx
end
m.s2.0 = m.st.0
call sqlFTabDetect f, s2
call fTabBegin f
do sx=1 to m.st.0
call out f(m.f.fmt, st'.'sx)
end
call fTabEnd f
call tstEnd t
call sqlDisConnect
return
endProcedure tstSqlFTab3
tstSqlFTab4: procedure expose m.
/*
$=/tstSqlFTab4/
### start tst tstSqlFTab4 #########################################
a
1
1 rows fetched: select 1 "a" from sysibm.sysDummy1
sqlCode -204: drop table gibt.EsNicht
a
2
1 rows fetched: select 2 "a" from sysibm.sysDummy1
*** err: SQLCODE = -104: ILLEGAL SYMBOL "Y". SOME SYMBOLS THAT MIGH+
T
. e 1: BE LEGAL ARE: , FROM INTO
. e 2: src select x frm y
. e 3: > <<<pos 14 of 14<<<
. e 4: sql = select x frm y
. e 5: stmt = prepare s10 into :M.SQL.10.D from :src
. e 6: with into :M.SQL.10.D = M.SQL.10.D
sqlCode -104: select x frm y
a
3
1 rows fetched: select 3 "a" from sysibm.sysDummy1
dy => 1
a
1
1 rows fetched: select 1 "a" from sysibm.sysDummy1
sqlCode -204: drop table gibt.EsNicht
a
2
1 rows fetched: select 2 "a" from sysibm.sysDummy1
SQLCODE = -104: ILLEGAL SYMBOL "Y". SOME SYMBOLS THAT MIGHT
. BE LEGAL ARE: , FROM INTO
src select x frm y
. > <<<pos 14 of 14<<<
sql = select x frm y
stmt = prepare s10 into :M.SQL.10.D from :src
with into :M.SQL.10.D = M.SQL.10.D
sqlCode 0: rollback
ret => 0
$/tstSqlFTab4/
*/
call pipeIni
call tst t, 'tstSqlFTab4'
call sqlConnect
b = jBuf('select 1 "a" from sysibm.sysDummy1;' ,
, 'drop table gibt.EsNicht;' ,
, 'select 2 "a" from sysibm.sysDummy1;',
, ' select x frm y;',
, 'select 3 "a" from sysibm.sysDummy1;')
call tstout t, 'dy =>' sqlsOut(scanSqlStmtRdr(b, 0))
call tstout t, 'ret =>' sqlsOut(scanSqlStmtRdr(b, 0), 'rb ret')
call tstEnd t
call sqlDisConnect
return
endProcedure tstSqlFTab4
tstSql4Obj: procedure expose m.
/*
$=/tstSql4Obj/
### start tst tstSql4Obj ##########################################
tstR: @tstWriteoV2 isA :tstClass-1 = -11
tstR: .a2i = -11
tstR: .b3b = b3
tstR: .D4 = D4-11+D4++++.
tstR: .fl5 = -111.1
tstR: .ex6 = -.111e-11
insert into cr.insTb -- tstClass-1
. ( , a2i, b3b, D4, fl5, ex6
. ) values .
. ( -11, -11, 'b3', 'D4-11+D4++++', -111.1, -.111e-11
. ) ; .
insert into cr.insTbHex -- tstClass-1
. ( , a2i, b3b, D4, fl5, ex6
. ) values .
. ( -11, -11, 'b3', x'C40760F1F14EC4F44E4E4E4E', -111.1, -.111e-1+
1
. ) ; .
tstR: @tstWriteoV4 isA :tstClass-2
tstR: .c = c83
tstR: .a2i = 83
tstR: .b3b = b3b8
tstR: .D4 = D483+D4++++++++++++++++++++++++++++++++++++++++++++++++
.++++++++++++++++++++++++++++++.
tstR: .fl5 = .183
tstR: .ex6 = .11183e-8
insert into cr.insTb -- tstClass-2
. ( c, a2i, b3b, D4, fl5, ex6
. ) values .
. ( 'c83', 83, 'b3b8'
. , 'D483+D4++++++++++++++++++++++++++++++++++++++++++++++++++++++
'
. || '++++++++++++++++++++++++'
. , .183, .11183e-8
. ) ; .
insert into cr.insTbHex -- tstClass-2
. ( c, a2i, b3b, D4, fl5, ex6
. ) values .
. ( 'c83', 83, 'b3b8'
. , x'C407F8F34EC4F44E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E'
. || '++++++++++++++++++++++++++++++++'
. || x'314E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E'
. , .183, .11183e-8
. ) ; .
$/tstSql4Obj/
*/
call pipeIni
call tst t, 'tstSql4Obj'
call pipe '+N'
call tstDataClassOut '. c3 a2i i b3b c5 D4 c23 fl5 f8n2 ex6 e9n3',
, -11, -11
call tstDataClassOut 'c c3 a2i i b3b c5 D4 c93 fl5 f8n2 ex6 e9n3',
, 83, 83
call pipe 'P|'
do cx=1 while in()
i = m.in
call mAdd t'.'trans, className(objClass(i)) 'tstClass-'cx
call out i
call sql4Obj i, 'cr.insTb'
m.i.d4 = overlay('07'x, m.i.d4, 2)
if length(m.i.d4) >= 62 then
m.i.d4 = overlay('31'x, m.i.d4, 62)
call sql4Obj i, 'cr.insTbHex'
end
call pipe '-'
call tstEnd t
return
endProcedure tstSql4Obj
tstSqlC: procedure expose m.
call sqlIni
/*
$=/tstSqlCRx/
### start tst tstSqlCRx ###########################################
*** err: SQLCODE = -104: ILLEGAL SYMBOL "?". SOME SYMBOLS THAT MIGH+
T
. e 1: BE LEGAL ARE: . <IDENTIFIER> JOIN INNER LEFT RIGHT FU+
LL CROSS ,
. e 2: HAVING GROUP
. e 3: src select * from sysibm?sysDummy1
. e 4: > >>>pos 21 of 30>>>
. e 5: sql = select * from sysibm?sysDummy1
. e 6: stmt = prepare s9 into :M.SQL.9.D from :src
. e 7: with into :M.SQL.9.D = M.SQL.9.D
*** err: SQLCODE = -204: NONONO.SYSDUMMY1 IS AN UNDEFINED NAME
. e 1: sql = select * from nonono.sysDummy1
. e 2: stmt = prepare s9 into :M.SQL.9.D from :src
. e 3: with into :M.SQL.9.D = M.SQL.9.D
sys ==> server CHSKA000DP4G .
fetched a1=abc, i2=12, c3=---
. I1 C2
. 1 eins
2222 zwei
$/tstSqlCRx/
$=/tstSqlCCsm/
### start tst tstSqlCCsm ##########################################
*** err: SQLCODE = -104: ILLEGAL SYMBOL "?". SOME SYMBOLS THAT MIGH+
T
. e 1: BE LEGAL ARE: . <IDENTIFIER> JOIN INNER LEFT RIGHT FU+
LL CROSS ,
. e 2: HAVING GROUP
. e 3: src select * from sysibm?sysDummy1
. e 4: > >>>pos 21 of 30>>>
. e 5: sql = select * from sysibm?sysDummy1
. e 6: subsys = DE0G, host = RZZ
*** err: SQLCODE = -204: NONONO.SYSDUMMY1 IS AN UNDEFINED NAME
. e 1: sql = select * from nonono.sysDummy1
. e 2: subsys = DE0G, host = RZZ
sys RZZ/DE0G ==> server CHROI00ZDE0G .
fetched a1=abc, i2=12, c3=---
. I1 C2
. 1 eins
2222 zwei
$/tstSqlCCsm/ */
sql1 = "select 1 i1, 'eins' c2 from sysibm.sysDummy1" ,
"union all select 2222 i1, 'zwei' c2 from sysibm.sysDummy1"
do tx=1 to 1 + (m.tst_CsmRZ \== '')
if tx = 1 then do
call tst t, "tstSqlCRx"
sys = ''
end
else do
call tst t, "tstSqlCCsm"
sys = m.tst_csmDbSys
end
call sqlConnect sys
cx = 9
call sqlQuery cx, 'select * from sysibm?sysDummy1'
call sqlQuery cx, 'select * from nonono.sysDummy1'
call sqlQuery cx, "select 'abc' a1, 12 i2, current server srv",
", case when 1=0 then 1 else null end c3",
"from sysibm.sysDummy1"
do while sqlFetch(cx, dst)
call out 'sys' sys '==> server' m.dst.srv
call out 'fetched a1='m.dst.a1', i2='m.dst.i2', c3='m.dst.c3
end
call fTabAuto , sqlRdr(sql1)
call sqlDisconnect
call tstEnd t
end
return
endProcedure tstSqlC
tstSqlUpd: procedure expose m.
/*
$=/tstSqlUpd/
### start tst tstSqlUpd ###########################################
insert updC 1
insert select updC 2
dest4.fet: 1 eins 2012-04-01-06.07.08.000000 1 updC 0
dest5.fet: 2 zwei 2012-02-29-15.44.33.220000 --- updC 0
dest6.fet: 11 zehn+eins 2012-04-11-06.07.08.000000 1 updC 0
dest7.fet: 12 zehn+zwei 2012-03-10-15.44.33.220000 --- updC 0
SQLCODE = 000, SUCCESSFUL EXECUTION
warnings 4=W no where
sql = select * from final table (update session.dgtt set c2 = 'u' +
|| c2)
stmt = prepare s9 into :M.SQL.9.D from :src
with into :M.SQL.9.D = M.SQL.9.D
dest9.fet: 1 ueins 2012-04-01-06.07.08.000000 updC 4
dest10.fet: 2 uzwei 2012-02-29-15.44.33.220000 updC 4
dest11.fet: 11 uzehn+eins 2012-04-11-06.07.08.000000 updC 4
dest12.fet: 12 uzehn+zwei 2012-03-10-15.44.33.220000 updC 4
$/tstSqlUpd/ */
call tst t, "tstSqlUpd"
cx = 9
qx = 3
call sqlConnect
call sqlUpdate,"declare global temporary table session.dgtt",
"(i1 int, c2 varchar(20), t3 timestamp)"
call sqlUpdate,"insert into session.dgtt" ,
"values(1, 'eins', '2012-04-01 06.07.08')"
call sqlUpdate,"insert into session.dgtt" ,
"values(2, 'zwei', '2012-02-29 15:44:33.22')"
call out 'insert updC' m.sql..updateCount
call sqlUpdate,"insert into session.dgtt" ,
"select i1+10, 'zehn+'||strip(c2), t3+10 days",
"from session.dgtt"
call out 'insert select updC' m.sql..updateCount
call sqlQuery cx, 'select d.*' ,
', case when mod(i1,2) = 1 then 1 else null end grad' ,
'from session.dgtt d'
do qx=qx+1 while sqlFetch(cx, 'dest'qx'.fet')
dst = 'dest'qx'.fet'
call out dst':' m.dst.i1 m.dst.c2 m.dst.t3 m.dst.grad ,
'updC' m.sql.cx.updateCount
drop m.dst.i1 m.dst.c2 m.dst.t3 m.dst.grad
end
call sqlClose cx
call sqlQuery cx, "select * from final table (update session.dgtt",
" set c2 = 'u' || c2)"
do qx=qx+1 while sqlFetch(cx, 'dest'qx'.fet')
dst = 'dest'qx'.fet'
call out dst':' m.dst.i1 m.dst.c2 m.dst.t3 ,
'updC' m.sql.cx.updateCount
drop m.dst.i1 m.dst.c2 m.dst.t3 m.dst.grad
end
call sqlDisconnect
call tstEnd t
return
endProcedure tstSqlUpd
tstSqlUpdPre: procedure expose m.
/*
$=/tstSqlUpdPre/
### start tst tstSqlUpdPre ########################################
insert updC 1
insert select updC 2
dest4.fet: 1 eins 2012-04-01-06.07.08.000000 1 updC 0
dest5.fet: 2 zwei 2012-02-29-15.44.33.220000 --- updC 0
dest6.fet: 11 zehn+eins 2012-04-11-06.07.08.000000 1 updC 0
dest7.fet: 12 zehn+zwei 2012-03-10-15.44.33.220000 --- updC 0
SQLCODE = 000, SUCCESSFUL EXECUTION
warnings 4=W no where
sql = select * from final table ( update session.dgtt set c2 = ? ||+
. c2)
stmt = prepare s5 into :M.SQL.5.D from :src
with into :M.SQL.5.D = M.SQL.5.D
dest9.fet: 1 ueins 2012-04-01-06.07.08.000000 updC 4
dest10.fet: 2 uzwei 2012-02-29-15.44.33.220000 updC 4
dest11.fet: 11 uzehn+eins 2012-04-11-06.07.08.000000 updC 4
dest12.fet: 12 uzehn+zwei 2012-03-10-15.44.33.220000 updC 4
$/tstSqlUpdPre/ */
call tst t, "tstSqlUpdPre"
cx = 5
qx = 3
call sqlConnect
call sqlUpdate,"declare global temporary table session.dgtt",
"(i1 int, c2 varchar(20), t3 timestamp)"
call sqlUpdatePrepare 5, "insert into session.dgtt" ,
"values (?, ?, ?)"
call sqlUpdateExecute 5, 1, 'eins', '2012-04-01 06.07.08'
call sqlUpdateExecute 5, 2, 'zwei', '2012-02-29 15:44:33.22'
call out 'insert updC' m.sql.5.updateCount
call sqlUpdatePrepare 5,"insert into session.dgtt" ,
"select i1+?, 'zehn+'||strip(c2), t3+? days",
"from session.dgtt"
call sqlUpdateExecute 5, 10, 10
call out 'insert select updC' m.sql.5.updateCount
call sqlQueryPrepare cx, 'select d.*' ,
', case when mod(i1,2) = ? then 0+? else null end grad' ,
'from session.dgtt d'
call sqlQueryExecute cx, 1, 1
do qx=qx+1 while sqlFetch(cx, 'dest'qx'.fet')
dst = 'dest'qx'.fet'
call out dst':' m.dst.i1 m.dst.c2 m.dst.t3 m.dst.grad ,
'updC' m.sql.cx.updateCount
drop m.dst.i1 m.dst.c2 m.dst.t3 m.dst.grad
end
call sqlClose cx
call sqlQueryPrepare cx, "select * from final table (" ,
"update session.dgtt set c2 = ? || c2)"
call sqlQueryExecute cx, "u"
do qx=qx+1 while sqlFetch(cx, 'dest'qx'.fet')
dst = 'dest'qx'.fet'
call out dst':' m.dst.i1 m.dst.c2 m.dst.t3 ,
'updC' m.sql.cx.updateCount
drop m.dst.i1 m.dst.c2 m.dst.t3 m.dst.grad
end
call sqlDisconnect
call tstEnd t
return
endProcedure tstSqlUpdPre
tstsqlRxUpd: procedure expose m.
/*
$=/tstsqlRxUpd/
### start tst tstsqlRxUpd #########################################
insert updC 1
insert select updC 2
dest4.fet: 1 eins 2012-04-01-06.07.08.000000 1 updC 0
dest5.fet: 2 zwei 2012-02-29-15.44.33.220000 --- updC 0
dest6.fet: 11 zehn+eins 2012-04-11-06.07.08.000000 1 updC 0
dest7.fet: 12 zehn+zwei 2012-03-10-15.44.33.220000 --- updC 0
SQLCODE = 000, SUCCESSFUL EXECUTION
warnings 4=W no where
sql = select * from final table (update session.dgtt set c2 = 'u' +
|| c2)
stmt = prepare s9 into :M.SQL.9.D from :src
with into :M.SQL.9.D = M.SQL.9.D
dest9.fet: 1 ueins 2012-04-01-06.07.08.000000 updC 4
dest10.fet: 2 uzwei 2012-02-29-15.44.33.220000 updC 4
dest11.fet: 11 uzehn+eins 2012-04-11-06.07.08.000000 updC 4
dest12.fet: 12 uzehn+zwei 2012-03-10-15.44.33.220000 updC 4
$/tstsqlRxUpd/ */
call pipeIni
call tst t, "tstsqlRxUpd"
cx = 9
qx = 3
call sqlRxConnect
call sqlRxUpdate,"declare global temporary table session.dgtt",
"(i1 int, c2 varchar(20), t3 timestamp)"
call sqlRxUpdate,"insert into session.dgtt" ,
"values(1, 'eins', '2012-04-01 06.07.08')"
call sqlRxUpdate,"insert into session.dgtt" ,
"values(2, 'zwei', '2012-02-29 15:44:33.22')"
call out 'insert updC' m.sql..updateCount
call sqlRxUpdate,"insert into session.dgtt" ,
"select i1+10, 'zehn+'||strip(c2), t3+10 days",
"from session.dgtt"
call out 'insert select updC' m.sql..updateCount
call sqlRxQuery cx, 'select d.*' ,
', case when mod(i1,2) = 1 then 1 else null end grad' ,
'from session.dgtt d'
do qx=qx+1 while sqlRxFetch(cx, 'dest'qx'.fet')
dst = 'dest'qx'.fet'
call out dst':' m.dst.i1 m.dst.c2 m.dst.t3 m.dst.grad ,
'updC' m.sql.cx.updateCount
drop m.dst.i1 m.dst.c2 m.dst.t3 m.dst.grad
end
call sqlRxClose cx
call sqlRxQuery cx, "select * from final table",
"(update session.dgtt set c2 = 'u' || c2)"
do qx=qx+1 while sqlRxFetch(cx, 'dest'qx'.fet')
dst = 'dest'qx'.fet'
call out dst':' m.dst.i1 m.dst.c2 m.dst.t3 ,
'updC' m.sql.cx.updateCount
drop m.dst.i1 m.dst.c2 m.dst.t3 m.dst.grad
end
call sqlRxClose cx
call sqlRxDisconnect
call tstEnd t
return
endProcedure tstsqlRxUpd
tstSqlE: procedure expose m.
/*
$=/tstSqlE/
### start tst tstSqlE #############################################
*** err: SQLCODE = -713: THE REPLACEMENT VALUE FOR CURRENT SCHEMA I+
S
. e 1: INVALID
. e 2: sql = set current schema = 'sysibm'
. e 3: stmt = execute immediate :src
-713 set schema ''
0 set schema
0 select
fetch=1 SYSIBM
$/tstSqlE/
*/
call sqlConnect
call tst t, "tstSqlE"
call tstOut t, sqlExecute(3, "set current schema = 'sysibm'") ,
"set schema ''"
call tstOut t, sqlExecute(3, " set current schema = sysibm ") ,
"set schema"
call tstOut t, sqlExecute(3, " select current schema c" ,
"from sysibm.sysDummy1") 'select'
call tstOut t, 'fetch='sqlFetch(3, aa) m.aa.c
call sqlClose 3
call sqlDisConnect
call tstEnd t
return
endProcedure tstSqlE
tstSqlO: procedure expose m.
/*
$=/tstSqlO/
### start tst tstSqlO #############################################
sqlCode 0: set current schema = A540769
*** err: SQLCODE = -204: A540769.SYSDUMMY IS AN UNDEFINED NAME
. e 1: sql = select * from sysdummy
. e 2: stmt = prepare s10 into :M.SQL.10.D from :src
. e 3: with into :M.SQL.10.D = M.SQL.10.D
sqlCode -204: select * from sysdummy
REQD=Y col=123 case=--- .sqlInd:-1 col5=anonym geburri=1956-04-01+
-06.00.00.000000
$/tstSqlO/
*/
call sqlConnect
call scanWinIni
call tst t, "tstSqlO"
call sqlStmts 'set current schema = A540769';
call sqlStmts 'select * from sysdummy';
r = sqlRdr( ,
"select d.*, 123, timestamp('01.04.1956','06:00:00')" ,
'"geburri walter",',
'case when 1=0 then 1 else null end caseNull,',
"'anonym'" ,
'from sysibm.sysdummy1 d')
call jOpen r, '<'
do while jRead(r)
o = m.r
call out 'REQD='m.o.IBMREQD 'col='m.o.col2,
'case='m.o.CASENULL '.sqlInd:'m.o.caseNull.sqlInd,
'col5='m.o.col5,
'geburri='m.o.GEBURRI
end
call jClose r
call sqlDisConnect
call tstEnd t
return
endProcedure tstSqlO
tstSqlUpdComLoop: procedure expose m.
/*
$=/tstSqlUpdComLoop/
### start tst tstSqlUpdComLoop ####################################
sqlCode 0: declare global temporary table session.dgtt (i1 int) on +
commit ....
sqlCode 0, 123 rows inserted: insert into session.dgtt select row_n+
umber()....
CNT
123
1 rows fetched: select count(*) cnt from session.dgtt
123 rows deleted, 10 commits: delete from session.dgtt d where i1 i+
n (sele....
C
0
1 rows fetched: select count(*) cnt from session.dgtt
$/tstSqlUpdComLoop/ */
call pipeIni
call tst t, "tstSqlUpdComLoop"
call sqlConnect
call sqlsOut "declare global temporary table session.dgtt",
"(i1 int) on commit preserve rows"
call sqlsOut "insert into session.dgtt",
"select row_number() over() from sysibm.sysTables",
"fetch first 123 rows only"
call sqlsOut "select count(*) cnt from session.dgtt"
call out sqlUpdComLoop("delete from session.dgtt d where i1 in",
"(select i1 from session.dgtt fetch first 13 rows only)")
call sqlsOut "select count(*) cnt from session.dgtt"
call sqlDisConnect
call tstEnd t
return
endProcedure tstSqlUpdComLoop
tstSqlO1: procedure expose m.
/*
$=/tstSqlO1/
### start tst tstSqlO1 ############################################
tstR: @tstWriteoV2 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLEPART
tstR: @tstWriteoV3 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLEPART_HIST
tstR: @tstWriteoV4 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLES
tstR: @tstWriteoV5 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLESPACE
--- writeAll
tstR: @tstWriteoV6 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLEPART
tstR: @tstWriteoV7 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLEPART_HIST
tstR: @tstWriteoV8 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLES
tstR: @tstWriteoV9 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLESPACE
$/tstSqlO1/
*/
call tst t, "tstSqlO1"
call sqlConnect
qr = sqlRdr("select strip(creator) cr, strip(name) tb",
"from sysibm.sysTables",
"where creator='SYSIBM' and name like 'SYSTABL%'",
"order by 2 fetch first 4 rows only")
call jOpen qr, m.j.cRead
call mAdd t.trans, className(m.qr.type) '<tstSqlO1Type>'
do while jRead(qr)
abc = m.qr
if m.qr.rowCount = 1 then do
cx = m.qr.cursor
end
call out abc
end
call jClose qr
call out '--- writeAll'
call pipeWriteAll qr
call sqlDisConnect
call tstEnd t
return 0
endProcedure tstSqlO1
tstSqlO2: procedure expose m.
/*
$=/tstSqlO2/
### start tst tstSqlO2 ############################################
CR TB RR
SYSIBM SYSTABLEPART 1
SYSIBM SYSTABLEPART_HIST 4
SYSIBM SYSTABLES 9
SYSIBM SYSTABLESPACE 16
$/tstSqlO2/
*/
call pipeIni
call tst t, "tstSqlO2"
call sqlConnect
call pipe '+N'
call out "select strip(creator) cr, strip(name) tb,"
call out "(row_number()over())*(row_number()over()) rr"
call out "from sysibm.sysTables"
call out "where creator='SYSIBM' and name like 'SYSTABL%'"
call out "order by 2 fetch first 4 rows only"
call pipe 'N|'
call sqlSel
call pipe 'P|'
call fTabAuto fTabReset(abc, 1)
call pipe '-'
call sqlDisConnect
call tstEnd t
return 0
endProcedure tstSqlO2
tstSqlS1: procedure expose m.
/*
$=/tstSqlS1/
### start tst tstSqlS1 ############################################
select c, a from sysibm.sysDummy1
tstR: @tstWriteoV2 isA :<cla sql c a>
tstR: .C = 1
tstR: .A = a
select ... where 1=0
tstR: @ obj null
$/tstSqlS1/
*/
call sqlIni
call tst t, "tstSqlS1"
call sqlConnect
s1 = jSingle( ,
sqlRdr("select count(*) c, 'a' a from sysibm.sysdummy1"))
call mAdd t.trans, className(objClass(s1)) '<cla sql c a>'
call out 'select c, a from sysibm.sysDummy1'
call tstWrite t, s1
call out 'select ... where 1=0'
call tstWrite t, jSingle( ,
sqlRdr("select*from sysibm.sysdummy1 where 1=0"), '')
call sqlDisConnect
call tstEnd t
return
endProcedure tstSqlS1
tstSqlStmt: procedure expose m.
/*
$=/tstSqlStmt/
### start tst tstSqlStmt ##########################################
*** err: SQLCODE = -713: THE REPLACEMENT VALUE FOR CURRENT SCHEMA I+
S
. e 1: INVALID
. e 2: sql = set current schema = 'sysibm'
. e 3: stmt = execute immediate :src
sqlCode -713: set current schema = 'sysibm'
sqlCode 0: set current schema = sysibm
tstR: @tstWriteoV2 isA :<sql?sc>
tstR: .C = SYSIBM
tstR: @tstWriteoV3 isA :<sql?sc>
tstR: .C = SYSIBM
$/tstSqlStmt/
*/
call sqlConnect
call scanReadIni
call tst t, "tstSqlStmt"
cn = className(classNew('n* Sql u f%v C'))
call mAdd t.trans, cn '<sql?sc>'
call sqlStmts "set current schema = 'sysibm'"
call sqlsOut " set current schema = sysibm "
call sqlsOut " select current schema c from sysDummy1", , 'o'
call sqlsOut " (select current schema c from sysDummy1)", , 'o'
call sqlDisConnect
call tstEnd t
return
endProcedure tstSqlStmt
tstSqlStmts: procedure expose m.
/*
$=/tstSqlStmts/
### start tst tstSqlStmts #########################################
*** err: SQLCODE = -104: ILLEGAL SYMBOL "BLABLA". SOME SYMBOLS THAT
. e 1: MIGHT BE LEGAL ARE: <ERR_STMT> <WNG_STMT> GET SQL SAV+
EPOINT HOLD
. e 2: FREE ASSOCIATE
. e 3: src blabla
. e 4: > <<<pos 1 of 6<<<
. e 5: sql = blabla
sqlCode -104: blabla
sqlCode 0: set current schema= sysIbm
c
1
1 rows fetched: select count(*) "c" from sysDummy1 with ur
c
1
1 rows fetched: select count(*) "c" from sysDummy1 with ur
#jIn 1# set current -- sdf
#jIn 2# schema = s100447;
#jIn eof 3#
sqlCode 0: set current schema = s100447
$/tstSqlStmts/ */
call jIni
call sqlConnect
call scanReadIni
call scanWinIni
call tst t, "tstSqlStmts"
call sqlStmts "blabla ;;set current schema= sysIbm "
b = jBuf('select count(*) "c" from sysDummy1 --com' ,
,'with /* comm */ ur;')
call sqlStmts b
call sqlStmts b
call mAdd mCut(t'.IN', 0), 'set current -- sdf', 'schema = s100447;'
call sqlStmts
call sqlDisConnect
call tstEnd t
return
endProcedure tstSqlStmts
tstCatTb: /* ???????????????????? tkr kopieren und testen */
/*
$=/tstCatTb/
### start tst tstCatTb ############################################
..
select * from sysibm.SYSDUMMY1 .
IBMREQD
I .
Y .
I .
IBMREQD
$/tstCatTb/
*/
call sqlConnect
call tst t, 'tstCatTb'
call sqlCatTb 'sysDummy1'
call sqlCatTb 'SYSTableSpaceStats',
, "name = 'A403A1' and dbName = 'DA540769'"
call sqlDisConnect
call tstEnd t
return
endProcedure tstCatTb
tstSqlDisDb: procedure expose m.
call sqlDsn di, 'DP4G', '-dis db(*) sp(*)' ,
'restrict advisory limit(*)', 12
m.oo.0 = 0
call sqlDisDb oo, di
say 'di.0' m.di.0 '==> oo.0' m.oo.0
trace ?r
ix = sqlDisDbIndex(oo, DB2PDB6,RR2HHAGE)
say 'DB2PDB6.RR2HHAGE ==>' ix m.oo.ix.sta
ix = sqlDisDbIndex(oo, DB2PDB6,RR2HHAGE, 3)
say 'DB2PDB6.RR2HHAGE.3 ==>' ix m.oo.ix.sta
ix = sqlDisDbIndex(oo, DB2PDB6,RR2HHAGE,22)
say 'DB2PDB6.RR2HHAGE.22 ==>' ix m.oo.ix.sta
return
endProcedure tstSqlDisDb
/****** tstComp ********************************************************
test the wsh compiler
***********************************************************************/
tstComp: procedure expose m.
call compIni
call tstCompDataConst
call tstCompDataVars
call tstCompShell
call tstCompPrimary
call tstCompExpr
call tstCompFile
call tstCompStmt
call tstCompDir
call tstCompObj
call tstCompORun
call tstCompORu2
call tstCompORuRe
call tstCompDataIO
call tstCompPipe
call tstCompPip2
call tstCompRedir
call tstCompComp
call tstCompColon
call tstCompTable
call tstCompSyntax
if m.err.os == 'TSO' then
call tstCompSql
call tstTotal
return
endProcedure tstComp
tstComp1: procedure expose m.
parse arg ty nm cnt
c1 = 0
if cnt = 0 | cnt = '+' then do
c1 = cnt
cnt = ''
end
call jIni
src = jBuf()
call jOpen src, m.j.cWri
do sx=2 to arg()
call jWrite src, arg(sx)
end
call tstComp2 nm, ty, jClose(src), , c1, cnt
return
endProcedure tstComp1
tstComp2: procedure expose m.
parse arg nm, spec, src, compSt
call compIni
call tst t, nm, compSt
if src == '' then do
src = jBuf()
call tst4dp src'.BUF', mapInline(nm'Src')
end
m.t.moreOutOk = abbrev(strip(arg(5)), '+')
oldErr = m.err.count
cmp = comp(src)
call out 'compile' spec',' (m.src.buf.0) 'lines:' m.src.buf.1
r = compile(cmp, spec)
noSyn = m.err.count = oldErr
coErr = m.t.err
say if( noSyn, "compiled", "*** syntaxed") r ":" objMet(r, 'oRun')
cnt = 0
do ax = 5 to max(arg(), 5) while m.t.err = coErr & noSyn
a1 = strip(arg(ax))
if a1 == '' & arg() >= 5 then
iterate
if abbrev(a1, '+') then do
m.t.moreOutOk = 1
a1 = strip(substr(a1, 2))
end
if datatype(a1, 'n') then
cnt = a1
else if a1 \== '' then
call err 'tstComp2 bad arg('ax')' arg(ax)
if cnt = 0 then do
call mCut 'T.IN', 0
call out "run without input"
end
else do
call mAdd mCut('T.IN', 0),
,"eins zwei drei", "zehn elf zwoelf?",
, "zwanzig 21 22 23 24 ... 29|"
do lx=4 to cnt
call mAdd 'T.IN', left(lx "line" lx, lx+9, '-')';'
end
call out "run with" cnt "inputs"
end
m.t.inIx = 0
call oRun r
end
call tstEnd t
return
endProcedure tstComp2
tstCompDataConst: procedure expose m.
/*
$=/tstCompDataConst/
### start tst tstCompDataConst ####################################
compile =, 8 lines: Lline one, $** asdf
run without input
. Lline one, .
line two..
line threecontinued on 4
line five fortsetzung
line six fortsetzung
$/tstCompDataConst/ */
call tstComp1 '= tstCompDataConst',
, ' Lline one, $** asdf',
, 'line two.',
, 'line three$*+ bla bla' ,
, 'continued on 4',
, 'line five $*( und so',
, 'weiter $abc $? $''$*)'' $"$*)" und weiter $*) fortsetzung',
, 'line six $*( und $*( $** $*( so',
, 'weiter $abc $? $*)'' $"$*)" und weiter $*) fortsetzung'
/*
$=/tstCompDataConstBefAftComm1/
### start tst tstCompDataConstBefAftComm1 #########################
compile =, 3 lines: $*(anfangs com.$*) $*(plus$*) $** x
run without input
the only line;
$/tstCompDataConstBefAftComm1/ */
call tstComp1 '= tstCompDataConstBefAftComm1',
, ' $*(anfangs com.$*) $*(plus$*) $** x',
, 'the only line;',
, ' $*(end kommentar$*) '
/*
$=/tstCompDataConstBefAftComm2/
### start tst tstCompDataConstBefAftComm2 #########################
compile =, 11 lines: $*(anfangs com.$*) $*(plus$*) $*+ x
run without input
the first non empty line;
. .
befor an empty line with comments;
$/tstCompDataConstBefAftComm2/ */
call tstComp1 '= tstCompDataConstBefAftComm2',
, ' $*(anfangs com.$*) $*(plus$*) $*+ x',
, ' $*(forts Zeile com.$*) $*(plus$*) $** x',
, ' $*(comment 2. Zeile$*) $*(plus$*) $*+ x',
, ' $*(forts Zeile com.$*) $*(plus$*) $** x',
, 'the first non empty line;',
, ' ',
, 'befor an empty line with comments;',
, ' $*(comment 4. Zeile$*) $*(plus$*) $*+ x',
, ' $*(forts 4.Zeile com.$*) $*(plus$*) $** x',
, ' $*(end kommentar$*) $*+',
, ' $*(forts end com.$*) $*(plus$*) $** x'
return
endProcedure tstCompDataComm
tstCompDataVars: procedure expose m.
/*
$=/tstCompDataVars/
### start tst tstCompDataVars #####################################
compile =, 5 lines: Lline one, $** asdf
run without input
. Lline one, .
lline zwei output
lline 3 .
variable v1 = valueV1 ${v1}= valueV1; .
. $-{""$v1} = valueV1; .
$/tstCompDataVars/ */
call tstComp1 '= tstCompDataVars',
, ' Lline one, $** asdf',
, ' $$ lline zwei output',
, 'lline 3 $=v1= valueV1 ' ,
, 'variable v1 = $v1 $"${v1}=" ${ v1 }; ',
, ' $"$-{""""$v1} =" $-{$""$"v1"}; '
return
endProcedure tstCompDataVars
tstCompShell: procedure expose m.
/*
$=/tstCompShell3/
### start tst tstCompShell3 #######################################
compile @, 8 lines: call tstOut "T", "abc" $-¢2*3$! "efg"$-¢2*3$!"+
hij"
run without input
abc 6 efg6hij
insert into A540769x.tqt002 with n(n) as ( select 4 from sysibm.s
insert into A540769x.tqt002 with n(n) as ( select 4 from sysibm.s +
. union all .
abc 6 efg6hij
$/tstCompShell3/ */
call tstComp1 '@ tstCompShell3',
, 'call tstOut "T", "abc" $-¢2*3$! "efg"$-¢2*3$!"hij"',
, 'ix=3' ,
, 'call tstOut "T","insert into A540769x.tqt002" ,',
, '"with n(n) as ( select" $-¢ix+1$! "from sysibm.s"',
, 'call tstOut "T","insert into A540769x.tqt002" , ',
, '"with n(n) as ( select" $-¢ix+1$! "from sysibm.s" , ' ,
, '" union all "' ,
, '$$ abc $-¢2*3$! efg$-¢2*3$!hij',
/*
$=/tstCompShell/
### start tst tstCompShell ########################################
compile @, 12 lines: $$ Lline one, $** asdf
run without input
Lline one,
lline zwei output
v1 = valueV1 ${v1}= valueV1|
REXX OUT L5 CONTINUED L6 CONTINUED L7
L8 ONE
L9 TWO
valueV1
valueV1 valueV2
out valueV1 valueV2
SCHLUSS
$/tstCompShell/ */
call tstComp1 '@ tstCompShell',
, ' $$ Lline one, $** asdf',
, ' $$ lline zwei output',
, ' $=v1= valueV1 ' ,
, '$$ v1 = $v1 $"${v1}=" ${ v1 }| ' ,
, 'call out rexx out l5, ' ,
, ' continued l6 , ' ,
, ' continued l7 ' ,
, 'call out l8 one ' ,
, 'call out l9 two$=v2=valueV2 ',
, '$$- $v1 $$- $v1 $v2 ',
, 'call out "out " $v1 $v2 ',
, '$$- schluss '
/*
$=/tstCompShell2/
### start tst tstCompShell2 #######################################
compile @, 13 lines: $@do j=0 to 1 $@¢ $$ do j=$j
run without input
do j=0
after if 0 $@¢ $!
after if 0 $=@¢ $!
do j=1
if 1 then $@¢ a
a2
if 1 then $@=¢ b
b2
after if 1 $@¢ $!
after if 1 $=@¢ $!
end
$/tstCompShell2/ */
call tstComp1 '@ tstCompShell2',
, '$@do j=0 to 1 $@¢ $$ do j=$j' ,
, 'if $j then $@¢ ',
, '$$ if $j then $"$@¢" a $$a2' ,
, '$!',
, 'if $j then $@=¢ ',
, '$$ if $j then $"$@=¢" b $$b2' ,
, '$!',
, 'if $j then $@¢ $!' ,
, '$$ after if $j $"$@¢ $!"' ,
, 'if $j then $@=¢ $!' ,
, '$$ after if $j $"$=@¢ $!"' ,
, '$!',
, '$$ end'
return
endProcedure tstCompShell
tstCompPrimary: procedure expose m.
call compIni
/*
$=/tstCompPrimary/
### start tst tstCompPrimary ######################################
compile =, 16 lines: Strings $"$""$""""$""" $'$''$''''$'''
run without input
Strings $"$""$" $'$''$'
rexx $-¢ 3 * 5 $! = 15
rexx $-¢ 5 * 7 $! = 35
rexx $-// 7 * 11 $// = 77
rexx $-/abcEf/ 11 * 13 $/abcEf/ = 143
data line three line four bis hier
shell line five line six bis hier
var get v1 value Eins, v1 value Eins .
var isDef v1 1, v2 0 .
#jIn eof 1#
var read >1 0 rr undefined
#jIn eof 2#
var read >2 0 rr undefined
no call abc$-¢4*5$! $-¢efg$-¢6*7$! abc20 EFG42
brackets $-¢$-¢1+9$!*$-¢7+3$!*$-/b/5+5$/b/$! 1000
run with 3 inputs
Strings $"$""$" $'$''$'
rexx $-¢ 3 * 5 $! = 15
rexx $-¢ 5 * 7 $! = 35
rexx $-// 7 * 11 $// = 77
rexx $-/abcEf/ 11 * 13 $/abcEf/ = 143
data line three line four bis hier
shell line five line six bis hier
var get v1 value Eins, v1 value Eins .
var isDef v1 1, v2 0 .
#jIn 1# eins zwei drei
var read >1 1 rr eins zwei drei
#jIn 2# zehn elf zwoelf?
var read >2 1 rr zehn elf zwoelf?
no call abc$-¢4*5$! $-¢efg$-¢6*7$! abc20 EFG42
brackets $-¢$-¢1+9$!*$-¢7+3$!*$-/b/5+5$/b/$! 1000
$/tstCompPrimary/ */
call vRemove 'v2'
call tstComp1 '= tstCompPrimary 3',
, 'Strings $"$""$""""$"""' "$'$''$''''$'''",
, 'rexx $"$-¢ 3 * 5 $! =" $-¢ 3 * 5 $!' ,
, 'rexx $"$-¢ 5 * 7 $! =" $-¢ 5 * 7 $!' ,
, 'rexx $"$-// 7 * 11 $// =" $-// 7 * 11 $//' ,
, 'rexx $"$-/abcEf/ 11 * 13 $/abcEf/ ="',
'$-/abcEf/ 11 * 13 $/abcEf/' ,
, 'data $-=¢ line three',
, 'line four $! bis hier' ,
, 'shell $-@¢ $$ line five',
, '$$ line six $! bis hier' ,
, '$= v1 = value Eins $=rr=undefined $= eins = 1 ',
, 'var get v1 $v1, v1 ${ v1 } ',
, 'var isDef v1 ${? v${ eins } }, v2 ${?v2 } ',
, 'var read >1 ${> rr} rr $rr' ,
, 'var read >2 ${> rr} rr $rr',
, 'no call $"abc$-¢4*5$! $-¢efg$-¢6*7$!"',
'abc$-¢4*5$! $-¢efg$-¢6*7$!$!',
, 'brackets $"$-¢$-¢1+9$!*$-¢7+3$!*$-/b/5+5$/b/$!"',
'$-¢$-¢1+9$!*$-¢7+3$!*$-/b/5+5$/b/$!'
return
endProcedure tstCompPrimary
tstCompExpr: procedure expose m.
call compIni
/*
$=/tstCompExprStr/
### start tst tstCompExprStr ######################################
compile -, 3 lines: $=vv=vvStr
run without input
vv=vvStr
o2String($.-vv)=vvStr
$/tstCompExprStr/ */
call tstComp1 '- tstCompExprStr',
, '$=vv=vvStr' ,
, '"vv="$vv' ,
, '$"o2String($.-vv)="o2String($.-vv)'
/*
$=/tstCompExprObj/
### start tst tstCompExprObj ######################################
compile ., 5 lines: $=vv=vvStr
run without input
vv=
vvStr
s2o($.vv)=
vvStr
$/tstCompExprObj/ */
call tstComp1 '. tstCompExprObj',
, '$=vv=vvStr' ,
, '"!vv="', '$.-vv',
, '$."s2o($.vv)="', 's2o($-vv)'
/*
$=/tstCompExprDat/
### start tst tstCompExprDat ######################################
compile =, 4 lines: $=vv=vvDat
run without input
vv=vvDat
$.-vv= !vvDat
$.-¢"abc"$!=!abc
$/tstCompExprDat/ */
call tstComp1 '= tstCompExprDat',
, '$=vv=vvDat' ,
, 'vv=$vv',
, '$"$.-vv=" $.-vv',
, '$"$.-¢""abc""$!="$.-¢"abc"$!'
/*
$=/tstCompExprRun/
### start tst tstCompExprRun ######################################
compile @, 3 lines: $=vv=vvRun
run without input
vv=vvRun
o2string($.-vv)=vvRun
$/tstCompExprRun/ */
call tstComp1 '@ tstCompExprRun',
, '$=vv=vvRun' ,
, 'call out "vv="$vv',
, 'call out $"o2string($.-vv)="o2string($.-vv)'
/*
$=/tstCompExprCon/
### start tst tstCompExprCon ######################################
compile #, 2 lines: $$ in # drinnen
run without input
$$ in # drinnen
call out "vv="$vv
$/tstCompExprCon/
$=/tstCompExprCo2/
### start tst tstCompExprCo2 ######################################
compile #, 3 lines: $$ in # drinnen
run without input
$$ in # drinnen
call out "vv="$vv
nacgh $#@
$/tstCompExprCo2/
*/
call tstComp1 '# tstCompExprCon',
, '$$ in # drinnen' ,
, 'call out "vv="$vv'
call tstComp1 '# tstCompExprCo2',
, '$$ in # drinnen' ,
, 'call out "vv="$vv',
, '$#@ $$ nacgh $"$#@"'
return
endProcedure tstCompExpr
tstCompStmt: procedure expose m.
/*
$=/tstCompStmt1/
### start tst tstCompStmt1 ########################################
compile @, 8 lines: $= v1 = value eins $= v2 =- 3*5*7 .
run without input
data v1 value eins v2 105
eins
zwei
drei
vier
fuenf
elf
. zwoelf dreiZ .
. vierZ .
fuenfZ
lang v1 value eins v2 945
oRun ouput 1
$/tstCompStmt1/ */
call pipeIni
call compIni
call vPut 'oRun', oRunner('call out "oRun ouput" (1*1)')
call vRemove 'v2'
call tstComp1 '@ tstCompStmt1',
, '$= v1 = value eins $= v2 =- 3*5*7 ',
, '$$ data v1 $v1 v2 ${ v2 }',
, '$$eins $@¢$$ zwei $$ drei ',
, ' $@¢ $! $@// $// $@/q r s / $/q r s /',
' $@/eins/ $@¢ $$vier $! $/eins/ $! $$fuenf',
, '$$elf $@=¢$@=¢ zwoelf dreiZ $! ',
, ' $@=¢ $! $@=¢ $@=¢ vierZ $! $! $! $$fuenfZ',
, '$$- "lang v1" $v1 "v2" ${v2}*9',
, '$@oRun'
/*
$=/tstCompStmt2/
### start tst tstCompStmt2 ########################################
compile @, 1 lines: $@for qq $$ loop qq $qq
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
loop qq eins zwei drei
#jIn 2# zehn elf zwoelf?
loop qq zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
loop qq zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
$/tstCompStmt2/ */
call tstComp1 '@ tstCompStmt2 3',
, '$@for qq $$ loop qq $qq'
/*
$=/tstCompStmt3/
### start tst tstCompStmt3 ########################################
compile @, 9 lines: $$ 1 begin run 1
2 ct zwei
ct 4 mit assign .
run without input
1 begin run 1
3 run 3 ctV = ct 4 assign ctV|
run 5 procCall $@prCa
out in proc at 8
run 6 vor call $@prCa
out in proc at 8
9 run end
run with 3 inputs
1 begin run 1
3 run 3 ctV = ct 4 assign ctV|
run 5 procCall $@prCa
out in proc at 8
run 6 vor call $@prCa
out in proc at 8
9 run end
$/tstCompStmt3/ */
call tstComp1 '@ tstCompStmt3 3',
, '$$ 1 begin run 1',
, '$@ct $$ 2 ct zwei',
, '$$ 3 run 3 ctV = $ctV|',
, '$@ct $@=¢ct 4 mit assign $=ctV = ct 4 assign ctV $!',
, '$$ run 5 procCall $"$@prCa" $@prCa',
, '$$ run 6 vor call $"$@prCa"',
, '$@prCa',
, '$@proc prCa $$out in proc at 8',
, '$$ 9 run end'
/*
$=/tstCompStmt4/
### start tst tstCompStmt4 ########################################
compile @, 4 lines: $=eins=vorher
run without input
eins vorher
eins aus named block eins .
$/tstCompStmt4/ */
call tstComp1 '@ tstCompStmt4 0',
, '$=eins=vorher' ,
, '$$ eins $eins' ,
, '$=/eins/aus named block eins $/eins/' ,
, '$$ eins $eins'
/*
$=/tstCompStmtDo/
### start tst tstCompStmtDo #######################################
compile @, 2 lines: ti=0$@do y=3 to 4 $@do 2 $@¢
run without input
y=3 ti1 z=7
y=3 ti1 z=8
y=3 ti2 z=7
y=3 ti2 z=8
y=4 ti3 z=7
y=4 ti3 z=8
y=4 ti4 z=7
y=4 ti4 z=8
$/tstCompStmtDo/ */
call tstComp1 '@ tstCompStmtDo', 'ti=0$@do y=3 to 4 $@do 2 $@¢',
, 'ti = ti + 1',
'$@do $*(sdf$*) z $*(sdf$*) =7 to 8 $$ y=$y ti$-¢ti$! z=$z $!'
/*
$=/tstCompStmtDo2/
### start tst tstCompStmtDo2 ######################################
compile @, 7 lines: $$ $-=/sqlSel/
run without input
select 1 abc select 2 abc after table .
$/tstCompStmtDo2/ */
call tstComp1 '@ tstCompStmtDo2',
, '$$ $-=/sqlSel/',
, '$=ty = abc ',
, '$@do tx=1 to 2 $@=/table/',
, 'select $tx $ty',
, '$/table/',
, '$=ty = abc',
, 'after table',
'$/sqlSel/'
/*
$=/tstCompStmtWith/
### start tst tstCompStmtWith #####################################
compile @, 3 lines: $@with $.vA $$ fEins=$FEINS fZwei=$FZWEI va&fEi+
ns=${vA&FEINS}
run without input
fEins=1Eins fZwei=1Zwei va&fEins=1Eins
fEins=1Eins fZwei=1Zwei va&fEins=1Eins
fEins=2Eins fZwei=2Zwei va&fEins=1Eins
fEins=1Eins fZwei=1Zwei va&fEins=1Eins
$/tstCompStmtWith/
*/
cl = classNew('n? tstStmtWith u f FEINS v, f FZWEI v')
v1 = onew(cl)
m.v1.feins = '1Eins'
m.v1.fzwei = '1Zwei'
v2 = oNew(cl)
m.v2.feins ='2Eins'
m.v2.fzwei ='2Zwei'
call vPut 'vA', v1
call vPut 'vB', v2
stmt = '$$ fEins=$FEINS fZwei=$FZWEI va&fEins=${vA&FEINS}'
call tstComp1 '@ tstCompStmtWith',
, '$@with $.vA' stmt ,
, '$@with $vA $@¢' stmt ,
, '$@with $vB ' stmt stmt '$!'
/*
$=/tstCompStmtArg/
### start tst tstCompStmtArg ######################################
compile :, 11 lines: v2 = var2
run without input
a1=eins a2=zwei, a3=elf b1= b2=
after op= v2=var2 var2=zwei,
a1=EINS a2=ZWEI a3= b1=ELF b2=
after op=- v2=var2 var2=ZWEI
a1=EINS a2=ZWEI a3= b1=ELF b2=
after op=. v2=var2 var2=ZWEI
$/tstCompStmtArg/
*/
call tstComp1 ': tstCompStmtArg',
, 'v2 = var2',
, '@% outArg eins zwei, elf',
, '$$ after op= v2=$v2 var2=$var2',
, '@% outArg - eins zwei, elf',
, '$$ after op=- v2=$v2 var2=$var2',
, '@% outArg . eins zwei, elf',
, '$$ after op=. v2=$v2 var2=$var2',
, 'proc $@:/outArg/' ,
, 'arg a1 {$v2} a3, b1 b2',
, '$$ a1=$a1 a2=${$v2} a3=$a3 b1=$b1 b2=$b2' ,
, '$/outArg/'
cl = classNew('n? tstStmtWith u f FEINS v, f FZWEI v')
return
endProcedure tstCompStmt
tstCompSyntax: procedure expose m.
call tstCompSynPrimary
call tstCompSynAss
call tstCompSynRun
return
endProcedure tstCompSyntax
tstCompSynPrimary: procedure expose m.
/*
$=/tstCompSynPri1/
### start tst tstCompSynPri1 ######################################
compile @, 1 lines: a $ =
*** err: scanErr wsh kindExe'@' expected: compile stopped before en+
d of input
. e 1: last token scanPosition $ =
. e 2: pos 3 in line 1: a $ =
*** err: no method oRun in class String
$/tstCompSynPri1/ */
call tstComp1 '@ tstCompSynPri1 +', 'a $ ='
/*
$=/tstCompSynPri2/
### start tst tstCompSynPri2 ######################################
compile @, 1 lines: a $. {
*** err: scanErr primary block or expression expected expected
. e 1: last token scanPosition . {
. e 2: pos 4 in line 1: a $. {
*** err: scanErr primary block or expression expected expected
. e 1: last token scanPosition . {
. e 2: pos 4 in line 1: a $. {
*** err: scanErr wsh kindExe'@' expected: compile stopped before en+
d of input
. e 1: last token scanPosition $. {
. e 2: pos 3 in line 1: a $. {
*** err: no method oRun in class String
$/tstCompSynPri2/ */
call tstComp1 '@ tstCompSynPri2 +', 'a $. {'
/*
$=/tstCompSynPri3/
### start tst tstCompSynPri3 ######################################
compile @, 1 lines: b $- ¢ .
*** err: scanErr primary block or expression expected expected
. e 1: last token scanPosition - ¢
. e 2: pos 4 in line 1: b $- ¢
*** err: scanErr primary block or expression expected expected
. e 1: last token scanPosition - ¢
. e 2: pos 4 in line 1: b $- ¢
*** err: scanErr wsh kindExe'@' expected: compile stopped before en+
d of input
. e 1: last token scanPosition $- ¢
. e 2: pos 3 in line 1: b $- ¢
*** err: no method oRun in class String
$/tstCompSynPri3/ */
call tstComp1 '@ tstCompSynPri3 +', 'b $- ¢ '
/*
$=/tstCompSynPri4/
### start tst tstCompSynPri4 ######################################
compile @, 1 lines: a ${ $*( sdf$*) } =
*** err: scanErr var name expected
. e 1: last token scanPosition } =
. e 2: pos 17 in line 1: a ${ $*( sdf$*) } =
$/tstCompSynPri4/ */
call tstComp1 '@ tstCompSynPri4 +', 'a ${ $*( sdf$*) } ='
/*
$=/tstCompSynFile/
### start tst tstCompSynFile ######################################
compile @, 1 lines: $@.<$*( co1 $*) $$abc
*** err: scanErr primary, block or expression expected
. e 1: last token scanPosition .<$*( co1 $*) $$abc
. e 2: pos 3 in line 1: $@.<$*( co1 $*) $$abc
*** err: scanErr wsh kindExe'@' expected: compile stopped before en+
d of input
. e 1: last token scanPosition $@.<$*( co1 $*) $$abc
. e 2: pos 1 in line 1: $@.<$*( co1 $*) $$abc
*** err: no method oRun in class String
$/tstCompSynFile/ */
call tstComp1 '@ tstCompSynFile +', '$@.<$*( co1 $*) $$abc'
return
endProcedure tstCompSynPrimary
tstCompSynAss: procedure expose m.
/*
$=/tstCompSynAss1/
### start tst tstCompSynAss1 ######################################
compile @, 1 lines: $=
*** err: scanErr block or expression in assignment after $= expecte+
d
. e 1: last token scanPosition .
. e 2: pos 3 in line 1: $=
$/tstCompSynAss1/ */
call tstComp1 '@ tstCompSynAss1 +', '$='
/*
$=/tstCompSynAss2/
### start tst tstCompSynAss2 ######################################
compile @, 2 lines: $= .
*** err: scanErr block or expression in assignment after $= expecte+
d
. e 1: last token scanPosition .
. e 2: pos 6 in line 1: $=
$/tstCompSynAss2/ */
call tstComp1 '@ tstCompSynAss2 +', '$= ', 'eins'
/*
$=/tstCompSynAss3/
### start tst tstCompSynAss3 ######################################
compile @, 2 lines: $= $$
*** err: scanErr block or expression in assignment after $= expecte+
d
. e 1: last token scanPosition $$
. e 2: pos 6 in line 1: $= $$
$/tstCompSynAss3/ */
call tstComp1 '@ tstCompSynAss3 +', '$= $$', 'eins'
/*
$=/tstCompSynAss4old/
### start tst tstCompSynAss4 ######################################
compile @, 1 lines: $= eins
*** err: scanErr = expected in assignment after $= var
. e 1: last token scanPosition .
. e 2: pos 10 in line 1: $= eins
$/tstCompSynAss4old/
$=/tstCompSynAss4/
### start tst tstCompSynAss4 ######################################
compile @, 1 lines: $= eins
*** err: scanErr wsh kindExe'@' expected: compile stopped before en+
d of input
. e 1: last token scanPosition $= eins
. e 2: pos 1 in line 1: $= eins
*** err: no method oRun in class String
$/tstCompSynAss4/ */
call tstComp1 '@ tstCompSynAss4 +', '$= eins'
/*
$=/tstCompSynAss5/
### start tst tstCompSynAss5 ######################################
compile @, 1 lines: $= abc eins $$ = x
*** err: scanErr wsh kindExe'@' expected: compile stopped before en+
d of input
. e 1: last token scanPosition $= abc eins $$ = x
. e 2: pos 1 in line 1: $= abc eins $$ = x
*** err: no method oRun in class String
$/tstCompSynAss5/
$=/tstCompSynAss5old/
### start tst tstCompSynAss5 ######################################
compile @, 1 lines: $= abc eins $$ = x
*** err: scanErr = expected in assignment after $= var
. e 1: last token scanPosition eins $$ = x
. e 2: pos 9 in line 1: $= abc eins $$ = x
$/tstCompSynAss5old/ */
call tstComp1 '@ tstCompSynAss5 +', '$= abc eins $$ = x'
/*
$=/tstCompSynAss6/
### start tst tstCompSynAss6 ######################################
compile @, 1 lines: $= abc =
*** err: scanErr block or expression in assignment after $= expecte+
d
. e 1: last token scanPosition .
. e 2: pos 10 in line 1: $= abc =
$/tstCompSynAss6/ */
call tstComp1 '@ tstCompSynAss6 +', '$= abc ='
/*
$=/tstCompSynAss7/
### start tst tstCompSynAss7 ######################################
compile @, 1 lines: $= abc =..
*** err: scanErr block or expression in assignment after $= expecte+
d
. e 1: last token scanPosition .
. e 2: pos 11 in line 1: $= abc =..
$/tstCompSynAss7/ */
call tstComp1 '@ tstCompSynAss7 +', '$= abc =.'
return
endProcedure tstCompSynAss
tstCompSynRun: procedure expose m.
/*
$=/tstCompSynRun1/
### start tst tstCompSynRun1 ######################################
compile @, 1 lines: $@
*** err: scanErr primary, block or expression expected
. e 1: last token scanPosition .
. e 2: pos 3 in line 1: $@
*** err: scanErr wsh kindExe'@' expected: compile stopped before en+
d of input
. e 1: last token scanPosition $@
. e 2: pos 1 in line 1: $@
*** err: no method oRun in class String
$/tstCompSynRun1/ */
call tstComp1 '@ tstCompSynRun1 +', '$@'
/*
$=/tstCompSynRun2/
### start tst tstCompSynRun2 ######################################
compile @, 1 lines: $@=
*** err: scanErr primary, block or expression expected
. e 1: last token scanPosition =
. e 2: pos 3 in line 1: $@=
*** err: scanErr wsh kindExe'@' expected: compile stopped before en+
d of input
. e 1: last token scanPosition $@=
. e 2: pos 1 in line 1: $@=
$/tstCompSynRun2/ */
call tstComp1 '@ tstCompSynRun2 +', '$@='
/*
$=/tstCompSynRun3/
### start tst tstCompSynRun3 ######################################
compile @, 1 lines: $@: und
*** err: scanErr bad kind : in compExpr
. e 1: last token scanPosition und
. e 2: pos 5 in line 1: $@: und
*** err: no method oRun in class Null
$/tstCompSynRun3/ */
call tstComp1 '@ tstCompSynRun3 +', '$@: und'
/*
$=/tstCompSynFor4/
### start tst tstCompSynFor4 ######################################
compile @, 1 lines: $@for
*** err: scanErr var? statement after for expected
. e 1: last token scanPosition .
. e 2: pos 6 in line 1: $@for
$/tstCompSynFor4/ */
call tstComp1 '@ tstCompSynFor4 +', '$@for'
/*
$=/tstCompSynFor5/
### start tst tstCompSynFor5 ######################################
compile @, 2 lines: $@for
*** err: scanErr var? statement after for expected
. e 1: last token scanPosition .
. e 2: pos 6 in line 1: $@for
$/tstCompSynFor5/ */
call tstComp1 '@ tstCompSynFor5 +', '$@for', a
/*
$=/tstCompSynFor6/
### start tst tstCompSynFor6 ######################################
compile @, 2 lines: a
*** err: scanErr variable or named block after for
. e 1: last token scanPosition .
. e 2: pos 15 in line 2: b $@for $$q
$/tstCompSynFor6/
call tstComp1 '@ tstCompSynFor6 +', 'a', ' b $@for $$q'
*/
/*
$=/tstCompSynFor7/
### start tst tstCompSynFor7 ######################################
compile @, 3 lines: a
*** err: scanErr var? statement after for expected
. e 1: last token scanPosition .
. e 2: pos 11 in line 2: b $@for a
$/tstCompSynFor7/ */
call tstComp1 '@ tstCompSynFor7 +', 'a', ' b $@for a', ' $$q'
/*
$=/tstCompSynCt8/
### start tst tstCompSynCt8 #######################################
compile @, 3 lines: a
*** err: scanErr ct statement expected
. e 1: last token scanPosition .
. e 2: pos 8 in line 2: b $@ct
$/tstCompSynCt8/ */
call tstComp1 '@ tstCompSynCt8 +', 'a', ' b $@ct', ' $$q'
/*
$=/tstCompSynProc9/
### start tst tstCompSynProc9 #####################################
compile @, 2 lines: a
*** err: scanErr var or namedBlock expected after proc
. e 1: last token scanPosition .
. e 2: pos 15 in line 2: b $@proc $$q
$/tstCompSynProc9/ */
call tstComp1 '@ tstCompSynProc9 +', 'a', ' b $@proc $$q'
/*
$=/tstCompSynProcA/
### start tst tstCompSynProcA #####################################
compile @, 2 lines: $@proc p1
*** err: scanErr proc statement expected
. e 1: last token scanPosition .
. e 2: pos 10 in line 1: $@proc p1
$/tstCompSynProcA/ */
call tstComp1 '@ tstCompSynProcA +', '$@proc p1', ' $$q'
/*
$=/tstCompSynCallB/
### start tst tstCompSynCallB #####################################
compile @, 1 lines: $@% ¢roc p1$!
*** err: scanErr primary, block or expression expected
. e 1: last token scanPosition % ¢roc p1$!
. e 2: pos 3 in line 1: $@% ¢roc p1$!
*** err: scanErr wsh kindExe'@' expected: compile stopped before en+
d of input
. e 1: last token scanPosition $@% ¢roc p1$!
. e 2: pos 1 in line 1: $@% ¢roc p1$!
*** err: no method oRun in class String
$/tstCompSynCallB/ */
call tstComp1 '@ tstCompSynCallB +', '$@% ¢roc p1$!'
/*
$=/tstCompSynCallC/
### start tst tstCompSynCallC #####################################
compile @, 1 lines: $@%¢call roc p1 !
*** err: scanErr ending $! expected after ¢
. e 1: last token scanPosition .
. e 2: atEnd after line 1: $@%¢call roc p1 !
$/tstCompSynCallC/ */
call tstComp1 '@ tstCompSynCallC +', '$@%¢call roc p1 !'
/*
$=/tstCompSynCallD/
### start tst tstCompSynCallD #####################################
compile @, 2 lines: $@^¢call( $** roc
*** err: scanErr ending $! expected after ¢
. e 1: last token scanPosition )
. e 2: pos 13 in line 2: $*( p1 $*) )
$/tstCompSynCallD/ */
call tstComp1 '@ tstCompSynCallD +',
,'$@^¢call( $** roc' , ' $*( p1 $*) )'
return
endProcedure tstCompSynRun
tstCompObj: procedure expose m.
call tstReset t
call classIni
cl = classNew('n? tstCompCla u v, f FEINS v, f FZWEI v')
do rx=1 to 10
o = oNew(cl)
m.tstComp.rx = o
m.o = 'o'rx
if rx // 2 = 0 then do
m.o.fEins = 'o'rx'.1'
m.o.fZwei = 'o'rx'.fZwei'rx
end
else do
m.o.fEins = 'o'rx'.fEins'
m.o.fZwei = 'o'rx'.2'
end
call mAdd 'T.TRANS', m.tstComp.rx '<o'rx'>'
end
/*
$=/tstCompObjRef/
### start tst tstCompObjRef #######################################
compile @, 13 lines: o1=m.tstComp.1
run without input
out .$"string" o1
string
out . o1
tstR: @<o1> isA :tstCompCla = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
out .{ o2 }
tstR: @<o2> isA :tstCompCla = o2
tstR: .FEINS = o2.1
tstR: .FZWEI = o2.fZwei2
out .¢ o3 $!
tstR: @<o3> isA :tstCompCla = o3
tstR: .FEINS = o3.fEins
tstR: .FZWEI = o3.2
out .¢ o4 $!
tstR: @<o4> isA :tstCompCla = o4
tstR: .FEINS = o4.1
tstR: .FZWEI = o4.fZwei4
out ./-/ o5 $/-/
tstR: @<o5> isA :tstCompCla = o5
tstR: .FEINS = o5.fEins
tstR: .FZWEI = o5.2
$/tstCompObjRef/ */
m.ttt=1
call tstComp1 '@ tstCompObjRef' ,
, 'o1=m.tstComp.1',
, 'o2 = m.tstComp.2' ,
, '$$ out $".$""string""" o1 $$."string"',
, '$$ out . o1 $$. o1',
, '$$ out .{ o2 } $$.¢ o2 $!',
, '$$ out .¢ o3 $"$!" $$.¢ ', ' m.tstComp.3 ', ' $!',
, '$$ out .¢ o4 $"$!" $$.¢ ', ' m.tstComp.4 ', ' $!',
, '$$ out ./-/ o5 $"$/-/" $$./-/ m.tstComp.5 ', ' $/-/'
/*
$=/tstCompObjRefPri/
### start tst tstCompObjRefPri ####################################
compile @, 9 lines: $$ out .$"$.{o1}" $$.¢ m.tstComp.1 $!
run without input
out .$.{o1}
tstR: @<o1> isA :tstCompCla = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
out .$.-{o2}
<o2>
out .$.={o3}
. m.tstComp.3 .
out .$.@{out o4}
tstWriteO kindOf ORun oRun begin <<<
tstR: @<o4> isA :tstCompCla = o4
tstR: .FEINS = o4.1
tstR: .FZWEI = o4.fZwei4
tstWriteO kindOf ORun oRun end >>>
out .$.@¢$$abc $$efg$!
tstWriteO kindOf ORun oRun begin <<<
abc
efg
tstWriteO kindOf ORun oRun end >>>
out .$.@¢o5$!
tstWriteO kindOf ORun oRun begin <<<
tstR: @<o5> isA :tstCompCla = o5
tstR: .FEINS = o5.fEins
tstR: .FZWEI = o5.2
abc
tstWriteO kindOf ORun oRun end >>>
$/tstCompObjRefPri/ */
call tstComp1 '@ tstCompObjRefPri' ,
, '$$ out .$"$.{o1}" $$.¢ m.tstComp.1 $!',
, '$$ out .$"$.-{o2}" $$.-¢ m.tstComp.2 $!',
, '$$ out .$"$.={o3}" $$.=¢ m.tstComp.3 $!',
, '$$ out .$"$.@{out o4}" $$.@@¢ call out m.tstComp.4 $!',
, '$$ out .$"$.@¢$$abc $$efg$!" $$. $.@@¢ $$abc ', ' ', ' $$efg $!',
, '$$ out .$"$.@¢o5$!" $$. $.@@¢ $$. m.tstComp.5', '$$abc $!'
/*
$=/tstCompObjRefFile/
### start tst tstCompObjRefFile ###################################
compile @, 7 lines: $$ out .$".<.¢o1!" $$.<.¢ m.tstComp.1 $!
run without input
out ..<.¢o1!
tstWriteO kindOf JRW jWriteNow begin <<<
tstR: @<o1> isA :tstCompCla = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
tstWriteO kindOf JRW jWriteNow end >>>
out .<$.-{o2}
tstWriteO kindOf JRW jWriteNow begin <<<
tstR: @<o2> isA :tstCompCla = o2
tstR: .FEINS = o2.1
tstR: .FZWEI = o2.fZwei2
tstWriteO kindOf JRW jWriteNow end >>>
out .$.<{o3}
tstWriteO kindOf JRW jWriteNow begin <<<
. m.tstComp.3 .
tstWriteO kindOf JRW jWriteNow end >>>
out .$.<@{out o4}
tstWriteO kindOf JRW jWriteNow begin <<<
tstR: @<o4> isA :tstCompCla = o4
tstR: .FEINS = o4.1
tstR: .FZWEI = o4.fZwei4
tstWriteO kindOf JRW jWriteNow end >>>
out .$<@¢$$abc $$efg$!
tstWriteO kindOf JRW jWriteNow begin <<<
abc
efg
tstWriteO kindOf JRW jWriteNow end >>>
$/tstCompObjRefFile/ */
call tstComp1 '@ tstCompObjRefFile' ,
, '$$ out .$".<.¢o1!" $$.<.¢ m.tstComp.1 $!',
, '$$ out .$"<$.-{o2}" $$<.¢ m.tstComp.2 $!',
, '$$ out .$"$.<{o3}" $$<=¢ m.tstComp.3 $!',
, '$$ out .$"$.<@{out o4}" $$<@¢ call out m.tstComp.4 $!',
, '$$ out .$"$<@¢$$abc $$efg$!" $$<@¢ $$abc ', ' ', ' $$efg $!'
/*
$=/tstCompObjFor/
### start tst tstCompObjFor #######################################
compile @, 2 lines: $@do rx=1 to 3 $$. m.tstComp.rx
run without input
FEINS=o1.fEins FZWEI=o1.2
FEINS=o2.1 FZWEI=o2.fZwei2
FEINS=o3.fEins FZWEI=o3.2
$/tstCompObjFor/
*/
call tstComp1 '@ tstCompObjFor' ,
, '$@do rx=1 to 3 $$. m.tstComp.rx' ,
, '$| $@forWith witx $$ FEINS=$FEINS FZWEI=$FZWEI'
/*
$=/tstCompObjRun/
### start tst tstCompObjRun #######################################
compile @, 4 lines: $$ out .$"$@¢o1!" $$@¢ $$. m.tstComp.1 $!
run without input
out .$@¢o1!
tstWriteO kindOf ORun oRun begin <<<
tstR: @<o1> isA :tstCompCla = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
tstWriteO kindOf ORun oRun end >>>
out .$<@¢$$abc $$efg$!
tstWriteO kindOf JRW jWriteNow begin <<<
abc
efg
tstWriteO kindOf JRW jWriteNow end >>>
$/tstCompObjRun/ */
call tstComp1 '@ tstCompObjRun' ,
, '$$ out .$"$@¢o1!" $$@¢ $$. m.tstComp.1 $!',
, '$$ out .$"$<@¢$$abc $$efg$!" $$<@¢ $$abc ', ' ', ' $$efg $!'
m.t.trans.0 = 0
/*
$=/tstCompObj/
### start tst tstCompObj ##########################################
compile @, 6 lines: o1=m.tstComp.1
run without input
out . o1
tstR: @tstWriteoV1 isA :tstCompCla = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
out .{ o2 }
tstR: @tstWriteoV2 isA :tstCompCla = o2
tstR: .FEINS = o2.1
tstR: .FZWEI = o2.fZwei2
out .¢ o1, o2!
tstR: @tstWriteoV1 isA :tstCompCla = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
tstR: @tstWriteoV2 isA :tstCompCla = o2
tstR: .FEINS = o2.1
tstR: .FZWEI = o2.fZwei2
$/tstCompObj/ */
call tstComp1 '@ tstCompObj' ,
, 'o1=m.tstComp.1',
, 'o2 = m.tstComp.2' ,
, '$$ out . o1 $$. o1',
, '$$ out .{ o2 } $$.¢ o2 $!',
, '$$ out .¢ o1, o2!$; $@.¢ m.tstComp.1 ', ' m.tstComp.2 $!'
return
m.t.trans.0 = 0
endProcedure tstCompObj
tstCompORun: procedure expose m.
/*
$=/tstCompORun/
### start tst tstCompORun #########################################
compile @, 6 lines: $@oRun
run without input
oRun arg=1, v2=, v3=, v4=
oRun arg=1, v2=, v3=, v4=
oRun arg=2, v2=-{1 arg only} oder?, v3=, v4=
oRun arg=2, v2=!.{1 obj only} oder?, v3=, v4=
oRun arg=3, v2={2 args}, v3=und zwei?, v4=
oRun arg=4, v2={3 args}, v3=zwei, v4=und drei?
$/tstCompORun/ */
call compIni
call vPut 'oRun', oRunner('parse arg , v2, v3, v4;',
'call tstOut t, "oRun arg="arg()", v2="v2", v3="v3", v4="v4' )
call tstComp1 '@ tstCompORun',
, '$@oRun', '$@%¢oRun$!' ,
, ' $@%¢oRun $"-{1 arg only}" oder?$!' ,
, ' $@%¢oRun - $.".{1 obj only}" ''oder?''$! $=v2=zwei' ,
, ' $@%¢oRun - $"{2 args}", "und" $v2"?"$!' ,
, ' $@%¢oRun - $"{3 args}", $v2, "und drei?"$!'
return
endProcedure tstCompORun
tstCompORu2: procedure expose m.
/*
$=/tstCompORu2/
### start tst tstCompORu2 #########################################
compile @, 6 lines: $@oRun
run without input
oRun arg=1, v2=, v3=, v4=
oRun arg=1, v2=, v3=, v4=
oRun arg=2, v2=eins, zwei, drei, v3=, v4=
oRun arg=2, v2=eins, zwei, drei, v3=, v4=
oRun arg=4, v2=-eins, v3=zwei, v4=DREI
oRun arg=4, v2=-eins, v3=zwei, v4=DREI
$/tstCompORu2/ */
call compIni
call vPut 'oRun', oRunner('parse arg , v2, v3, v4;',
'call tstOut t, "oRun arg="arg()", v2="v2", v3="v3", v4="v4' )
call tstComp1 '@ tstCompORu2',
, '$@oRun', '$@%oRun',
, '$@% oRun eins, zwei, drei' ,
, '$@%¢ oRun eins, zwei, drei $!',
, '$@% oRun - "-eins", "zwei", drei' ,
, '$@%¢ oRun - "-eins", "zwei", drei $!'
return
endProcedure tstCompORu2
tstCompORuRe: procedure expose m.
/*
$=/tstCompORuRe/
### start tst tstCompORuRe ########################################
compile @, 9 lines: $$ primary $-^oRuRe eins, zwei
run without input
primary oRuRe(arg=1, v2=, v3=) eins, zwei
oRuRe(arg=2, v2=expr, zwei, v3=)
oRuRe(arg=3, v2=-expr, v3=zwei)
oRuRe(arg=2, v2=block, zwei, v3=)
oRuRe(arg=3, v2=-block, v3=zwei)
$/tstCompORuRe/ */
call compIni
call vPut 'oRuRe', oRunner('parse arg , v2, v3;',
'return "oRuRe(arg="arg()", v2="v2", v3="v3")"' )
call tstComp1 '@ tstCompORuRe',
, '$$ primary $-^oRuRe eins, zwei' ,
, '$$-^ oRuRe expr, zwei',
, '$$-^ oRuRe - "-expr", "zwei"',
, '$$-^¢oRuRe block, zwei$!' ,
, '$$-^¢',, 'oRuRe - "-block", "zwei"' , , '$!'
return
endProcedure tstCompORuRe
tstCompDataIO: procedure expose m.
/*
$=/tstCompDataHereData/
### start tst tstCompDataHereData #################################
compile =, 13 lines: herdata $@#/stop/ .
run without input
. herdata .
heredata 1 $x
heredata 2 $y
nach heredata
. herdata ¢ .
heredata 1 xValue
heredata 2 yValueY
nach heredata ¢
. herdata { .
HEREDATA 1 xValue
heredata 2 yValueY
nach heredata {
$/tstCompDataHereData/ */
call tstComp1 '= tstCompDataHereData',
, ' herdata $@#/stop/ ',
, 'heredata 1 $x',
, 'heredata 2 $y',
, '$/stop/ $$ nach heredata',
, ' herdata ¢ $@=/stop/ ',
, '$=x=xValue$=y=yValueY',
, 'heredata 1 $x',
, 'heredata 2 $y',
, '$/stop/ $$ nach heredata ¢',
, ' herdata { $@/st/',
, '; call out heredata 1 $x',
, '$$heredata 2 $y',
, '$/st/ $$ nach heredata {'
/*
$=/tstCompDataIO/
### start tst tstCompDataIO #######################################
compile =, 5 lines: input 1 $@.<-=¢$dsn $*+.
run without input
. input 1 .
readInp line 1 .
readInp line 2 .
. nach dsn input und nochmals mit & .
readInp line 1 .
readInp line 2 .
. und schluiss..
$/tstCompDataIO/ */
dsn = word(tstPdsMbr(tstFilename('lib37', 'r'), 'readInp'), 1)
dsnFB = strip(dsn tstFB('::F37', 0))
b = jBuf(tstFB('readInp line 1', 37),
,tstFB('readInp line 2', 37))
extFd = tstFB('&dsn('dsn') dd(xyz)', 0)
extFd = tstFB(dsn 'dd(xyz) ::f', 0)
if extFd = '' then
extFd = dsn
call jCat file(dsnFB), b
call vPut 'dsn', dsn
say 'dsn' dsn 'extFD' extFD'?'
call tstComp1 '= tstCompDataIO',
, ' input 1 $@.<-=¢$dsn $*+',
, tstFB('::f', 0) '$!',
, ' nach dsn input und nochmals mit & ' ,
, ' $@.<'extFD,
, ' und schluiss.'
return
endProcedure tstCompDataIO
tstObjVF: procedure expose m.
parse arg v, f
obj = oNew(classNew('n? TstClassVF u v, f FLD1 v'))
m.obj = if(f=='','val='v, v)
m.obj.fld1 = if(f=='','FLD1='v, f)
return obj
endProcedure tstObjVF
tstCompFile: procedure expose m.
/*
$=/tstCompFileBloSrc/
$=vv=value-of-vv
###file from empty # block
$@<#¢
$!
###file from 1 line # block
$@<#¢
the only $ix+1/0 line $vv
$!
###file from 2 line # block
$@<#¢
first line /0 $*+ no comment
second and last line $$ $wie
$!
===file from empty = block
$@<=¢ $*+ comment
$!
===file from 1 line = block
$@<=¢ the only line $!
===file from 2 line = block
$@<=¢ first line$** comment
second and last line $!
---file from empty - block
$@<-/s/
$/s/
---file from 1 line - block
$@<-/s/ the only "line" (1*1) $/s/
---file from 2 line = block
$@<-// first "line" (1+0)
second and "last line" (1+1) $//
...file from empty . block
$@<.¢
$!
...file from 1 line . block
$@<.¢ tstObjVF('v-Eins', '1-Eins') $!
...file from 2 line . block
$@<.¢ tstObjVF('v-Elf', '1-Elf')
tstObjVF('zwoelf') $!
...file from 3 line . block
$@<.¢ tstObjVF('einUndDreissig')
s2o('zweiUndDreissig' o2String($.-vv))
tstObjVF('dreiUndDreissig') $!
@@@file from empty @ block
$@<@¢
$!
$=noOutput=before
@@@file from nooutput @ block
$@<@¢ nop
$=noOutput = run in block $!
@@@nach noOutput=$noOutput
@@@file from 1 line @ block
$@<@¢ $$. tstObjVF('w-Eins', 'w1-Eins') $!
@@@file from 2 line @ block
$@<@¢ $$. tstObjVF('w-Elf', 'w1-Elf')
y='zwoelf' $$- y $!
@@@file from 3 line @ block
$@<@¢ $$. tstObjVF('w einUndDreissig') $$ +
zweiUndDreissig $$ 33 $vv$!
{{{ empty ¢ block
$@<¢ $!
{{{ empty ¢ block with comment
$@<¢ $*+ abc
$!
{{{ one line ¢ block
$@<¢ the only $"¢...$!" line $*+.
$vv $!
{{{ one line -¢ block
$@<-¢ the only $"-¢...$!" "line" $vv $!
{{{ empty #¢ block
$@<#¢
$!
{{{ one line #¢ block
$@<#¢ the only $"-¢...$!" "line" $vv $¢vv${x}$!
$!
$/tstCompFileBloSrc/ */
/*
$=/tstCompFileBlo/
### start tst tstCompFileBlo ######################################
compile =, 72 lines: $=vv=value-of-vv
run without input
###file from empty # block
###file from 1 line # block
the only $ix+1/0 line $vv
###file from 2 line # block
first line /0 $*+ no comment
second and last line $$ $wie
===file from empty = block
===file from 1 line = block
. the only line .
===file from 2 line = block
. first line
second and last line .
---file from empty - block
---file from 1 line - block
THE ONLY line 1
---file from 2 line = block
FIRST line 1
SECOND AND last line 2
...file from empty . block
...file from 1 line . block
tstR: @tstWriteoV1 isA :TstClassVF = v-Eins
tstR: .FLD1 = 1-Eins
...file from 2 line . block
tstR: @tstWriteoV2 isA :TstClassVF = v-Elf
tstR: .FLD1 = 1-Elf
tstR: @tstWriteoV3 isA :TstClassVF = val=zwoelf
tstR: .FLD1 = FLD1=zwoelf
...file from 3 line . block
tstR: @tstWriteoV4 isA :TstClassVF = val=einUndDreissig
tstR: .FLD1 = FLD1=einUndDreissig
zweiUndDreissig value-of-vv
tstR: @tstWriteoV5 isA :TstClassVF = val=dreiUndDreissig
tstR: .FLD1 = FLD1=dreiUndDreissig
@@@file from empty @ block
@@@file from nooutput @ block
@@@nach noOutput=run in block
@@@file from 1 line @ block
tstR: @tstWriteoV6 isA :TstClassVF = w-Eins
tstR: .FLD1 = w1-Eins
@@@file from 2 line @ block
tstR: @tstWriteoV7 isA :TstClassVF = w-Elf
tstR: .FLD1 = w1-Elf
zwoelf
@@@file from 3 line @ block
tstR: @tstWriteoV8 isA :TstClassVF = val=w einUndDreissig
tstR: .FLD1 = FLD1=w einUndDreissig
zweiUndDreissig
33 value-of-vv
{{{ empty ¢ block
{{{ empty ¢ block with comment
{{{ one line ¢ block
. the only ¢...$! line value-of-vv .
{{{ one line -¢ block
THE ONLY -¢...$! line value-of-vv
{{{ empty #¢ block
{{{ one line #¢ block
. the only $"-¢...$!" "line" $vv $¢vv${x}$!
$/tstCompFileBlo/ */
call tstComp2 'tstCompFileBlo', '='
m.t.trans.0 = 0
/*
$=/tstCompFileObjSrc/
$=vv=value-vv-1
$=fE=<¢ $!
$=f2=. $.<.¢s2o("f2 line 1" o2String($.-vv))
tstObjVF("f2 line2") $!
---empty file $"$@<$fE"
$@fE
---file with 2 lines $"$@<$f2"
$@.<.f2
$=vv=value-vv-2
---file with 2 lines $"$@<$f2"
$@.<.f2
$= dsn =- word(tstPdsMbr(tstFilename('libvb', 'r'), 'fileObj'),1) +
tstFB('::V', 0)
$@¢
fi=jOpen(file($dsn),'>')
call jWrite fi, 'line one on' $"$dsn"
call jWrite fi, 'line two on' $"$dsn"
call jClose fi
$!
---file on disk out
$@<-dsn
$/tstCompFileObjSrc/ */
/*
$=/tstCompFileObj/
### start tst tstCompFileObj ######################################
compile =, 20 lines: $=vv=value-vv-1
run without input
---empty file $@<$fE
---file with 2 lines $@<$f2
f2 line 1 value-vv-1
tstR: @tstWriteoV1 isA :TstClassVF = val=f2 line2
tstR: .FLD1 = FLD1=f2 line2
---file with 2 lines $@<$f2
f2 line 1 value-vv-1
tstR: @tstWriteoV1 isA :TstClassVF = val=f2 line2
tstR: .FLD1 = FLD1=f2 line2
---file on disk out
line one on $dsn
line two on $dsn
$/tstCompFileObj/ */
call tstComp2 'tstCompFileObj', '='
return
endProcedure tstCompFile
tstCompPipe: procedure expose m.
/*
$=/tstCompPipe1/
### start tst tstCompPipe1 ########################################
compile @, 1 lines: call pipePreSuf "(1 ", " 1)"
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
(1 eins zwei drei 1)
#jIn 2# zehn elf zwoelf?
(1 zehn elf zwoelf? 1)
#jIn 3# zwanzig 21 22 23 24 ... 29|
(1 zwanzig 21 22 23 24 ... 29| 1)
#jIn eof 4#
$/tstCompPipe1/ */
call tstComp1 '@ tstCompPipe1 3',
, ' call pipePreSuf "(1 ", " 1)"'
/*
$=/tstCompPipe2/
### start tst tstCompPipe2 ########################################
compile @, 2 lines: call pipePreSuf "(1 ", " 1)"
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
#jIn 2# zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
¢2 (1 eins zwei drei 1) 2!
¢2 (1 zehn elf zwoelf? 1) 2!
¢2 (1 zwanzig 21 22 23 24 ... 29| 1) 2!
$/tstCompPipe2/ */
call tstComp1 '@ tstCompPipe2 3',
, ' call pipePreSuf "(1 ", " 1)"' ,
, ' $| call pipePreSuf "¢2 ", " 2!"'
/*
$=/tstCompPipe3/
### start tst tstCompPipe3 ########################################
compile @, 3 lines: call pipePreSuf "(1 ", " 1)"
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
#jIn 2# zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
<3 ¢2 (1 eins zwei drei 1) 2! 3>
<3 ¢2 (1 zehn elf zwoelf? 1) 2! 3>
<3 ¢2 (1 zwanzig 21 22 23 24 ... 29| 1) 2! 3>
$/tstCompPipe3/ */
call tstComp1 '@ tstCompPipe3 3',
, ' call pipePreSuf "(1 ", " 1)"' ,
, ' $| call pipePreSuf "¢2 ", " 2!"',
, ' $| call pipePreSuf "<3 ", " 3>"'
/*
$=/tstCompPipe4/
### start tst tstCompPipe4 ########################################
compile @, 7 lines: call pipePreSuf "(1 ", " 1)"
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
#jIn 2# zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
<3 ¢222 ¢221 ¢21 ¢20 (1 eins zwei drei 1) 20! 21! 221! 222! 3>
<3 ¢222 ¢221 ¢21 ¢20 (1 zehn elf zwoelf? 1) 20! 21! 221! 222! 3>
<3 ¢222 ¢221 ¢21 ¢20 (1 zwanzig 21 22 23 24 ... 29| 1) 20! 21! 221!+
. 222! 3>
$/tstCompPipe4/ */
call tstComp1 '@ tstCompPipe4 3',
, ' call pipePreSuf "(1 ", " 1)"' ,
, ' $| $@¢ call pipePreSuf "¢20 ", " 20!"',
, ' $| call pipePreSuf "¢21 ", " 21!"',
, ' $| $@¢ call pipePreSuf "¢221 ", " 221!"',
, ' $| call pipePreSuf "¢222 ", " 222!"',
, '$! $! ',
, ' $| call pipePreSuf "<3 ", " 3>"'
return
endProcedure tstCompPipe
tstCompPip2: procedure expose m.
/*
$=/tstCompPip21/
### start tst tstCompPip21 ########################################
compile @, 3 lines: $<¢ zeile eins .
run without input
(1 zeile eins 1)
(1 zeile zwei 1)
run with 3 inputs
(1 zeile eins 1)
(1 zeile zwei 1)
$/tstCompPip21/ */
call tstComp1 '@ tstCompPip21 3',
, ' $<¢ zeile eins ' ,
, ' zeile zwei $!' ,
, ' call pipePreSuf "(1 ", " 1)"'
/*
$=/tstCompPip22/
### start tst tstCompPip22 ########################################
compile @, 3 lines: if ${>i1} then $@¢
run without input
#jIn eof 1#
nachher
run with 3 inputs
#jIn 1# eins zwei drei
<zeile 1: eins zwei drei>
<zwei>
nachher
$/tstCompPip22/ */
call tstComp1 '@ tstCompPip22 3',
, 'if ${>i1} then $@¢' ,
, ' $$ zeile 1: $i1 $$ zwei $| call pipePreSuf "<",">" $!',
, ' $$ nachher '
return
endProcedure tstCompPip2
tstCompRedir: procedure expose m.
/*
$=/tstCompRedir/
### start tst tstCompRedir ########################################
compile @, 6 lines: $=eins=<@¢ $@for vv $$ <$vv> $! .
run without input
#jIn eof 1#
output eins .
output piped zwei .
run with 3 inputs
#jIn 1# eins zwei drei
#jIn 2# zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
output eins <eins zwei drei> <zehn elf zwoelf?> +
<zwanzig 21 22 23 24 ... 29|>
output piped zwei ab<eins zwei drei>yz ab<zehn elf zwoelf?>yz a+
b<zwanzig 21 22 23 24 ... 29|>yz
$/tstCompRedir/ */
call pipeIni
call vRemove 'eins' /* alte Variable loswerden */
dsn = word(tstPdsMbr(tstFilename('libvb', 'r'), 'redir1'), 1)
call vPut 'dsn', dsn
say 'dsn' $dsn
call tstComp1 '@ tstCompRedir 3' ,
, ' $=eins=<@¢ $@for vv $$ <$vv> $! ',
, ' $$ output eins $-=¢$@.eins$! $; ',
, ' $@for ww $$b${ww}y ' ,
, ' $>-= $-¢ $dsn $! 'tstFB('::v', 0),
, '$| call pipePreSuf "a", "z" $<.eins' ,
, ' $; $$ output piped zwei $-=¢$@<$-dsn$!'
/*
$=/tstCompRedi2/
### start tst tstCompRedi2 ########################################
compile @, 12 lines: call mAdd t.trans, $var "dsnTestRedi"
run without input
>1<dsnTestRedi currTimeRedi
>2<$"dsnTestRedi" currTimeRedi
>3<$"dsnTestRedi" ::v currTimeRedi
>4<$-var" currTimeRedi
>5<$dsnTestRedi" currTimeRedi
$/tstCompRedi2/
*/
call vPut 'var', tstFileName('compRedi', 'r')
call vPut 'tst', translate(date()'+'time()'+testRedi2', '_', ' ')
call tstComp1 '@ tstCompRedi2 ' ,
, 'call mAdd t.trans, $var "dsnTestRedi"',
, 'call mAdd t.trans, $tst "currTimeRedi"',
, '$<> $>'vGet('var') '::v $$ $">1<'vGet('var')'" $tst',
, '$<> $<'vGet('var') ' $@ call pipeWriteAll' ,
, '$<> $>$"'vGet('var')' ::v" $$ $">2<$""'vGet('var')'""" $tst',
, '$<> $<$"'vGet('var') '" $@ call pipeWriteAll',
, '$<> $>$"'vGet('var')'" ::v $$ $">3<$""'vGet('var')'"" ::v" $tst',
, '$<> $<$"'vGet('var') '" $@ call pipeWriteAll',
, '$<> $>-var $$ $">4<$"-var" $tst',
, '$<> $<-var $@ call pipeWriteAll',
, '$<> $>$var ::v $$ $">5<$"$var" $tst',
, '$<> $<$var $@ call pipeWriteAll'
return
endProcedure tstCompRedir
tstCompComp: procedure expose m.
/*
$=/tstCompCompShell/
### start tst tstCompCompShell ####################################
compile @, 5 lines: $$compiling shell $; $= rrr =. $.^compile $<@#/+
aaa/
run without input
compiling shell
running einmal
RUN 1 COMPILED einmal
#jIn eof 1#
running zweimal
RUN 1 COMPILED zweimal
#jIn eof 2#
run with 3 inputs
compiling shell
running einmal
RUN 1 COMPILED einmal
#jIn 1# eins zwei drei
compRun eins zwei dreieinmal
#jIn 2# zehn elf zwoelf?
compRun zehn elf zwoelf?einmal
#jIn 3# zwanzig 21 22 23 24 ... 29|
compRun zwanzig 21 22 23 24 ... 29|einmal
#jIn eof 4#
running zweimal
RUN 1 COMPILED zweimal
#jIn eof 5#
$/tstCompCompShell/ */
call tstComp1 '@ tstCompCompShell 3',
, "$$compiling shell $; $= rrr =. $.^compile $<@#/aaa/",
, "call out run 1*1*1 compiled $cc;" ,
"$@for v $$ compRun $v$cc" ,
, "$/aaa/ $;",
, "$=cc=einmal $$ running $cc $@rrr",
, "$=cc=zweimal $$ running $cc $@rrr"
/*
$=/tstCompCompData/
### start tst tstCompCompData #####################################
compile @, 5 lines: $$compiling data $; $= rrr =. $.^¢compile = +
=$! $<@#/aaa/
run without input
compiling data
running einmal
call out run 1*1*1 compiled einmal
running zweimal
call out run 1*1*1 compiled zweimal
run with 3 inputs
compiling data
running einmal
call out run 1*1*1 compiled einmal
running zweimal
call out run 1*1*1 compiled zweimal
$/tstCompCompData/ */
call tstComp1 '@ tstCompCompData 3',
, "$$compiling data $; $= rrr =. $.^¢compile = =$! $<@#/aaa/",
, "call out run 1*1*1 compiled $cc",
, "$/aaa/ $;",
, "$=cc=einmal $$ running $cc $@rrr",
, "$=cc=zweimal $$ running $cc $@rrr"
return
endProcedure tstCompComp
tstCompDir: procedure expose m.
/*
$=/tstCompDirSrc/
'in src v1='$v1
$#@ call out 'src @ out v1='$v1
$#. $*(komm$*) s2o('src . v1=')
$.-v1
$#-
'src - v1='$v1
$#=
src = v1=$v1
$/tstCompDirSrc/
$=/tstCompDir/
### start tst tstCompDir ##########################################
compile @call out 'before v1='$v1 $=v1=eins $#. s2o('. v1='$-v1) $#+
@ call out '@ v1='$v1 $#= = v1=$v1 $#- '- v1='$v1 $#-, 8 lines: 'in+
. src v1='$v1
run without input
before v1=v1Before
.. v1=eins
@ v1=eins
= v1=eins .
- v1=eins
in src v1=eins
src @ out v1=eins
src . v1=
eins
src - v1=eins
src = v1=eins
$/tstCompDir/ */
call compIni
call vPut 'v1', 'v1Before'
call tstComp2 'tstCompDir', "@call out 'before v1='$v1 $=v1=eins" ,
"$#. s2o('. v1='$-v1) $#@ call out '@ v1='$v1" ,
"$#= = v1=$v1 $#- '- v1='$v1 $#-"
/*
$=/tstCompDirPiSrc/
zeile 1 v1=$v1
zweite Zeile vor $"$@$#-"
$#@ $@proc pi2 $@-¢
$'zeile drei nach $@$#- v1='v1
vierte und letzte Zeile $!
$/tstCompDirPiSrc/ */
/*
$=/tstCompDirPi/
### start tst tstCompDirPi ########################################
compile @call pipePreSuf '<','>' $=v1=eiPi $<.pi2 $#=, 5 lines: ze+
ile 1 v1=$v1
run without input
<zeile drei nach $@$#- v1=V1>
<VIERTE UND LETZTE ZEILE>
zeile 1 v1=eiPi
zweite Zeile vor $@$#-
$/tstCompDirPi/ */
call tstComp2 'tstCompDirPi',
, "@call pipePreSuf '<','>' $=v1=eiPi $<.pi2 $#="
return
endProcedure tstCompDir
tstCompColon: procedure expose m.
/*
$=/tstCompColon1/
### start tst tstCompColon1 #######################################
compile :, 12 lines: vA = valueVonA
run without input
vA = valueVonA
vA=valueVonA vB=valueVonB vC=valueVonC
vC=valueVonC vD=valueVonD vE=valueVonvE
vF=6
$/tstCompColon1/ */
call tstComp1 ': tstCompColon1',
, 'vA = valueVonA' ,
, ' $$ vA = $vA' ,
, ' * kommentar ' ,
, '=vB=- "valueVonB"' ,
, '=/vC/valueVonC$/vC/' ,
, ' $$ vA=$vA vB=$vB vC=$vC' ,
, '$=/vD/valueVonD' ,
, '$/vD/ vE=valueVonvE' ,
, ' * kommentar ' ,
, ' $$ vC=$vC vD=$vD vE=$vE',
, 'vF=- 2*3 $=vG=@@¢ $$ vF=$vF$!' ,
, '@vG'
/*
$=/tstCompColon2/
### start tst tstCompColon2 #######################################
compile :, 7 lines: ix=0
run without input
#jIn eof 1#
proc p1 arg(2) total 0 im argumentchen
run with 3 inputs
#jIn 1# eins zwei drei
#jIn 2# zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
<<for 1 -> eins zwei drei>>
<<for 2 -> zehn elf zwoelf?>>
<<for 3 -> zwanzig 21 22 23 24 ... 29|>>
proc p1 arg(2) total 3 im argumentchen
$/tstCompColon2/
*/
call tstComp1 ': tstCompColon2 3',
, 'ix=0' ,
, 'for v @:¢ix=- $ix+1',
, ' $$ for $ix -> $v' ,
, '! | @¢call pipePreSuf "<<",">>"',
, '$! @%¢p1 total $ix im argumentchen$!',
, 'proc @:/p1/$$- "proc p1 arg(2)" arg(2)' ,
, '/p1/'
/*
$=/tstCompColon3/
### start tst tstCompColon3 #######################################
compile :, 11 lines: tc3Eins=freeVar1
run without input
tc3Eins=freeVar1 o2&tc3Eins= o2&tc3Zwei=
tc3Eins=freeVar1 o2&tc3Eins=with3Eins o2&tc3Zwei=with3Zwei
tc3Eins=freeVar1 o2&tc3Eins=ass4Eins o2&tc3Zwei=with5Zwei
o3&tc3Eins=ass4Eins o3&tc3Zwei=with5 o3 Zwei
tc3Eins=freeVar1 o2&tc3Eins=ass4Eins o2&tc3Zwei=with5Zwei
$/tstCompColon3/
*/
call classNew 'n? TstCompColon3 u f tc3Eins v, f tc3Zwei v'
showO2 = 'tc3Eins=$tc3Eins' ,
'o2&tc3Eins=${o2&tc3Eins} o2&tc3Zwei=${o2&tc3Zwei}'
showO3 = 'o3&tc3Eins=${o3&tc3Eins} o3&tc3Zwei=${o3&tc3Zwei}'
call tstComp1 ': tstCompColon3',
, 'tc3Eins=freeVar1' ,
, 'o2 =. oNew("TstCompColon3")' ,
, '$$' showO2 ,
, 'with $o2 $@:¢tc3Eins = with3Eins',
, 'tc3Zwei = with3Zwei',
, '! $$' showO2 ,
, '{o2&tc3Eins} = ass4Eins',
, 'with $o2 $=tc3Zwei = with5Zwei',
, '$$' showO2 ,
, 'with o3 =. oCopy($o2) $=tc3Zwei = with5 o3 Zwei',
, '$$' showO3 '$$' showO2
return
endProcedure tstCompColon
tstCompTable: procedure expose m.
/*
$=/tstCompTable1/
### start tst tstCompTable1 #######################################
compile :, 6 lines: table $*( sdf $*) .
run without input
tstR: @tstWriteoV2 isA :<TstCT1Class>
tstR: .fEins = v1
tstR: .fZwei = valueZwei undD
tstR: .fDrei = rei
zweite
tstR: @tstWriteoV3 isA :<TstCT1Class>
tstR: .fEins = w1 wZwe
tstR: .fZwei = i
tstR: .fDrei = wwwDrei
$/tstCompTable1/
*/
call wshIni
cl = classNew('n* CompTable u f fEins v, f fZwei v, f fDrei v')
c2 = classNew('n* CompTable u f fEins v, f fDrei v')
call tstComp1 ': tstCompTable1',
, 'table $*( sdf $*) ' ,
, 'fEins fZwei $*(....$*) fDrei ' ,
, '$@¢call mAdd t.trans, className("'cl'") "<TstCT1Class>"$!',
, ' v1 valueZwei undDrei ' ,
, '$$ zweite',
, ' w1 wZwei wwwDrei '
/*
$=/tstCompWithNew/
### start tst tstCompWithNew ######################################
compile :, 12 lines: withNew
run without input
tstR: @tstWriteoV2 isA :<TstCT1Class>
tstR: .fEins = withNewValue fEins
tstR: .fZwei = withNewValue fZwei
tstR: .fDrei = withNewValuel drei
tstR: @tstWriteoV3 isA :<TstCT1Class>
tstR: .fEins = withNewValue fEinsB
tstR: .fZwei = withNewValue fZweiB
tstR: .fDrei = withNewValue fDreiB
tstR: @tstWriteoV5 isA :<TstCT2Class>
tstR: .fEins = withValue fEinsC
tstR: .fDrei = withValue fDreiC
$/tstCompWithNew/
*/
call tstComp1 ': tstCompWithNew',
, 'withNew' ,
, 'fEins = withNewValue fEins' ,
, 'fZwei = withNewValue fZwei' ,
, '$@¢call mAdd t.trans, className("'cl'") "<TstCT1Class>"',
, '$@:¢ fDrei = withNewValuel drei $! $! ' ,
, 'withNew ' ,
, 'fEins = withNewValue fEinsB' ,
, 'fZwei = withNewValue fZweiB',
, 'fDrei = withNewValue fDreiB',
, 'withNew fEins = withValue fEinsC' ,
, '$@¢call mAdd t.trans, className("'c2'") "<TstCT2Class>"',
, '$@¢$=fDrei = withValue fDreiC$! $! '
/*
$=/tstCompWithNeRe/
### start tst tstCompWithNeRe #####################################
compile :, 11 lines: withNew
run without input
tstR: @tstWriteoV2 isA :<TstClassR2>
tstR: .rA = value rA
tstR: .rB refTo @!value rB isA :w
tstR: @tstWriteoV4 isA :<TstClassR2>
tstR: .rA = val33 rA
tstR: .rB refTo @!VAL33 RB isA :w
tstR: @tstWriteoV5 isA :<TstClassR2>
tstR: .rA = val22 rA
tstR: .rB refTo @!VAL22 RB isA :w
tstR: @tstWriteoV6 isA :<TstCT1Class>
tstR: .fEins = withNewValue fEins
tstR: .fZwei = withNewValue fZwei
tstR: .fDrei = withNewValuel drei
vOth=value vOth fZwei=fZwei Wert vorher ?fDrei=0
$/tstCompWithNeRe/
*/
cR = classNew("n* CompTable u f rA v, f rB r")
call vRemove 'fDrei'
call vPut 'fZwei', 'fZwei Wert vorher'
call tstComp1 ': tstCompWithNeRe',
, 'withNew' ,
, 'fEins = withNewValue fEins' ,
, '@:¢withNew rA =value rA $=rB=. "!value rB" ' ,
, '$@ call mAdd t.trans, className("'cR'") "<TstClassR2>"$!',
, 'fZwei = withNewValue fZwei' ,
, '$@¢call mAdd t.trans, className("'cl'") "<TstCT1Class>"',
, '$@:¢withNew rA =val22 rA $=rB=. !val22 rB ' ,
, '{vOth} = value vOth',
, '$@:¢withNew rA =val33 rA $=rB=. !val33 rB $! $!' ,
, '$@:¢ fDrei = withNewValuel drei $! $! ',
, '$<> $$ vOth=$vOth fZwei=$fZwei ?fDrei=${?fDrei}'
return
endProcedure tstCompTable
tstCompSql: procedure expose m.
/*
$=/tstCompSqlSrc/
$@=¢
select strip(creator) cr, strip(name) tb,
(row_number()over())*(row_number()over()) rr
from sysibm.sysTables
where creator='SYSIBM' and name like 'SYSTABL%'
order by 2 fetch first 4 rows only
$!
$| call sqlSel
$| call fTabAuto
$/tstCompSqlSrc/
$=/tstCompSql/
### start tst tstCompSql ##########################################
compile @, 9 lines: $@=¢
run without input
CR TB RR
SYSIBM SYSTABLEPART 1
SYSIBM SYSTABLEPART_HIST 4
SYSIBM SYSTABLES 9
SYSIBM SYSTABLESPACE 16
$/tstCompSql/
$=/tstCompSqlFTabSrc/
$$ select 'ahaaaax' ahaCol, 'buuuuh' buhhhh from sysibm.sysDummy1
$| $@. vPut('lc', sqlRdr(scanSqlIn2Stmt()))
$| call fTab sqlFTabOthers(sqlRdrFTabReset($.lc, tstCompSql1))
$<>
$$ select 'aOh' ahaOhne, 'buuVar' buhVar from sysibm.sysDummy1
$| call sqlSel
$| t2 = fTabReset(sqlRdrFTabReset( , tstCompS2), '2 1', '2 c', '-')
ox = m.t2.0 + 1
call sqlFTabOthers t2
call fTab fTabAddTit(t2, ox, 2, '-----')
$<>
$$ select 'aOh' aDrei, 'buuDre' buhDrei from sysibm.sysDummy1
$| call sql2Tab
$/tstCompSqlFTabSrc/
$=/tstCompSqlFTab/
### start tst tstCompSqlFTab ######################################
compile @, 13 lines: $$ select 'ahaaaax' ahaCol, 'buuuuh' buhhhh fr+
om sysibm.sysDummy1
run without input
AHACOL--BUHHHH---
ahaaaax buuuuh
AHACOL--BUHHHH---
-----
AHA-BUHVAR---
aOh buuVar
-----
AHAOHNE
. BUHVAR
ADREI
. BUHDREI
ADR-BUHDRE---
aOh buuDre
ADR-BUHDRE---
ADREI
. BUHDREI
$/tstCompSqlFTab/
### start tst tstCompSql ##########################################
*/
call sqlConnect
call tstComp2 'tstCompSql', '@'
call tstComp2 'tstCompSqlFTab', '@'
call sqlDisConnect
return
endProcedure tstCompSql
tstTut0: procedure expose m.
/*
$=/tstTut01Src/
$#=
$*+>.fSub() Kommentar
$*+>~tmp.jcl(t) Kommentar
$*+@=¢ Kommentar
$=subsys=DP4G
$=db=DA540769
$=ts=A977A
$*+@<~wk.jcl(jc) Kommentar
??* ?-¢sysvar(sysnode) date() time()?!ts=$ts 10*len=$-¢length($ts)*10$!
//P02 EXEC PGM=DSNUTILB,
// PARM='$subsys,A540769C.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=$subsys.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE $db.$ts* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
$@¢if right($ts, 2) == '7A' then $@=¢
FULL YES
$! else
$$ $'' FULL NO
$!
SHRLEVEL CHANGE
$*+! Kommentar
$#out original/src
$/tstTut01Src/
$=/tstTut01/
### start tst tstTut01 ############################################
compile , 28 lines: $#=
run without input
??* ?-¢sysvar(sysnode) date() time()?!ts=A977A 10*len=50
//P02 EXEC PGM=DSNUTILB,
// PARM='DP4G,A540769C.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DA540769.A977A* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
FULL YES
SHRLEVEL CHANGE
$/tstTut01/
$=/tstTut02Src/
$#@
$**>.fSub()
$**@¢
$=subsys=DP4G
$=db=DA540769
$=jx=0
$@do tx = 976 to 977 $@=¢
$=ts=A$tx
$=jx=- $jx+1
//A540769$jx JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//C$ts EXEC PGM=DSNUTILB,
// PARM='$subsys,A540769$jx.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=$subsys.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE $db.$ts* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$!
$**!
$#out original/src
$/tstTut02Src/
$=/tstTut02/
### start tst tstTut02 ############################################
compile , 28 lines: $#@
run without input
//A5407691 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA976 EXEC PGM=DSNUTILB,
// PARM='DP4G,A5407691.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DA540769.A976* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
//A5407692 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA977 EXEC PGM=DSNUTILB,
// PARM='DP4G,A5407692.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DA540769.A977* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$/tstTut02/
$=/tstTut03Src/
$#@
$=subsys=DP4G
$@:¢table
db ts
DGDB9998 A976
DA540769 A977
$!
$** $| call fTabAuto
$** $#end
$|
$=jx=0
$@forWith o $@=¢
$=jx=- $jx+1
//A540769$jx JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//C$ts EXEC PGM=DSNUTILB,
// PARM='$subsys,A540769$jx.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=$subsys.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE $db.$ts* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$!
$#out original/src
$/tstTut03Src/
$=/tstTut03/
### start tst tstTut03 ############################################
compile , 31 lines: $#@
run without input
//A5407691 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA976 EXEC PGM=DSNUTILB,
// PARM='DP4G,A5407691.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DGDB9998.A976* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
//A5407692 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA977 EXEC PGM=DSNUTILB,
// PARM='DP4G,A5407692.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DA540769.A977* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$/tstTut03/
$=/tstTut04Src/
$#@
$=subsys=DP4G
$=db=DA540769
call sqlConnect $subsys
$@=¢ select dbName db , tsName ts
from sysibm.sysTables
where creator = 'SYSIBM' and name like 'SYSINDEXPAR%'
order by name desc
$!
$| call sqlSel
$** $| call fTabAuto
$** $#end
$|
$=jx=0
$@forWith o $@=¢
$=jx=- $jx+1
//A540769$jx JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//C$TS EXEC PGM=DSNUTILB,
// PARM='$subsys,A540769$jx.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=$subsys.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE $DB.$TS* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$!
call sqlDisConnect
$#out original/src
$/tstTut04Src/
$=/tstTut04/
### start tst tstTut04 ############################################
compile , 35 lines: $#@
run without input
//A5407691 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CSYSHIST EXEC PGM=DSNUTILB,
// PARM='DP4G,A5407691.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DSNDB06 .SYSHIST * PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
//A5407692 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CSYSTSIPT EXEC PGM=DSNUTILB,
// PARM='DP4G,A5407692.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DSNDB06 .SYSTSIPT* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$/tstTut04/
$=/tstTut05Src/
$#:
subsys = DP4G
lst =<:¢withNew out :¢
db = DGDB9998
ts =<:¢table
ts
A976
A977
$!
db = DA540769
<|/ts/
ts
A976
A975
/ts/
!
$** $$. $lst
$** $@ct $@¢$=tool =. $.compile@ $<~.wk.rexx(wshtut06)$!
$** $@$tool
$@do sx=1 to ${lst.0} $@¢
$=db = ${lst.$sx.db}
$** $$. ${lst.$sx}
$@do tx=1 to ${lst.$sx.ts.0} $@=¢
$*+ $$. ${lst.$sx.ts.$tx}
$=ts= ${lst.$sx.ts.$tx.ts}
$@¢ say $-=¢subsys $subsys db $db ts $ts $! $!
$@copy()
$!
$!
$@ct $@¢
cl = classNew('n? DbTsList u s' ,
classNew('n? DbTs u f db v, f ts s' ,
classNew('n? Ts u f ts v')))
$=lst=. oNew(cl)
$!
$@proc copy $@=¢
$@ct $=jx=0
$=jx=- $jx+1
//A540769$jx JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//C$ts EXEC PGM=DSNUTILB,
// PARM='$subsys,A540769$jx.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=$subsys.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE $db.$ts* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$!
$#out original/src
$/tstTut05Src/
$=/tstTut05/
### start tst tstTut05 ############################################
compile , 56 lines: $#@
run without input
//A5407691 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA976 EXEC PGM=DSNUTILB,
// PARM='DP4G,A5407691.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DGDB9998.A976* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
//A5407692 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA977 EXEC PGM=DSNUTILB,
// PARM='DP4G,A5407692.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DGDB9998.A977* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
//A5407693 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA976 EXEC PGM=DSNUTILB,
// PARM='DP4G,A5407693.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DA540769.A976* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
//A5407694 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA975 EXEC PGM=DSNUTILB,
// PARM='DP4G,A5407694.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DA540769.A975* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$/tstTut05/
tstTut06 ==> platz für copy aus tut05
$=/tstTut07Src/
$**$>.fEdit()
call sqlConnect dp4g
$@:¢table
ts
VTCASHFLOW
VTCASHFLOWAMOUNT
VTINSTRFLATDATA
$!
$| $@=¢
select name, statstime, strip(dbName) || '.' || strip(tsName) dbts
from sysibm.sysTables
where creator = 'VDPS2' and name in
$=co=(
$@forWith t $@=¢
$co '$ts'
$=co=,
$!
)
$!
$| call sqlSel
$** $| call fTabAuto
$|
$=jx=0
$@forWith t $@=¢
$=jx=- $jx+1
//A540769$jx JOB (CP00,KE50),
// 'CATALOG',MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//STEP$jx EXEC PGM=DSNUTILB,TIME=1440,
// PARM=(DP4G,'A540769$jx.RUNSTA'),
// REGION=0M
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSOUT DD SYSOUT=*
//RNPRIN01 DD SYSOUT=*
//SYSIN DD *
LISTDEF LST#STA INCLUDE TABLESPACE $DBTS
OPTIONS EVENT (ITEMERROR, SKIP)
RUNSTATS TABLESPACE LIST LST#STA
SHRLEVEL CHANGE
INDEX(ALL KEYCARD)
REPORT YES UPDATE ALL
$!
call sqlDisconnect
$#out original/src
$/tstTut07Src/
$=/tstTut07/
$=/tstTut07/
### start tst tstTut07 ############################################
compile , 47 lines: $**$>.fEdit()
run without input
//A5407691 JOB (CP00,KE50),
// 'CATALOG',MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//STEP1 EXEC PGM=DSNUTILB,TIME=1440,
// PARM=(DP4G,'A5407691.RUNSTA'),
// REGION=0M
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSOUT DD SYSOUT=*
//RNPRIN01 DD SYSOUT=*
//SYSIN DD *
LISTDEF LST#STA INCLUDE TABLESPACE VV27A1T.VDPS329
OPTIONS EVENT (ITEMERROR, SKIP)
..
RUNSTATS TABLESPACE LIST LST#STA
SHRLEVEL CHANGE
INDEX(ALL KEYCARD)
REPORT YES UPDATE ALL
//A5407692 JOB (CP00,KE50),
// 'CATALOG',MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//STEP2 EXEC PGM=DSNUTILB,TIME=1440,
// PARM=(DP4G,'A5407692.RUNSTA'),
// REGION=0M
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSOUT DD SYSOUT=*
//RNPRIN01 DD SYSOUT=*
//SYSIN DD *
LISTDEF LST#STA INCLUDE TABLESPACE VV28A1T.VDPS390
OPTIONS EVENT (ITEMERROR, SKIP)
..
RUNSTATS TABLESPACE LIST LST#STA
SHRLEVEL CHANGE
INDEX(ALL KEYCARD)
REPORT YES UPDATE ALL
//A5407693 JOB (CP00,KE50),
// 'CATALOG',MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//STEP3 EXEC PGM=DSNUTILB,TIME=1440,
// PARM=(DP4G,'A5407693.RUNSTA'),
// REGION=0M
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSOUT DD SYSOUT=*
//RNPRIN01 DD SYSOUT=*
//SYSIN DD *
LISTDEF LST#STA INCLUDE TABLESPACE VV21A1T.VDPS004
OPTIONS EVENT (ITEMERROR, SKIP)
..
RUNSTATS TABLESPACE LIST LST#STA
SHRLEVEL CHANGE
INDEX(ALL KEYCARD)
REPORT YES UPDATE ALL
$/tstTut07/
$=/tstTut08Src/
$/tstTut08Src/
$=/tstTut08/
$/tstTut08/
*/
call sqlIni
call sqlDisconnect '*'
call tstComp2 'tstTut01'
call tstComp2 'tstTut02'
call tstComp2 'tstTut03'
if m.err.os == 'TSO' then do
call tstComp2 'tstTut04'
/* call tstComp2 'tstTut05' */
/* call tstComp2 'tstTut07' ???? anderes Beispiel ???? */
end
call tstTotal
return
endProcedure tstTut0
/****** tstBase ********************************************************
test the basic classes
***********************************************************************/
tstBase: procedure expose m.
call tstTstSay
call tstM
call tstUtc2d
call tstMap
call tstMapVia
call tstClass
call tstClass2
call tstClass3
call tstClass4
call tstO
call classIni
call tstF
call tstFWords
call tstFtst
call tstFCat
call tstOEins
call tstO2Text
call jIni
call tstJSay
call tstJ
call tstJ2
call tstScanSqlStmt
call catIni
call tstCat
call pipeIni
CALL TstEnv
CALL TstEnvCat
call tstPipe
call tstPipeS
call tstEnvVars
call tstvWith
call tstTotal
call tstPipeLazy
call tstEnvClass
call tstDsn
if m.tst_csmRZ \== '' then
call tstDsnEx
call tstFile
call tstFileList
call tstMbrList
call tstFE
call tstFTab
call tstFmt
call tstfUnits
call tstCsv
call tstCsv2
call tstCsvExt
call tstTotal
call tstSb
call tstSb2
call tstScan
call ScanReadIni
call tstScanRead
call tstScanUtilInto
call tstScanWin
call tstScanSQL
call tstTotal
return
endProcedure tstBase
/*--- test the tst Module, check the output visually ----------------*/
tstTstSay: procedure expose m.
call tstIni
oldErr = m.tst.err
oldNames = m.tst.errNames
say '+++ tstTstSay start with' oldErr 'totErrs and',
m.tst.tests 'tests'
/*
$=/tstTstSayEins/
### start tst tstTstSayEins #######################################
test eins einzige testZeile
$/tstTstSayEins/
$=/tstTstSayZwei/
### start tst tstTstSayZwei #######################################
zwei 1. testZeile
zwei 2. und letzte testZeile
$/tstTstSayZwei/
$=/tstTstSayDrei/
### start tst tstTstSayDrei #######################################
drei 1. testZeile vor empty Zeile
..
drei 3. testZeile vor 10 space
. .
drei 5. testZeile ziemlich lang 66 +
. 77 5 10 15++++++++++++++++++++
.+++++++++++++++++++++++++++++++++++++++++++.
$/tstTstSayDrei/
*/
call tst x, 'tstTstSayEins'
call tstOut x, "test eins einzige testZeile"
call tstEnd x, 'err 0'
call tst x, 'tstTstSayZwei'
call tstOut x, "zwei 1. testZeile"
call tstOut x, "zwei 2. und letzte testZeile"
call tstEnd x, 'err 0'
call tst x, 'tstTstSayZwei'
call tstOut x, "zwei 1. testZeile " /* ein space zuviel */
call tstOut x, "zwei 2. und letzte testZeile"
call tstOut x, "zwei 3. zuviel"
call tstEnd x, 'err 3'
call tst y, 'tstTstSayDrei'
call tstOut y, 'drei 1. testZeile vor empty Zeile'
call tstOut y, ''
call tstOut y, 'drei 3. testZeile vor 10 space'
call tstOut y, left('', 10)
call tstOut y, 'drei 5. testZeile ziemlich lang',
left(66, 66) left('77 5 10 15', 77, '+')
call tstEnd y, 'err 0'
if m.y.err <> 0 then
call err '+++ tstTstSay errs' m.x.err 'expected' 0
if m.tst.err <> oldErr + 3 then
call err '+++ tstTstSay totErrs' m.tst.err 'expected' 3
say '+++ tstTstSay end Ok with' m.tst.err 'totErrs and' ,
m.tst.tests 'tests'
m.tst.err = oldErr
m.tst.errNames = oldNames
return
endProcedure tstTstSay
tstMark: procedure expose m.
parse arg m, msg
if symbol('m.m') == 'VAR' then
m.m = msg';' m.m
else
m.m = msg 'new'
return m
endProcedure tstMark
tstM: procedure expose m.
/*
$=/tstMa/
### start tst tstMa ###############################################
mNew() 1=newM1 2=newM2
mNew(tst...) 2=2 new 3=4; 3; 1 new 4=5 new
iter 4; 3; 1 new
iter 2 new
iter 5 new
$/tstMa/
*/
call tst t, 'tstMa'
m1 = mNew()
m2 = mNew()
m.m1 = 'newM1'
m.m2 = 'newM2'
call tstOut t, 'mNew() 1='m.m1 '2='m.m2
call mNewArea 'tst'm1
t1 = tstMark(mNew('tst'm1), '1')
t2 = tstMark(mNew('tst'm1), '2')
call mFree tstMark(t1, '3')
t3 = tstMark(mNew('tst'm1), '4')
t4 = tstMark(mNew('tst'm1), '5')
call tstOut t, 'mNew(tst...) 2='m.t2 '3='m.t3 '4='m.t4
i = mIterBegin('tst'm1)
do while assNN('i', mIter(i))
call tstOut t, 'iter' m.i
end
call tstEnd t
/*
$=/tstM/
### start tst tstM ################################################
symbol m.b LIT
symbol m.a LIT
mAdd a A.2
mAdd a A.3
m.a: 3: 1=eins 2=zwei 3=drei 4=M.A.4
m.c: 5: 1=c vorAddSt a 2=eins 3=zwei 4=drei 5=c nacAddSt a 6=M.C.6
$/tstM/ */
drop m.b m.a m.a.0 m.a.1 m.a.2
call tst t, 'tstM'
call tstOut t, 'symbol m.b' symbol('m.b')
m.b = 1
call tstOut t, 'symbol m.a' symbol('m.a')
call tstOut t, 'mAdd a' mAdd(mCut(a, 0), 'eins', 'zwei')
call tstOut t, 'mAdd a' mAdd(a, 'drei')
call tstOut t, 'm.a:' m.a.0': 1='m.a.1 '2='m.a.2 '3='m.a.3 '4='m.a.4
call mAdd mCut(c, 0), 'c vorAddSt a'
call mAddSt c, a
call mAdd c, 'c nacAddSt a'
call tstOut t, 'm.c:' m.c.0': 1='m.c.1 '2='m.c.2 '3='m.c.3,
'4='m.c.4 '5='m.c.5 '6='m.c.6
call tstEnd t
return
endProcedure tstM
tstFCat: procedure expose m.
/*
$=/tstFCat/
### start tst tstFCat #############################################
fCat( ,0) =;
fCat(1 ,0) =;
fCat(112222 ,0) =;
fCat(3%#a1%c2 ,0) =;
fCat(4%#a1%c2@%c333 ,0) =;
fCat(5%#a1%c2@%c3@%c4 ,0) =;
fCat( ,1) =eins;
fCat(1 ,1) =eins;
fCat(112222 ,1) =eins;
fCat(3%#a1%c2 ,1) =1eins2;
fCat(4%#a1%c2@%c333 ,1) =1eins2eins333;
fCat(5%#a1%c2@%c3@%c4 ,1) =1eins2eins3eins4;
fCat( ,2) =einszwei;
fCat(1 ,2) =eins1zwei;
fCat(112222 ,2) =eins112222zwei;
fCat(3%#a1%c2 ,2) =1eins231zwei2;
fCat(4%#a1%c2@%c333 ,2) =1eins2eins33341zwei2zwei333;
fCat(5%#a1%c2@%c3@%c4 ,2) =1eins2eins3eins451zwei2zwei3zwei4;
fCat( ,3) =einszweidrei;
fCat(1 ,3) =eins1zwei1drei;
fCat(112222 ,3) =eins112222zwei112222drei;
fCat(3%#a1%c2 ,3) =1eins231zwei231drei2;
fCat(4%#a1%c2@%c333 ,3) =1eins2eins33341zwei2zwei33341drei2dr+
ei333;
fCat(5%#a1%c2@%c3@%c4 ,3) =1eins2eins3eins451zwei2zwei3zwei451d+
rei2drei3drei4;
$/tstFCat/ */
call pipeIni
call tst t, "tstFCat"
m.qq.1 = "eins"
m.qq.2 = "zwei"
m.qq.3 = "drei"
do qx = 0 to 3
m.qq.0 = qx
call tstFCat1 qx
call tstFCat1 qx, '1'
call tstFCat1 qx, '112222'
call tstFCat1 qx, '3%#a1%c2'
call tstFCat1 qx, '4%#a1%c2@%c333'
call tstFCat1 qx, '5%#a1%c2@%c3@%c4'
end
call tstEnd t
return
endProcedure tstFCat
tstFCat1: procedure expose m.
parse arg m.qq.0, fmt
call out left("fCat("fmt, 26)","m.qq.0") ="fCat(fmt, qq)";"
return
endProcedure tstFCat1
tstMap: procedure expose m.
/*
$=/tstMap/
### start tst tstMap ##############################################
mapNew m keys m-keys 0
map m zwei --> 2
map m Zwei is not defined
map stem m-keys 4
map m eins --> 1
map m zwei --> 2
map m drei --> 3
map m vier --> 4
*** err: duplicate in mapAdd(m, eins, 1)
map m zwei is not defined
q 2 zw dr
map stem Q 2
map Q zw --> 2Q
map Q dr --> 3Q
map stem m 3
map m eins --> 1
map m zwei --> 2PUT
map m vier --> 4PUT
*** err: duplicate in mapAdd(m, zwei, 2ADDDUP)
tstMapLong eins keys 3
tstMapLong zweiMal keys 48
tstMapLong dreiMal keys 93
tstMapLong vier keys 138
tstMapLong <fuenf> keys 188
tstMap clear keys 0
inline1 3
inline1 1 == inline1 eins==
inline1 2 ====
inline1 3 == inline1 drei==
inline2 1 1 == inline2 eins==
inline3 ?
$/tstMap/ */
/*
$=/tstMapInline1/
inline1 eins
inline1 drei
$/tstMapInline1/ */
/*
$=/tstMapInline2/
inline2 eins
$/tstMapInline2/ */
call tst t, 'tstMap'
m = mapNew('K')
ky = mapKeys(m)
call mAdd t'.TRANS', m 'm', ky 'm-keys'
call tstOut t, 'mapNew' m 'keys' ky m.ky.0
call mapAdd m, 'eins', 1
call mapAdd m, 'zwei', 2
call mapAdd m, 'drei', 3
call mapAdd m, 'vier', 4
call tstMapShow m, 'zwei'
call tstMapShow m, 'Zwei'
call tstMapShowSt m, mapKeys(m)
call mapAdd m, 'eins', 1
call mapReset m, '='
call tstMapShow m, 'zwei'
call mapAdd m, 'eins', 1
call mapAdd m, 'zwei', 2
call mapPut m, 'zwei', 2Put
call mapPut m, 'vier', 4Put
call mapReset q, '='
call mapAdd q, 'zw', 2q
call mapAdd q, 'dr', 3q
call tstOut t, 'q' m.q.0 m.q.1 m.q.2
call tstMapShowSt q, mapKeys(q)
call tstMapShowSt m, mapKeys(m)
call mapAdd m, 'zwei', 2addDup
call tstMapLong m, 'eins' ,201, 2000, -2, 2
call tstMapLong m, 'zweiMal' ,201, 2000, -2, 2
call tstMapLong m, 'dreiMal' ,201, 2000, 2,-2
call tstMapLong m, 'vier ' ,2010, 201, -2, 2
call tstMapLong m, '<fuenf>' ,2010, 201, 2,-2
call mapClear m
keys = mapKeys(m)
call tstOut t, 'tstMap clear keys' m.keys.0
i = mapInline('tstMapInline1')
call tstOut t, 'inline1' m.i.0
do x=1 to m.i.0
call tstOut t, 'inline1' x '=='m.i.x'=='
end
i = mapInline('tstMapInline2')
call tstOut t, 'inline2' m.i.0 '1 =='m.i.1'=='
call tstOut t, 'inline3' mapInline('tstMapInline3', 'r')'?'
call tstEnd t
return
endProcedure tstMap
tstMapLong: procedure expose m.
parse arg m, w, f1, t1, f2, t2
if f1 < t1 then
b1 = 201
else
b1 = -201
if f2 < t2 then
b2 = 1
else
b2 = -1
lo = copies(w, 2100 % length(w))
keys = mapKeys(m)
keyCn = m.keys.0
call tstOut t, 'tstMapLong' w 'keys' keyCn
do x = f1 by b1 to t1
do y = x+f2 by b2 to x+t2
k = left(lo, y)
if mapHasKey(m, k) then
call err 'mapLong hasKey before' w y
call mapAdd m, k, w y
if \ mapHasKey(m, k) then
call err 'mapLong \ hasKey after' w y
if mapGet(m, k) \== w y then
call err 'mapLong \ get <> ' w y
keys = mapKeys(m)
if keyCn + 1 \= m.keys.0 then
call err 'mapLong keys .0 <> ' w y
keyCn = m.keys.0
if k \== m.keys.keyCn then
call err 'mapLong keys . ' keyCn '<>' w y
end
end
return
endProcedure tstMapLong
tstMapVia: procedure expose m.
/*
$=/tstMapVia/
### start tst tstMapVia ###########################################
map M K --> A
mapVia(m, K) A
*** err: missing m.A at 3 in mapVia(M, K|)
mapVia(m, K|) M.A
mapVia(m, K|) valAt m.a
mapVia(m, K|) valAt m.a
*** err: missing m.A.aB at 5 in mapVia(M, K|aB)
mapVia(m, K|aB) M.A.aB
mapVia(m, K|aB) valAt m.A.aB
*** err: missing m.valAt m.a at 4 in mapVia(M, K||)
mapVia(m, K||) M.valAt m.a
mapVia(m, K||) valAt m.valAt m.a
mapVia(m, K||F) valAt m.valAt m.a.F
$/tstMapVia/ */
call tst t, 'tstMapVia'
u = 'A.aB'
v = 'valAt m.a'
drop m.a m.u m.v m.v.f
call mapReset m, 'K'
call mapAdd m, k, a
call tstMapShow m, k
call tstOut t, 'mapVia(m, K) ' mapVia(m, 'K')
call tstOut t, 'mapVia(m, K|) ' mapVia(m, 'K|')
m.a = v
call tstOut t, 'mapVia(m, K|) ' mapVia(m, 'K|')
call tstOut t, 'mapVia(m, K|) ' mapVia(m, 'K|')
call tstOut t, 'mapVia(m, K|aB) ' mapVia(m, 'K|aB')
m.u = 'valAt m.'u
call tstOut t, 'mapVia(m, K|aB) ' mapVia(m, 'K|aB')
call tstOut t, 'mapVia(m, K||) ' mapVia(m, 'K||')
v = m.a
m.v = 'valAt m.'v
m.v.f = 'valAt m.'v'.F'
call tstOut t, 'mapVia(m, K||) ' mapVia(m, 'K||')
call tstOut t, 'mapVia(m, K||F) ' mapVia(m, 'K||F')
call tstEnd t
return
endProcedure tstMapVia
tstMapShow: procedure expose m.
parse arg a, key
if mapHasKey(a, key) then
call tstOut t, 'map' a key '-->' mapGet(a, key)
else
call tstOut t, 'map' a key 'is not defined'
return
endProcedure tstMapShow
tstMapShowSt: procedure expose m.
parse arg a, st
call tstOut t, 'map stem' st m.st.0
do wx=1 to m.st.0
call tstMapShow a, m.st.wx
end
return
endProcedure tstMapShow
tstClass2: procedure expose m.
/*
$=/tstClass2/
### start tst tstClass2 ###########################################
@CLASS.9 :class = u
. choice u union
. .NAME = class
. stem 8
. .1 refTo @CLASS.3 :class = u
. choice u union
. .NAME = v
. stem 2
. .1 refTo @CLASS.1 :class = m
. choice m union
. .NAME = o2String
. .MET = return m.m
. stem 0
. .2 refTo @CLASS.2 :class = m
. choice m union
. .NAME = o2File
. .MET = return file(m.m)
. stem 0
. .2 refTo @CLASS.12 :class = c
. choice c union
. .NAME = u
. stem 1
. .1 refTo @CLASS.11 :class = u
. choice u union
. .NAME = .
. stem 1
. .1 refTo @CLASS.10 :class = f
. choice f union
. .NAME = NAME
. stem 1
. .1 refTo @CLASS.3 done :class @CLASS.3
. .3 refTo @CLASS.13 :class = c
. choice c union
. .NAME = f
. stem 1
. .1 refTo @CLASS.11 done :class @CLASS.11
. .4 refTo @CLASS.15 :class = c
. choice c union
. .NAME = s
. stem 1
. .1 refTo @CLASS.14 :class = u
. choice u union
. .NAME = .
. stem 0
. .5 refTo @CLASS.16 :class = c
. choice c union
. .NAME = c
. stem 1
. .1 refTo @CLASS.11 done :class @CLASS.11
. .6 refTo @CLASS.17 :class = c
. choice c union
. .NAME = r
. stem 1
. .1 refTo @CLASS.14 done :class @CLASS.14
. .7 refTo @CLASS.20 :class = c
. choice c union
. .NAME = m
. stem 1
. .1 refTo @CLASS.19 :class = u
. choice u union
. .NAME = .
. stem 2
. .1 refTo @CLASS.10 done :class @CLASS.10
. .2 refTo @CLASS.18 :class = f
. choice f union
. .NAME = MET
. stem 1
. .1 refTo @CLASS.3 done :class @CLASS.3
. .8 refTo @CLASS.22 :class = s
. choice s union
. stem 1
. .1 refTo @CLASS.21 :class = r
. choice r union
. stem 1
. .1 refTo @CLASS.9 done :class @CLASS.9
$/tstClass2/
*/
call classIni
call tst t, 'tstClass2'
call classOut m.class_C, m.class_C
call tstEnd t
return
endProcedure tstClass2
tstClass3: procedure expose m.
/*
$=/tstClass3/
### start tst tstClass3 ###########################################
met v#o2String return m.m
met w#o2String return substr(m, 2)
met w#o2String return substr(m, 2)
*** err: no method nonono in class w
met w#nonono 0
t1 4 fldD .FV, .FR
clear q1 FV= FR= FW= FO=
orig R1 FV=valFV FR=refFR FW=!valFW FO=obj.FO
copy <s1> FV=valFV FR=refFR FW=!valFW FO=obj.FO
t2 2 fldD .EINS.ZWEI, .
clear q2 EINS.ZWEI= val=
orig R2 EINS.ZWEI=valR2.eins.zwei val=valR2Self
copy <s2> EINS.ZWEI=valR2.eins.zwei val=valR2Self
t3 0 fldD M.<class tst...Tf33>.FLDD.1, M.<class tst...Tf33>.FLDD.2
clear q3 s1.0=0
orig R3 s1.0=1 s1.1=M.R3.S1.1 s1.1.f1=M.R3.S1.1.F1 s1.1.s2.0=2 s1.1+
..s2.1.f2=M.R3.S1.1.S2.1.F2 s1.1.s2.2.f2=M.R3.S1.1.S2.2.F2
copy <s3> s1.0=1 s1.1=M.R3.S1.1 s1.1.f1=M.R3.S1.1.F1 s1.1.s2.0=2 s1+
..1.s2.1.f2=M.R3.S1.1.S2.1.F2 s1.1.s2.2.f2=M.R3.S1.1.S2.2.F2
$/tstClass3/ */
call classIni
call tst t, 'tstClass3'
call mAdd t.trans, m.class_C '<class class>'
call tstOut t, 'met v#o2String' classMet(m.class_V, 'o2String')
call tstOut t, 'met w#o2String' classMet(m.class_W, 'o2String')
call tstOut t, 'met w#o2String' classMet(m.class_W, 'o2String')
call tstOut t, 'met w#nonono' classMet(m.class_W, 'nonono')
all = classNew('n? tstClassTf31 u f FV v, f FR r, f FW w, f FO o'),
classNew('n? tstClassTf32 u f EINS f ZWEI v, v') ,
classNew('n? tstClassTf33 u f S1' classNew('s u v, f F1 v,',
'f S2 s f F2 v'))
call mAdd t.trans, word(all, 3) '<class tst...Tf33>'
m.r1.fv = 'valFV'
m.r1.fr = 'refFR'
m.r1.fw = '!valFW'
m.r1.fo = 'obj.FO'
m.r2 = 'valR2Self'
m.r2.eins.zwei = 'valR2.eins.zwei'
m.r3.s1.0 = 1
m.r3.s1.1.s2.0 = 2
o.1 = "q 'FV='m.q.FV 'FR='m.q.fr 'FW='m.q.fw 'FO='m.q.fo"
o.2 = "q 'EINS.ZWEI='m.q.EINS.zwei 'val='m.q"
o.3 = "q 's1.0='m.q.s1.0"
p.1 = o.1
p.2 = o.2
p.3 = "q 's1.0='m.q.s1.0 's1.1='m.q.s1.1 's1.1.f1='m.q.s1.1.f1" ,
"'s1.1.s2.0='m.q.s1.1.s2.0 's1.1.s2.1.f2='m.q.s1.1.s2.1.f2",
"'s1.1.s2.2.f2='m.q.s1.1.s2.2.f2"
do tx=1 to words(all)
t1 = word(all, tx)
u1 = classFldD(t1)
q = 'q'tx
call tstOut t, 't'tx m.u1.0 'fldD' m.u1.1',' m.u1.2
call utInter("m='"q"';" classMet(t1, 'oClear'))
interpret "call tstOut t, 'clear'" o.tx
q = 'R'tx
interpret "call tstOut t, 'orig'" p.tx
q = utInter("m='"q"';t='';" classMet(t1, 'oCopy'))
call mAdd t.trans, q '<s'tx'>'
interpret "call tstOut t, 'copy'" p.tx
end
call tstEnd t
return
endProcedure tstClass3
tstClass: procedure expose m.
/*
$=/tstClass/
### start tst tstClass ############################################
Q u =className= tstClassTf12
Q.eins.zwei v ==> M.Q.eins.zwei
*** err: bad type v: classNew(v tstClassTf12)
*** err: missing key in mapGet(CLASS_N2C, 0)
R u =className= uststClassTf12
R u =className= uststClassTf12in
R u =className= tstClassTf12
R.eins.zwei v ==> M.R.eins.zwei
R s =stem.0= 2
R.1 r ==> M.R.1 :CLASS.7
R.1 u =className= tstClassTf12
R.1.eins.zwei v ==> M.R.1.eins.zwei
R.2 r ==> M.R.2 :CLASS.7
R.2 u =className= tstClassTf12
R.2.eins.zwei v ==> M.R.2.eins.zwei
S u =className= TstClass7
S s =stem.0= 2
S.1 u =className= TstClass7s
S.1.eins v ==> M.S.1.eins
S.1 m =met-metA--> say "metA"
S.1 m =met-metB--> say "metB"
S.2 u =className= TstClass7s
S.2.zwei v ==> M.S.2.zwei
S.2 m =met-metA--> say "metA"
S.2 m =met-metB--> say "metB"
class of mutate qq tstClassTf12
$/tstClass/ */
f = 'eins.zwei'
e = 'eins'
z = 'zwei'
drop m.q.f m.r.f m.r.0 m.r.1 m.r.1.f m.r.2 m.r.2.f
drop m.s.0 m.s.1 m.s.1.e m.s.2 m.s.2.z
call classIni
call tst t, 'tstClass'
t1 = classNew('n? tstClassTf12 u f eins f zwei v')
call tstClassOut t, t1, q
z = m.class.0
if class4name('tstClassB', '') == '' then do
t2 = classNew('n tstClassB u n tstClassC u tstClassTf12,',
's u v tstClassTf12')
end
else do /* the second time we would get a duplicate error */
call tstOut t, '*** err: bad type v: classNew(v tstClassTf12)'
call tstOut t, '*** err: missing key in mapGet(CLASS_N2C, 0)'
end
t2 = classNew('n? uststClassTf12 u' ,
'n? uststClassTf12in u tstClassTf12',
, classNew('s u r, tstClassTf12'))
m.r.0 = 2
call tstClassOut t, t2, r
t3 = classNew('n? TstClass7 u s',
classNew('n? TstClass7s u c 1 f eins v, c 2 f zwei v',
,'m', 'metA say "metA"', 'metB say "metB"'))
m.s.0 = 2
m.s.1 = 1
m.s.2 = 2
call tstClassOut t, t3, s
call oMutatName qq, 'tstClassTf12'
tt = objClass(qq)
call tstOut t, 'class of mutate qq' className(tt)
call tstEnd t
return
endProcedure tstClass
tstClassOut: procedure expose m.
parse arg o, t, a
if wordPos(t, m.class_V m.class_W m.class_O) > 0 then
return tstOut(o, a m.t.name '==>' m.a)
if m.t == 'r' then
return tstOut(o, a m.t '==>' m.a ':'if(m.t.0==0,'',m.t.1))
if m.t == 'u' & m.t.name \== '' then
call tstOut o, a m.t '=className=' m.t.name
if m.t == 'f' then
return tstClassOut(o, m.t.1, a'.'m.t.name)
if m.t = 'u' then do
do ux=1 to m.t.0
call tstClassOut o, m.t.ux, a
end
return 0
end
if m.t = 's' then do
call tstOut o, a m.t '=stem.0=' m.a.0
do ux=1 to m.a.0
call tstClassOut o, m.t.1, a'.'ux
end
return 0
end
if m.t = 'c' then do
if m.t.name = m.a then
call tstClassOut o, m.t.1, a
return 0
end
if m.t = 'm' then
return tstOut(o, a m.t '=met-'m.t.name'-->' m.t.met)
call err 'bad class type' m.t
endProcedure tstClassOut
tstClass4: procedure expose m.
parse arg
/*
$=/tstClass4/
### start tst tstClass4 ###########################################
f 1 eins
f 2 zwei
f 3 drei
f 4 vier
f 5 acht
s 1 fuenf
s 2 sechs
s 3 sie
$/tstClass4/
*/
call classIni
call tst t, 'tstClass4'
x = classNew('n* TstClass4a u f eins v, f%v zwei drei, f vier v',
', f%s-v fuenf sechs sie, f acht v')
ff = classFlds(x)
do fx=1 to m.ff.0
call tstOut t, 'f' fx m.ff.fx
end
st = classMet(x, 'stms')
do sx=1 to m.st.0
call tstOut t, 's' sx m.st.sx
end
call tstEnd t
return
endProcedure tstClass4
tstO: procedure expose m.
/*
$=/tstO/
### start tst tstO ################################################
o1.class <class_S>
o1.class <class T..1>
o1#met1 metEins
o1#met2 metZwei
o1#new m = mNew('<class T..1>'); call oMutate m, '<class T..1>'; ca+
ll classClear '<class T..1>', m;
$/tstO/
*/
call mIni
call tst t, 'tstO'
call classIni
call mAdd t.trans, m.class_s '<class_S>'
c1 = classNew('n? TstOCla1 u', 'm', 'met1 metEins', 'met2 metZwei')
call mAdd t.trans, c1 '<class T..1>'
o1 = 'tst_o1'
call tstOut t, 'o1.class' objClass(o1)
o1 = oMutate('o1', c1)
call tstOut t, 'o1.class' objClass(o1)
call tstOut t, 'o1#met1' objMet(o1, 'met1')
call tstOut t, 'o1#met2' objMet(o1, 'met2')
call tstOut t, 'o1#new' objMet(o1, 'new')
call tstEnd t
return
endProcedure tstO
tstOEins: procedure expose m.
/*
$=/tstOEins/
### start tst tstOEins ############################################
class method calls of TstOEins
. met Eins.eins M
flds of <obj e of TstOEins> FEINS, FZWEI
methodcalls of object e of TstOEins
. met Eins.eins <obj e of TstOEins>
. met Eins.zwei <obj e2 of TstOEins>
*** err: no method nein in class TstOEins
*** err: no method nein in class String
class method calls of TstOEins
. met Elf.zwei M
flds of <obj f of TstOElf> FEINS, FZWEI, FELF
methodcalls of object f of TstOElf
. met Eins.eins <obj f of TstOElf>
. met Elf.zwei <obj f of TstOElf>
. met Elf.drei <obj f of TstOElf>
oCopy c1 of class TstOEins, c2
C1 u =className= TstOEins
C1.FEINS v ==> M.C1.FEINS
C1.FZWEI v ==> M.C1.FZWEI
C1 m =met-eins--> call tstOut t, " met Eins.eins" m
C1 m =met-zwei--> call tstOut t, " met Eins.zwei" m
C2 u =className= TstOEins
C2.FEINS v ==> M.C1.FEINS
C2.FZWEI v ==> M.C1.FZWEI
C2 m =met-eins--> call tstOut t, " met Eins.eins" m
C2 m =met-zwei--> call tstOut t, " met Eins.zwei" m
oCopy c3 of class TstOElf, c4
C4 u =className= TstOElf
C4 u =className= TstOEins
C4.FEINS v ==> M.C3.FEINS
C4.FZWEI v ==> M.C3.FZWEI
C4 m =met-eins--> call tstOut t, " met Eins.eins" m
C4 m =met-zwei--> call tstOut t, " met Eins.zwei" m
C4.FELF r ==> M.C3.FELF :<class O>
C4 m =met-zwei--> call tstOut t, " met Elf.zwei" m
C4 m =met-drei--> call tstOut t, " met Elf.drei" m
tEinsDop <class TstOEins>
oRun 7*3 21
oRun 12*12 144
$/tstOEins/ */
call classIni
call tst t, 'tstOEins'
tEins = classNew('n? TstOEins u f FEINS v,f FZWEI v', 'm',
, 'eins call tstOut t, " met Eins.eins" m',
, 'zwei call tstOut t, " met Eins.zwei" m')
call mAdd t.trans, tEins '<class TstOEins>' ,
, m.class_o '<class O>'
call tstOut t, 'class method calls of TstOEins'
interpret classMet('TstOEins', 'eins')
e = oNew('TstOEins')
e2 = oNew('TstOEins')
call mAdd t.trans, e '<obj e of TstOEins>'
call mAdd t.trans, e2 '<obj e2 of TstOEins>'
call tstOut t, 'flds of' e mCat(oFlds(e), ', ')
call tstOut t, 'methodcalls of object e of TstOEins'
call tstOmet e, 'eins'
call tstOmet e2, 'zwei'
call tstOmet e, 'nein'
call tstOmet 'noObj', 'nein'
tElf = classNew('n? TstOElf u TstOEins, f FELF r', 'm',
, 'zwei call tstOut t, " met Elf.zwei" m',
, 'drei call tstOut t, " met Elf.drei" m')
call tstOut t, 'class method calls of TstOEins'
interpret classMet('TstOElf', 'zwei')
f = oNew('TstOElf')
call mAdd t.trans, f '<obj f of TstOElf>'
call tstOut t, 'flds of' f mCat(oFlds(f), ', ')
call tstOut t, 'methodcalls of object f of TstOElf'
call tstOmet f, 'eins'
call tstOmet f, 'zwei'
call tstOmet f, 'drei'
call oMutatName c1, 'TstOEins'
call tstOut t, 'oCopy c1 of class TstOEins, c2'
call tstClassOut t, tEins, c1
call oCopy c1, c2
call tstClassOut t, tEins, c2
call tstOut t, 'oCopy c3 of class TstOElf, c4'
call oMutatName c3, 'TstOElf'
call oCopy c3, c4
call tstClassOut t, tElf, c4
/* tEinsDop = classNew('n TstOEins u f FEINS v,f FZWEI v', 'm',
, 'eins call tstOut t, " met Eins.eins" m',
, 'zwei call tstOut t, " met Eins.zwei" m')
*/ tEinsDop = tEins
call tstOut t, 'tEinsDop' tEinsDop
e3 = oNew('TstOEins')
if e3 <<= e | e3 <<= e2 then
call err 'doppelt reinitialised objects'
rr = oRunner('return 7 * 3')
call tstOut t, 'oRun 7*3' oRun(rr)
r12 = oRunner('return 12 * 12')
call tstOut t, 'oRun 12*12' oRun(r12)
call tstEnd t
return
endProcedure tstOEins
tstOmet: procedure expose m.
parse arg m, met
interpret objMet(m, met)
return
endProcedure tstOmet
tstO2Text: procedure expose m.
/*
$=/o2Text/
### start tst o2Text ##############################################
. > .
und _s abc > und so
und _s lang > und so und so und so und so und so und so und so und+
. so und so ....
!und _w abc > und so
o1 > tstO2T1=¢fEins=v_o1_fEins fZwei=v_o1_fZwei fDrei=v_o+
1_fDrei!
o1 lang > tstO2T1=¢fEins=v_o1_fEins fZwei=v_o1_fZweiv_o1_fZwei+
v_o1_fZwei...!
runner > <tstRunObj>=¢<tstRunCla>!
file > <tstFileObj>=¢File!
$/o2Text/
*/
call catIni
cl = classNew('n* TstO2Text1 u f fEins v, f fZwei v, f fDrei v')
o1 = 'tstO2T1'
call oMutate o1, cl
call mPut o1'.fEins', 'v_o1_fEins'
call mPut o1'.fZwei', 'v_o1_fZwei'
call mPut o1'.fDrei', 'v_o1_fDrei'
call tst t, 'o2Text'
maxL = 66
call tstOut t, ' >' o2Text(' ', maxL)
call tstOut t, 'und _s abc >' o2Text('und so ', maxL)
call tstOut t, 'und _s lang >' o2Text(copies('und so ',33), maxL)
call tstOut t, '!und _w abc >' o2Text('und so ', maxL)
call tstOut t, 'o1 >' o2Text(o1 , maxL)
call mPut o1'.fZwei', copies('v_o1_fZwei',33)
call tstOut t, 'o1 lang >' o2Text(o1 , maxL)
f = file('abc.efg')
r = oRunner('say o2Text test')
call mAdd t.trans, r '<tstRunObj>',
, className(objClass(r)) '<tstRunCla>' ,
, f '<tstFileObj>'
call tstOut t, 'runner >' o2Text(r , maxL)
call tstOut t, 'file >' o2Text(f , maxL)
call mAdd t.trans, r '<tstRunnerObj>',
, className(objClass(r)) '<tstRunnerCla>'
call tstEnd t
return
endProcedure tstO2Text
tstJSay: procedure expose m.
/*
$=/tstJSay/
### start tst tstJSay #############################################
*** err: bad option openArg in jOpen(<obj j of JRW>, openArg)
*** err: jWrite(<obj j of JRW>, writeArg) but not opened w
*** err: can only write JSay#jOpen(<obj s of JSay>, <)
*** err: jWrite(<obj s of JSay>, write s vor open) but not opened+
. w
*** err: JRWEof#open(<obj e of JRWEof>, >)
*** err: jRead(<obj e of JRWEof>) but not opened r
read e vor open 0 m.xx valueBefore
read e nach open 0 m.xx valueBefore
out eins
#jIn 1# tst in line 1 eins ,
out zwei in 1 vv=readAdrVV
#jIn 2# tst in line 2 zwei ; .
out drei in 1 vv=readAdrVV Schluss
$/tstJSay/ */
call jIni
call tst t, 'tstJSay'
jrw = oNew('JRW')
call mAdd t'.TRANS', jrw '<obj j of JRW>'
call jOpen jrw, 'openArg'
call jWrite jrw, 'writeArg'
s = oNew('JSay')
call mAdd t'.TRANS', s '<obj s of JSay>'
call jOpen s, m.j.cRead
s = oNew('JSay')
call mAdd t'.TRANS', s '<obj s of JSay>'
call jWrite s, 'write s vor open'
call jOpen s, '>'
call jWrite s, 'write s nach open'
e = oNew('JRWEof')
call mAdd t'.TRANS', e '<obj e of JRWEof>'
call jOpen e, '>'
e = oNew('JRWEof')
call mAdd t'.TRANS', e '<obj e of JRWEof>'
m.xx = 'valueBefore'
call tstOut t, 'read e vor open' jReadVar(e, xx) 'm.xx' m.xx
call jOpen e, m.j.cRead
call tstOut t, 'read e nach open' jReadVar(e, xx) 'm.xx' m.xx
call out 'out eins'
vv = 'readAdrVV'
m.vv = 'readAdrVVValueBefore'
call out 'out zwei in' in() 'vv='vv
m.vv = 'readAdrVVValueBefore'
call out 'out drei in' inVar(vv) 'vv='vv 'Schluss'
call tstEnd t
return
endProcedure tstJSay
tstJ: procedure expose m.
/*
$=/tstJ/
### start tst tstJ ################################################
out eins
#jIn 1# tst in line 1 eins ,
1 in() tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
2 in() tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
3 in() tst in line 3 drei .schluss..
#jIn eof 4#
in() 3 reads vv VV
line buf line one
line buf line two
line buf line three
line buf line four
*** err: jWrite(<buf b>, buf line five while reading) but not opene+
d w
$/tstJ/ */
call jIni
call tst t, "tstJ"
b = jOpen(jBuf(), '>')
call mAdd t'.TRANS', b '<buf b>'
call out 'out eins'
do lx=1 by 1 while in()
call out lx 'in()' m.in
end
call out 'in()' (lx-1) 'reads vv' vv
call jOpen b, '>'
call jWrite b, 'buf line one'
call jClose b
call mAdd b'.BUF', 'buf line two', 'buf line three'
call jWrite b, 'buf line four'
call jClose b
call jOpen b, m.j.cRead
do while jRead(b)
call out 'line' m.b
end
call jWrite b, 'buf line five while reading'
call jClose b
call tstEnd t
return
endProcedure tstJ
tstJ2: procedure expose m.
/*
$=/tstJ2/
### start tst tstJ2 ###############################################
class1 <Tst?1 class> <Tst?1 name>
class2 <Tst?1 class> <Tst?1 name>
class3 <Tst?1 class> <Tst?1 name>
b read EINS feld eins, ZWEI feld zwei, DREI feld drei
b read EINS feld eins, ZWEI feld zwei 2, DREI feld drei
c read EINS feld eins, ZWEI feld zwei, DREI drei cat 1
tstR: @tstWriteoV3 isA :<Tst?1 name>
tstR: .EINS = feld eins
tstR: .ZWEI = feld zwei
tstR: .DREI = drei cat 1
c read EINS feld eins, ZWEI feld zwei 2, DREI drei cat 2
tstR: @tstWriteoV4 isA :<Tst?1 name>
tstR: .EINS = feld eins
tstR: .ZWEI = feld zwei 2
tstR: .DREI = drei cat 2
$/tstJ2/ */
call jIni
call tst t, "tstJ2"
ty = classNew('n* Tst u f EINS v, f ZWEI v, f DREI v')
call mAdd t'.TRANS', ty '<Tst?1 class>'
call mAdd t'.TRANS', m.ty.name '<Tst?1 name>'
call tstOut t, 'class1' ty m.ty.name
ty = classNew('n* Tst u f EINS v, f ZWEI v, f DREI v')
call tstOut t, 'class2' ty m.ty.name
ty = classNew('n* Tst u f EINS v, f ZWEI v, f DREI v')
call tstOut t, 'class3' ty m.ty.name
call oMutate qq, ty
m.qq.eins = 'feld eins'
m.qq.zwei = 'feld zwei'
m.qq.drei = 'feld drei'
b = jBuf()
call jOpen b, '>'
call jWrite b, oCopy(qq)
m.qq.zwei = 'feld zwei 2'
call jWrite b, qq
call jOpen jClose(b), m.j.cRead
c = jOpen(jBuf(), '>')
do xx=1 while jRead(b)
res = m.b
call out 'b read EINS' m.res.eins', ZWEI' m.res.zwei,
|| ', DREI' m.res.drei
m.res.drei = 'drei cat' xx
call jWrite c, res
end
call jOpen jClose(c), m.j.cRead
do while jRead(c)
ccc = m.c
call out 'c read EINS' m.ccc.eins', ZWEI' m.ccc.zwei,
|| ', DREI' m.ccc.drei
call out ccc
end
call tstEnd t
return
endProcedure tstJ2
tstCat: procedure expose m.
/*
$=/tstCat/
### start tst tstCat ##############################################
catRead 1 line 1
catRead 2 line 2
catRead 3 line 3
appRead 1 line 1
appRead 2 line 2
appRead 3 line 3
appRead 4 append 4
appRead 5 append 5
$/tstCat/ */
call catIni
call tst t, "tstCat"
i = cat(jBuf('line 1', 'line 2'), jBuf('line 3'))
call jOpen i, m.j.cRead
do lx=1 by 1 while jRead(i)
call tstOut t, 'catRead' lx m.i
end
call jOpen jClose(i), m.j.cApp
call jWrite i, 'append 4'
call jWrite i, 'append 5'
call jOpen jClose(i), m.j.cRead
do lx=1 by 1 while jRead(i)
call tstOut t, 'appRead' lx m.i
end
call tstEnd t
return
endProcedure tstCat
tstEnv: procedure expose m.
call pipeIni
/*
$=/tstEnv/
### start tst tstEnv ##############################################
before pipeBeLa
after pipeEnd
*** err: jWrite(<jBuf c>, write nach pop) but not opened w
#jIn 1# tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
before writeNow 2 c --> std
before writeNow 1 b --> c
b line eins
b zwei |
nach writeNow 1 b --> c
add nach pop
after push c only
tst in line 1 eins ,
tst in line 2 zwei ; .
tst in line 3 drei .schluss..
nach writeNow 2 c --> std
*** err: jWrite(<jBuf c>, ) but not opened w
$/tstEnv/ */
call tst t, "tstEnv"
c = jBuf()
call mAdd t'.TRANS', c '<jBuf c>'
call out 'before pipeBeLa'
b = jBuf("b line eins", "b zwei |")
call pipe '+Ff', c, b
call out 'before writeNow 1 b --> c'
call pipeWriteNow
call out 'nach writeNow 1 b --> c'
call pipe '-'
call out 'after pipeEnd'
call jWrite c, 'write nach pop'
call mAdd c'.BUF', 'add nach pop'
call pipe '+A', c
call out 'after push c only'
call pipeWriteNow
call pipe '-'
call pipe '+f', , c
call out 'before writeNow 2 c --> std'
call pipeWriteNow
call out 'nach writeNow 2 c --> std'
call pipe '-'
call jWrite c
call tstEnd t
return
endProcedure tstEnv
tstEnvCat: procedure expose m.
call pipeIni
/*
$=/tstEnvCat/
### start tst tstEnvCat ###########################################
c1 contents
c1 line eins |
before writeNow 1 b* --> c*
b1 line eins|
b2 line eins
b2 zwei |
c2 line eins |
after writeNow 1 b* --> c*
c2 contents
c2 line eins |
$/tstEnvCat/ */
call tst t, "tstEnvCat"
b0= jBuf()
b0= jBuf()
b1= jBuf("b1 line eins|")
b2 = jBuf("b2 line eins", "b2 zwei |")
c1 = jBuf("c1 line eins |")
c2 = jBuf("c2 line eins |")
call pipe '+Affff', c1, b0, b1, b2, c2
call out 'before writeNow 1 b* --> c*'
call pipeWriteNow
call out 'after writeNow 1 b* --> c*'
call pipe '-'
call out 'c1 contents'
call pipe '+f' , , c1
call pipeWriteNow
call pipe '-'
call pipe '+f' , , c2
call out 'c2 contents'
call pipeWriteNow
call pipe '-'
call tstEnd t
return
endProcedure tstEnvCat
tstPipe: procedure expose m.
call pipeIni
/*
$=/tstPipe/
### start tst tstPipe #############################################
.+0 vor pipeBegin
#jIn 1# tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
.+7 nach pipeLast
¢7 +6 nach pipe 7!
¢7 +2 nach pipe 7!
¢7 +4 nach nested pipeLast 7!
¢7 (4 +3 nach nested pipeBegin 4) 7!
¢7 (4 (3 +1 nach pipeBegin 3) 4) 7!
¢7 (4 (3 tst in line 1 eins , 3) 4) 7!
¢7 (4 (3 tst in line 2 zwei ; 3) 4) 7!
¢7 (4 (3 tst in line 3 drei .schluss. 3) 4) 7!
¢7 (4 (3 +1 nach writeNow vor pipe 3) 4) 7!
¢7 (4 +3 nach preSuf vor nested pipeLast 4) 7!
¢7 +4 nach preSuf vor nested pipeEnd 7!
¢7 +5 nach nested pipeEnd vor pipe 7!
¢7 +6 nach writeNow vor pipeLast 7!
.+7 nach writeNow vor pipeEnd
.+8 nach pipeEnd
$/tstPipe/ */
say 'x0' m.pipe.0
call tst t, 'tstPipe'
call out '+0 vor pipeBegin'
say 'x1' m.pipe.0
call pipe '+N'
call out '+1 nach pipeBegin'
call pipeWriteNow
call out '+1 nach writeNow vor pipe'
call pipe 'N|'
call out '+2 nach pipe'
call pipe '+N'
call out '+3 nach nested pipeBegin'
call pipePreSuf '(3 ', ' 3)'
call out '+3 nach preSuf vor nested pipeLast'
call pipe 'P|'
call out '+4 nach nested pipeLast'
call pipePreSuf '(4 ', ' 4)'
call out '+4 nach preSuf vor nested pipeEnd'
call pipe '-'
call out '+5 nach nested pipeEnd vor pipe'
call pipe 'N|'
call out '+6 nach pipe'
call pipeWriteNow
say 'out +6 nach writeNow vor pipeLast'
call out '+6 nach writeNow vor pipeLast'
call pipe 'P|'
call out '+7 nach pipeLast'
call pipePreSuf '¢7 ', ' 7!'
call out '+7 nach writeNow vor pipeEnd'
call pipe '-'
call out '+8 nach pipeEnd'
say 'xx' m.pipe.0
call tstEnd t
return
endProcedure tstPipe
tstPipeS: procedure expose m.
/*
$=/tstPipeS/
### start tst tstPipeS ############################################
eine einzige zeile
nach all einzige Zeile
select strip(creator) cr, strip(name) tb,
(row_number()over())*(row_number()over()) rr
from sysibm.sysTables
$/tstPipeS/
*/
call pipeIni
call tst t, "tstPipeS"
call pipe '+s',, 'eine einzige zeile'
call pipeWriteAll
call out 'nach all einzige Zeile'
call pipe 'sss',,
, "select strip(creator) cr, strip(name) tb," ,
, "(row_number()over())*(row_number()over()) rr" ,
, "from sysibm.sysTables"
call pipeWriteAll
call pipe '-'
call tstEnd t
return
endProcedure tstPipeS
tstEnvVars: procedure expose m.
call pipeIni
/*
$=/tstEnvVars/
### start tst tstEnvVars ##########################################
put v1 value eins
v1 hasKey 1 get TST.ADR1
v2 hasKey 0
one to theBur
two to theBuf
v1=TST.ADR1 o=TST.ADR1
v3=v3WieGehts? o=v3WieGehts?
v4=!v4WieGehts? o=!v4WieGehts?
o o0=<o0>
s o0=<o0>
o o0=<o0>
s o0=<o0>
o0&fSt0=rexx o0.fSt0 o=rexx o0.fSt0
o0&fRe0=!rexx o0.fRe0 o=!rexx o0.fRe0
o0&=rexx o0-value o=rexx o0-value
o o0=<o0>
s o0=<o0>
o0&fSt0=put o0.fSt0 o=put o0.fSt0
o0&fRe0=!putO o0.fRe0 o=!putO o0.fRe0
o0&=put o0-value o=put o0-value
$/tstEnvVars/
$=/tstEnvVars1/
### start tst tstEnvVars1 #########################################
m.o1=put-o1-value m.o1.fStr=put-o1.fStr m.o1.fRef=<o0>
o o1=<o1> s o1=<o1>
o1&fStr=put-o1.fStr o=put-o1.fStr
o1&=put-o1-value o=put-o1-value
o1&fRef=<o0> o=<o0>
o1&fRef>fSt0=put o0.fSt0 o=put o0.fSt0
o1&fRef>fRe0=!putO o0.fRe0 o=!putO o0.fRe0
m.o1&fNest.fSt0= put-o1.fNest.fSt0 m.o1&fNest.fRe0= !put-o1&fNest.f+
Re0
o1&fNest.fSt0=put-o1.fNest.fSt0 o=put-o1.fNest.fSt0
o1&fNest&fRe0=!put-o1&fNest.fRe0 o=!put-o1&fNest.fRe0
$/tstEnvVars1/
$=/tstEnvVars2/
### start tst tstEnvVars2 #########################################
o2=<o2> getO(o2)=<o2> getO(o2&fRef)=<o1>
o2&fRef>fStr=put-o1.fStr o=put-o1.fStr
o2&fRef>=put-o1-value o=put-o1-value
o2&fRef>fRef=<o0> o=<o0>
o2&fRef>fRef>fSt0=put o0.fSt0 o=put o0.fSt0
o2&fRef>fRef>fRe0=!putO o0.fRe0 o=!putO o0.fRe0
o2&fRef>fNest.fSt0=put-o1.fNest.fSt0 o=put-o1.fNest.fSt0
o2&fRef>fNest&fRe0=!put-o1&fNest.fRe0 o=!put-o1&fNest.fRe0
$/tstEnvVars2/
$=/tstEnvVarsS/
### start tst tstEnvVarsS #########################################
oS=<oS> oS&fStS=<put oS.fStS>
oS&fStV.0=1 oS&fStV.1=<put oS.fStV.1>
m.oS.fStR.0=2 .2=!<put oS.fStR.2>
oS&fStR.0=2 .1=!<put oS.fStR.1> .2=!<put oS.fStR.2>
m.oS.0=9876 .1234=<put oS.1234>
*** err: undefined var oS&12
oS&0=9876 .12=M. .1234=<put oS.1234>
$/tstEnvVarsS/
$=/tstEnvVars3/
### start tst tstEnvVars3 #########################################
m.<o0>=*o0*val vGet(<o0>>)=*o0*val
m.<o0>.fSt0=*o0.fSt0*val vGet(<o0>>fSt0)=*o0.fSt0*val
m.<o0>.fRe0=<o1> vGet(<o0>>fRe0)=<o1>
m.<o1>=*o1*val vGet(<o0>>fRe0>)=*o1*val
m.<o1>.fStr=*o1.fStr*val vGet(<o0>>fRe0>fStr)=*o1.fStr*val
m.V.tstEnvVar0=<o0> vGet(tstEnvVar0)=<o0>
m.V.tstEnvVar0=<o0> vGet(tstEnvVar0&)=<o0>
m.<o0>=*o0*val vGet(tstEnvVar0&>)=*o0*val
m.<o0>.fSt0=*o0.fSt0*val vGet(tstEnvVar0&fSt0)=*o0.fSt0*val
m.<o0>.fRe0=<o1> vGet(tstEnvVar0&fRe0)=<o1>
m.<o1>=*o1*val vGet(tstEnvVar0&fRe0>)=*o1*val
m.<o1>.fStr=*o1.fStr*val vGet(tstEnvVar0&fRe0>fStr)=*o1.fStr*val
m.<o1>.fVar=tstEnvVar2 vGet(tstEnvVar0&fRe0>fVar)=tstEnvVar2
m.<o2>=*o2*val vGet(tstEnvVar0&fRe0>fVar&)=<o2>
m.<o2>=*o2*val vGet(tstEnvVar0&fRe0>fVar&>)=*o2*val
m.<o2>.fStr=*o2.fStr*val vGet(tstEnvVar0&fRe0>fVar&fStr)=*o2.fStr*v+
al
m.<o0>=*o0*put2 vGet(<o0>>)=*o0*put2
m.<o0>.fSt0=*o0.fSt0*put2 vGet(<o0>>fSt0)=*o0.fSt0*put2
m.<o1>=*o0>fRe0>put2 vGet(<o0>>fRe0>)=*o0>fRe0>put2
m.<o1>.fStr=*o0>fRe0>fStr*put2 vGet(<o0>>fRe0>fStr)=*o0>fRe0>fStr*p+
ut2
m.<o0>=*v0&>*put3 vGet(tstEnvVar0&>)=*v0&>*put3
m.<o0>.fSt0=*v0&fSt0*put3 vGet(tstEnvVar0&fSt0)=*v0&fSt0*put3
m.<o1>=*v0&fRe0>*put3 vGet(tstEnvVar0&fRe0>)=*v0&fRe0>*put3
m.<o1>.fStr=*v0&fRe0>fStr*put3 vGet(tstEnvVar0&fRe0>fStr)=*v0&fRe0>+
fStr*put3
m.<o2>=*v0&fRe0>fVar&>*put3 vGet(tstEnvVar0&fRe0>fVar&>)=*v0&fRe0>f+
Var&>*put3
m.<o2>.fStr=*v0&fRe0>fVar&fStr*put3 vGet(tstEnvVar0&fRe0>fVar&fStr)+
=*v0&fRe0>fVar&fStr*put3
$/tstEnvVars3/
*/
c0 = classNew('n? TstEnvVars0 u f fSt0 v, f = v, f fRe0 r')
c1 = classNew('n? TstEnvVars1 u f fStr v,f fRef r' ,
', f fNest TstEnvVars0, f = v, f fVar v')
o0 = oNew(c0)
o1 = oNew(c1)
o2 = oNew(c1)
call tst t, "tstEnvVars3"
call mAdd t.trans, o0 '<o0>', o1 '<o1>', o2 '<o2>'
fSt0 = 'fSt0'
fRe0 = 'fRe0'
fStr = 'fStr'
fRef = 'fRef'
fVar = 'fVar'
v0 = 'tstEnvVar0'
v2 = 'tstEnvVar2'
m.o0 = '*o0*val'
m.o0.fSt0 = '*o0.fSt0*val'
m.o0.fRe0 = o1
m.o1 = '*o1*val'
m.o1.fStr = '*o1.fStr*val'
m.o1.fRef = o2
m.o1.fVar = v2
m.o2 = '*o2*val'
m.o2.fStr = '*o2.fStr*val'
m.v.v0 = o0
m.v.v2 = o2
call tstEnvVarsMG o0, o0'>'
call tstEnvVarsMG o0'.'fSt0, o0'>'fSt0
call tstEnvVarsMG o0'.'fRe0, o0'>'fRe0
call tstEnvVarsMG o1, o0'>'fRe0'>'
call tstEnvVarsMG o1'.'fStr, o0'>'fRe0'>'fStr
call tstEnvVarsMG v'.'v0, v0
call tstEnvVarsMG v'.'v0, v0'&'
call tstEnvVarsMG o0, v0'&>'
call tstEnvVarsMG o0'.'fSt0, v0'&'fSt0
call tstEnvVarsMG o0'.'fRe0, v0'&'fRe0
call tstEnvVarsMG o1, v0'&'fRe0'>'
call tstEnvVarsMG o1'.'fStr, v0'&'fRe0'>'fStr
call tstEnvVarsMG o1'.'fVar, v0'&'fRe0'>'fVar
call tstEnvVarsMG o2, v0'&'fRe0'>'fVar'&'
call tstEnvVarsMG o2, v0'&'fRe0'>'fVar'&>'
call tstEnvVarsMG o2'.'fStr, v0'&'fRe0'>'fVar'&fStr'
call vPut o0'>', '*o0*put2'
call tstEnvVarsMG o0, o0'>'
call vPut o0'>'fSt0, '*o0.fSt0*put2'
call tstEnvVarsMG o0'.'fSt0, o0'>'fSt0
call vPut o0'>'fRe0'>', '*o0>fRe0>put2'
call tstEnvVarsMG o1, o0'>'fRe0'>'
call vPut o0'>'fRe0'>'fStr, '*o0>fRe0>fStr*put2'
call tstEnvVarsMG o1'.'fStr, o0'>'fRe0'>'fStr
call vPut v0'&>', '*v0&>*put3'
call tstEnvVarsMG o0, v0'&>'
call vPut v0'&'fSt0, '*v0&fSt0*put3'
call tstEnvVarsMG o0'.'fSt0, v0'&'fSt0
call vPut v0'&'fRe0'>', '*v0&fRe0>*put3'
call tstEnvVarsMG o1, v0'&'fRe0'>'
call vPut v0'&'fRe0'>'fStr, '*v0&fRe0>fStr*put3'
call tstEnvVarsMG o1'.'fStr, v0'&'fRe0'>'fStr
call vPut v0'&'fRe0'>'fVar'&>', '*v0&fRe0>fVar&>*put3'
call tstEnvVarsMG o2, v0'&'fRe0'>'fVar'&>'
call vPut v0'&'fRe0'>'fVar'&fStr', '*v0&fRe0>fVar&fStr*put3'
call tstEnvVarsMG o2'.'fStr, v0'&'fRe0'>'fVar'&fStr'
call tstEnd t, "tstEnvVars"
call tst t, "tstEnvVars"
call mAdd t.trans, o0 '<o0>', o1 '<o1>', o2 '<o2>'
call vRemove 'v2'
m.tst.adr1 = 'value eins'
put1 = vPut('v1', oMutate(tst'.'adr1, m.class_V))
call tstOut t, 'put v1' m.put1
call tstOut t, 'v1 hasKey' vHasKey('v1') 'get' vGet('v1')
call tstOut t, 'v2 hasKey' vHasKey('v2')
if 0 then
call tstOut t, 'v2 get' vGet('v2')
call vPut 'theBuf', jBuf()
call pipe '+F' , vGet('theBuf')
call out 'one to theBur'
call out 'two to theBuf'
call pipe '-'
call pipe '+f',, vGet('theBuf')
call pipeWriteNow
call pipe '-'
call tstOut t, 'v1='vGet('v1') 'o='vGet('v1')
call vPut 'v3', 'v3WieGehts?'
call tstOut t, 'v3='vGet('v3') 'o='vGet('v3')
call vPut 'v4', s2o('v4WieGehts?')
call tstOut t, 'v4='vGet('v4') 'o='vGet('v4')
call vPut 'o0', o0
call tstOut t, 'o o0='vGet('o0')
call tstOut t, 's o0='vGet('o0')
fSt0 = 'fSt0'
fRe0 = 'fRe0'
m.o0 = 'rexx o0-value'
m.o0.fSt0 = 'rexx o0.fSt0'
m.o0.fRe0 = s2o('rexx o0.fRe0')
call tstOut t, 'o o0='vGet('o0')
call tstOut t, 's o0='vGet('o0')
call tstOut t, 'o0&fSt0='vGet('o0&fSt0') 'o='vGet('o0&fSt0')
call tstOut t, 'o0&fRe0='vGet('o0&fRe0') 'o='vGet('o0&fRe0')
call tstOut t, 'o0&='vGet('o0&>') 'o='vGet('o0&>')
call vPut 'o0&>', 'put o0-value'
call vPut 'o0&fSt0', 'put o0.fSt0'
call vPut 'o0&fRe0', s2o('putO o0.fRe0')
call tstOut t, 'o o0='vGet('o0')
call tstOut t, 's o0='vGet('o0')
call tstOut t, 'o0&fSt0='vGet('o0&fSt0') 'o='vGet('o0&fSt0')
call tstOut t, 'o0&fRe0='vGet('o0&fRe0') 'o='vGet('o0&fRe0')
call tstOut t, 'o0&='vGet('o0&>') 'o='vGet('o0&>')
call tstEnd t
call tst t, "tstEnvVars1"
call mAdd t.trans, o0 '<o0>', o1 '<o1>', o2 '<o2>'
call vPut 'o1', o1
call vPut 'o1&>', 'put-o1-value'
call vPut 'o1&fStr', 'put-o1.fStr'
call vPut 'o1&fRef', vGet('o0')
call tstOut t, 'm.o1='m.o1 'm.o1.fStr='mGet(o1'.fStr'),
'm.o1.fRef='mGet(o1'.fRef')
call tstOut t, 'o o1='vGet('o1') 's o1='vGet('o1')
call tstOut t, 'o1&fStr='vGet('o1&fStr') 'o='vGet('o1&fStr')
call tstOut t, 'o1&='vGet('o1&>') 'o='vGet('o1&>')
call tstOut t, 'o1&fRef='vGet('o1&fRef') 'o='vGet('o1&fRef')
call tstOut t, 'o1&fRef>fSt0='vGet('o1&fRef>fSt0') ,
'o='vGet('o1&fRef>fSt0')
call tstOut t, 'o1&fRef>fRe0='vGet('o1&fRef>fRe0'),
'o='vGet('o1&fRef>fRe0')
call vPut 'o1&fNest.fSt0', 'put-o1.fNest.fSt0'
call vPut 'o1&fNest.fRe0', s2o('put-o1&fNest.fRe0')
call tstOut t, 'm.o1&fNest.fSt0=' mGet(o1'.fNest.fSt0') ,
'm.o1&fNest.fRe0=' mGet(o1'.fNest.fRe0')
call tstOut t, 'o1&fNest.fSt0='vGet('o1&fNest.fSt0'),
'o='vGet('o1&fNest.fSt0')
call tstOut t, 'o1&fNest&fRe0='vGet('o1&fNest.fRe0'),
'o='vGet('o1&fNest.fRe0')
call tstEnd t
call tst t, "tstEnvVars2"
call mAdd t.trans, o0 '<o0>', o1 '<o1>', o2 '<o2>'
call vPut 'o2', o2
call vPut 'o2&fRef', vGet('o1')
call tstOut t, 'o2='o2 'getO(o2)='vGet('o2'),
'getO(o2&fRef)='vGet('o2&fRef')
call tstOut t, 'o2&fRef>fStr='vGet('o2&fRef>fStr'),
'o='vGet('o2&fRef>fStr')
call tstOut t, 'o2&fRef>='vGet('o2&fRef>'),
'o='vGet('o2&fRef>')
call tstOut t, 'o2&fRef>fRef='vGet('o2&fRef>fRef') ,
'o='vGet('o2&fRef>fRef')
call tstOut t, 'o2&fRef>fRef>fSt0='vGet('o2&fRef>fRef>fSt0') ,
'o='vGet('o2&fRef>fRef>fSt0')
call tstOut t, 'o2&fRef>fRef>fRe0='vGet('o2&fRef>fRef>fRe0'),
'o='vGet('o2&fRef>fRef>fRe0')
call tstOut t, 'o2&fRef>fNest.fSt0='vGet('o2&fRef>fNest.fSt0'),
'o='vGet('o2&fRef>fNest.fSt0')
call tstOut t, 'o2&fRef>fNest&fRe0='vGet('o2&fRef>fNest.fRe0'),
'o='vGet('o1&fNest.fRe0')
call tstEnd t
cS = classNew('n? TstEnvVarsS u f fStS v,f fStV s v, f fStR s r',
', f fNeS s TstEnvVars0, f = s v')
oS = oNew(cS)
call vPut 'oS', oS
oT = oNew(cS)
call tst t, "tstEnvVarsS"
call mAdd t.trans, o0 '<o0>', o1 '<o1>', o2 '<o2>',
, oS '<oS>', oT '<oT>'
call mPut oS'.fStS', '<put oS.fStS>'
call tstOut t, 'oS='vGet('oS') 'oS&fStS='vGet('oS&fStS')
call mPut oS'.fStV.1', '<put oS.fStV.1>'
call mPut oS'.fStV.0', 1
call tstOut t, 'oS&fStV.0='vGet('oS&fStV.0'),
'oS&fStV.1='vGet('oS&fStV.1')
call mPut oS'.fStR.1', s2o('<put oS.fStR.1>')
call mPut oS'.fStR.2', s2o('<put oS.fStR.2>')
call mPut oS'.fStR.0', 2
call tstOut t, 'm.oS.fStR.0='mGet(oS'.fStR.0'),
'.2='mGet(oS'.fStR.2')
call tstOut t, 'oS&fStR.0='vGet('oS&fStR.0'),
'.1='vGet('oS&fStR.1') '.2='vGet('oS&fStR.2')
call mPut oS'.1234', '<put oS.1234>'
call mPut oS'.0', 9876
call mPut oS'.fStR.0', 2
call tstOut t, 'm.oS.0='mGet(oS'.0'),
'.1234='mGet(oS'.1234')
call tstOut t, 'oS&0='vGet('oS&0'),
'.12='vGet('oS&12') '.1234='vGet('oS&1234')
call tstEnd t
return
endProcedure tstEnvVars
tstEnvVarsMG: procedure expose m.
parse arg m, g
call tstOut t, 'm.'m'='m.m 'vGet('g')='vGet(g)
return
tstvWith: procedure expose m.
/*
$=/tstEW2/
### start tst tstEW2 ##############################################
tstK1 TSTEW1
tstK1& !get1 w
tstK1&f1 get1.f1 v
tstK1&f2 !get1.f2 w
tstK1&F3 get1.f3 v
ttstK1&F3.FEINS get1.f3.fEins v
tstK1&F3.FZWEI !get1.f3.fZwei w
tstK1&F3.FDREI o !get1.f3.fDrei w
tstK1&F3.FDREI !get1.f3.fDrei w
tstK1&F3.1 !get1.f3.1 w
tstK1&F3.2 TSTEW1
tstK1&F3.2>F1 get1.f1 v
tstK1&F3.2>F3.2>F2 !get1.f2 w
*** err: undefined var F1
F1 M..
F1 get1.f1 v
f2 !get1.f2 w
F3 get1.f3 v
F3.FEINS get1.f3.fEins v
F3.FZWEI !get1.f3.fZwei w
F3.FDREI o !get1.f3.fDrei w
F3.1 !get1.f3.1 w
pu1 F1 get1.f1 v
pu2 F1 get2.f1 v
po-2 F1 get1.f1 v
*** err: undefined var F1
po-1 F1 M..
$/tstEW2/ */
call pipeIni
c0 = classNew('n? TstEW0 u f FEINS v,f FZWEI w, f FDREI r,v,s r')
call classMet c0, 'oFlds' /* new would do it, but we donot use it */
cl = classNew('n? TstEW u r TstEW0, f F1 v, f F2 r, f F3 TstEW0')
call classMet cl, 'oFlds' /* new would do it, but we donot use it */
call oMutate tstEW1, cl
m.tstEW1 = s2o('get1 w')
m.tstEW1.f1 = 'get1.f1 v'
m.tstEW1.f2 = s2o('get1.f2 w')
m.tstEW1.f3 = 'get1.f3 v'
m.tstEW1.f3.fEins = 'get1.f3.fEins v'
m.tstEW1.f3.fZwei = s2o('get1.f3.fZwei w')
m.tstEW1.f3.fDrei = s2o('get1.f3.fDrei w')
m.tstEW1.f3.0 = 3
m.tstEW1.f3.1 = s2o('get1.f3.1 w')
m.tstEW1.f3.2 = tstEW1
m.tstEW1.f3.3 = s2o('get1.f3.3 w')
call oMutate tstEW2, cl
m.tstEW2 = s2o('get2 w')
m.tstEW2.f1 = 'get2.f1 v'
m.tstEW2.f2 = s2o('get2.f2 w')
call vPut 'tstK1', tstEW1
call tst t, 'tstEW2'
call tstOut t, 'tstK1 ' vGet('tstK1')
call tstOut t, 'tstK1& ' vGet('tstK1&>')
call tstOut t, 'tstK1&f1 ' vGet('tstK1&F1')
call tstOut t, 'tstK1&f2 ' vGet('tstK1&F2')
call tstOut t, 'tstK1&F3 ' vGet('tstK1&F3')
call tstOut t, 'ttstK1&F3.FEINS ' vGet('tstK1&F3.FEINS')
call tstOut t, 'tstK1&F3.FZWEI ' vGet('tstK1&F3.FZWEI')
call tstOut t, 'tstK1&F3.FDREI o ' vGet('tstK1&F3.FDREI')
call tstOut t, 'tstK1&F3.FDREI ' vGet('tstK1&F3.FDREI')
call tstOut t, 'tstK1&F3.1 ' vGet('tstK1&F3.1')
call tstOut t, 'tstK1&F3.2 ' vGet('tstK1&F3.2')
call tstOut t, 'tstK1&F3.2>F1 ' vGet('tstK1&F3.2>F1')
call tstOut t, 'tstK1&F3.2>F3.2>F2' ,
vGet('tstK1&F3.2>F3.2>F2')
call tstOut t, 'F1 ' vGet('F1')
call vWith '+', tstEW1
call tstOut t, 'F1 ' vGet('F1')
call tstOut t, 'f2 ' vGet('F2')
call tstOut t, 'F3 ' vGet('F3')
call tstOut t, 'F3.FEINS ' vGet('F3.FEINS')
call tstOut t, 'F3.FZWEI ' vGet('F3.FZWEI')
call tstOut t, 'F3.FDREI o ' vGet('F3.FDREI')
call tstOut t, 'F3.1 ' vGet('F3.1')
call tstOut t, 'pu1 F1 ' vGet('F1')
call vWith '+', tstEW2
call tstOut t, 'pu2 F1 ' vGet('F1')
call vWith '-'
call tstOut t, 'po-2 F1 ' vGet('F1')
call vWith '-'
call tstOut t, 'po-1 F1 ' vGet('F1')
call tstEnd t
/*
$=/tstEW3/
### start tst tstEW3 ##############################################
. s c3&F1 = v(c3&f1)
*** err: null address at &FEINS in c3&F1&FEINS
*** err: undefined var c3&F1&FEINS
. s c3&F1&FEINS = M..
*** err: null address at &FEINS in c3&F3&FEINS
*** err: null address at &FEINS in c3&F3&FEINS
*** err: undefined var c3&F3&FEINS
. s c3&F3&FEINS = M..
. s c3&F3.FEINS = val(c3&F3.FEINS)
*** err: undefined var c3&FEINS
. s c3&FEINS = M..
getO c3&
aft Put s c3&>FEINS = v&&fEins
Push c3 s F3.FEINS = val(c3&F3.FEINS)
aftPut= s F3.FEINS = pushPut(F3.FEINS)
push c4 s F1 = v(c4&f1)
put f2 s F2 = put(f2)
put .. s F3.FEINS = put(f3.fEins)
popW c4 s F1 = v(c3&f1)
*** err: undefined var F1
popW c3 s F1 = M..
. s F222 = f222 pop stop
$/tstEW3/
*/
call tst t, 'tstEW3'
c3 = oNew('TstEW')
call mAdd t.trans, c3 '<c3>'
m.c3.f1 = 'v(c3&f1)'
call vPut 'c3', c3
call tstEnvSG , 'c3&F1'
call tstEnvSG , 'c3&F1&FEINS'
call tstEnvSG , 'c3&F3&FEINS'
call vPut 'c3&F3.FEINS', 'val(c3&F3.FEINS)'
call tstEnvSG , 'c3&F3.FEINS'
call tstEnvSG , 'c3&FEINS'
call tstOut t, 'getO c3&', vGet('c3&')
call vPut 'c3&>', oNew('TstEW0')
call vPut 'c3&>FEINS', 'v&&fEins'
call tstEnvSG 'aft Put', 'c3&>FEINS'
call vWith '+', c3
call tstEnvSG 'Push c3', 'F3.FEINS'
call vPut 'F3.FEINS', 'pushPut(F3.FEINS)'
call tstEnvSG 'aftPut=', 'F3.FEINS'
c4 = oNew('TstEW')
call mAdd t.trans, c4 '<c4>'
m.c4.f1 = 'v(c4&f1)'
call vPut f222, 'f222 no stop'
call vWith '+', c4
call tstEnvSG 'push c4', f1
call vPut f2, 'put(f2)'
call tstEnvSG 'put f2', f2
call vPut f222, 'f222 stopped', 1
call vPut 'F3.FEINS', 'put(f3.fEins)'
call tstEnvSG 'put .. ', 'F3.FEINS'
call vWith '-'
call tstEnvSG 'popW c4', f1
call vWith '-'
call vPut f222, 'f222 pop stop'
call tstEnvSG 'popW c3', f1
call tstEnvSG , f222
call tstEnd t
return
endProcedure tstvWith
tstEnvSG: procedure expose m. t
parse arg txt, nm
call tstOut t, left(txt,10)'s' left(nm, 15)'=' vGet(nm)
return
tstPipeLazy: procedure expose m.
call pipeIni
/*
$=/tstPipeLazy/
### start tst tstPipeLazy #########################################
a1 vor pipeBegin loop lazy 0 writeNow *** <class TstPipeLazyBuf>
bufOpen <
bufClose
#jIn 2# tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
a5 vor 2 writeNow in inIx 4
a2 vor writeNow jBuf
jBuf line 1
jBuf line 2
a3 vor writeNow in inIx 1
tst in line 2 zwei ; .
tst in line 3 drei .schluss..
a4 vor barLast inIx 4
a6 vor barEnd inIx 4
a7 nach barEnd lazy 0 writeNow ***
b1 vor barBegin lazy 0 writeNow *** <class TstPipeLazyRdr>
RdrOpen <
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
rdrClose
b4 vor writeNow
b2 vor writeNow rdr inIx 2
jRead lazyRdr
tst in line 3 drei .schluss..
jRead lazyRdr
b3 vor barLast inIx 4
b5 vor barEnd inIx 4
b6 nach barEnd lazy 0 writeNow ***
a1 vor pipeBegin loop lazy 1 writeAll *** +
.<class TstPipeLazyBuf>
a5 vor 2 writeAll in inIx 0
a2 vor writeAll jBuf
bufOpen <
jBuf line 1
jBuf line 2
bufClose
a3 vor writeAll in inIx 0
#jIn 1# tst in line 1 eins ,
tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
tst in line 3 drei .schluss..
#jIn eof 4#
a4 vor barLast inIx 0
a6 vor barEnd inIx 4
a7 nach barEnd lazy 1 writeAll ***
b1 vor barBegin lazy 1 writeAll *** <class TstPipeLazyRdr>
b4 vor writeAll
b2 vor writeAll rdr inIx 1
RdrOpen <
jRead lazyRdr
#jIn 2# tst in line 2 zwei ; .
tst in line 2 zwei ; .
jRead lazyRdr
#jIn 3# tst in line 3 drei .schluss..
tst in line 3 drei .schluss..
jRead lazyRdr
#jIn eof 4#
rdrClose
b3 vor barLast inIx 1
b5 vor barEnd inIx 4
b6 nach barEnd lazy 1 writeAll ***
$/tstPipeLazy/ */
call tst t, "tstPipeLazy"
do lz=0 to 1
if lz then
w = 'writeAll'
else
w = 'writeNow'
m.t.inIx = 1-lz
ty = class4Name('TstPipeLazyBuf', '')
if ty == '' then do
ty = classNew('n TstPipeLazyBuf u JRWDeleg', 'm',
, 'jOpen call tstOut "T", "bufOpen" opt;',
'call jOpen m.m.deleg, opt',
, 'jClose call tstOut "T", "bufClose";',
'call jClose m.m.deleg')
end
if \ lz then
call mAdd t'.TRANS', ty '<class TstPipeLazyBuf>'
call out 'a1 vor pipeBegin loop lazy' lz w '***' ty
call pipe '+N'
call out 'a2 vor' w 'jBuf'
b = oNew('TstPipeLazyBuf', jBuf('jBuf line 1','jBuf line 2'))
interpret 'call pipe'w 'b'
call out 'a3 vor' w 'in inIx' m.t.inIx
interpret 'call pipe'w
call out 'a4 vor barLast inIx' m.t.inIx
call pipe 'P|'
call out 'a5 vor 2' w 'in inIx' m.t.inIx
interpret 'call pipe'w
call out 'a6 vor barEnd inIx' m.t.inIx
call pipe '-'
call out 'a7 nach barEnd lazy' lz w '***'
ty = class4Name('TstPipeLazyRdr', '')
if ty == '' then
ty = classNew('n TstPipeLazyRdr u JRW', 'm',
, 'jOpen call tstOut "T", "RdrOpen" opt',
, 'jRead call out "jRead lazyRdr";' ,
'mr = m.m.rdr; if \ jRead(mr) then return 0;',
"m.m = m.mr; return 1",
, 'jClose call tstOut "T", "rdrClose";')
if \ lz then
call mAdd t'.TRANS', ty '<class TstPipeLazyRdr>'
r = oNew('TstPipeLazyRdr')
m.r.rdr = m.j.in
if lz then
call mAdd t'.TRANS', r '<lazyRdr>'
m.t.inIx = 2-lz
call out 'b1 vor barBegin lazy' lz w '***' ty
call pipe '+N'
call out 'b2 vor' w 'rdr inIx' m.t.inIx
interpret 'call pipe'w 'r'
call out 'b3 vor barLast inIx' m.t.inIx
call pipe 'P|'
call out 'b4 vor' w
interpret 'call pipe'w
call out 'b5 vor barEnd inIx' m.t.inIx
call pipe '-'
call out 'b6 nach barEnd lazy' lz w '***'
end
call tstEnd t
return
endProcedure tstPipeLazy
tstEnvClass: procedure expose m.
call pipeIni
/*
$=/tstEnvClass/
### start tst tstEnvClass #########################################
a0 vor pipeBegin loop lazy 0 writeNow *** TY
#jIn 2# tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
a5 vor writeNow
a1 vor jBuf()
a2 vor writeNow b
tstR: @<o20 of TstEnvClass10> isA :TstEnvClass10
tstR: .f11 = .
tstR: .F12 = value F12 of o1 <o20 of TstEnvClass10>
tstR: .f13 = .
WriteO o2
tstR: @<oc0 of TstEnvClass20> isA :TstEnvClass20 = valueO2Lazy0
tstR: .f24 = .
tstR: .F25 = value F25 of o20 <o20 of TstEnvClass20>
a3 vor writeNow
tst in line 2 zwei ; .
tst in line 3 drei .schluss..
a4 vor barLast inIx 4
a6 vor barEnd
a7 nach barEnd lazy 0 writeNow ***
a0 vor pipeBegin loop lazy 1 writeAll *** TY
a5 vor writeAll
a1 vor jBuf()
a2 vor writeAll b
tstR: @<o21 of TstEnvClass10> isA :TstEnvClass10
tstR: .f11 = .
tstR: .F12 = value F12 of o1 <o21 of TstEnvClass10>
tstR: .f13 = .
WriteO o2
tstR: @<oc1 of TstEnvClass20> isA :TstEnvClass20 = valueO2Lazy1
tstR: .f24 = .
tstR: .F25 = value F25 of o21 <o21 of TstEnvClass20>
a3 vor writeAll
#jIn 1# tst in line 1 eins ,
tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
tst in line 3 drei .schluss..
#jIn eof 4#
a4 vor barLast inIx 0
a6 vor barEnd
a7 nach barEnd lazy 1 writeAll ***
$/tstEnvClass/ */
call tst t, "tstEnvClass"
t10 = classNew('n? TstEnvClass10 u f f11 v, f F12 v, f f13 v')
t20 = classNew('n? TstEnvClass20 u v, f f24 v, f F25 v')
do lz=0 to 1
if lz then
w = 'writeAll'
else
w = 'writeNow'
m.t.inIx = 1-lz
call out 'a0 vor pipeBegin loop lazy' lz w '***' ty
call pipe '+N'
call out 'a1 vor jBuf()'
b = jOpen(jBuf(), m.j.cWri)
o1 = oNew('TstEnvClass10')
m.o1.F12 = 'value F12 of o1' o1
call mAdd t'.TRANS', o1 '<o2'lz 'of TstEnvClass10>'
call jWrite b, o1
call jWrite b, 'WriteO o2'
o2 = oNew('TstEnvClass20')
m.o2 = 'valueO2Lazy'lz
m.o2.F25 = 'value F25 of o2'lz o2
oc = oCopy(oCopy(o2))
call mAdd t'.TRANS', o2 '<o2'lz 'of TstEnvClass20>'
call mAdd t'.TRANS', oc '<oc'lz 'of TstEnvClass20>'
call jWrite b, oc
call out 'a2 vor' w 'b'
interpret 'call pipe'w jClose(b)
call out 'a3 vor' w
interpret 'call pipe'w
call out 'a4 vor barLast inIx' m.t.inIx
call pipe 'P|'
call out 'a5 vor' w
interpret 'call pipe'w
call out 'a6 vor barEnd'
call pipe '-'
call out 'a7 nach barEnd lazy' lz w '***'
end
call tstEnd t
m.t.trans.0 = 0
return
endProcedure tstEnvClass
tstDsn: procedure expose m.
/*
$=/tstDsn/
### start tst tstDsn ##############################################
aa has 4 members: created
- aa(DREI) 3 lines, aa(drei) 1/3, aa(drei) 2/3, aa(drei) 3/3
- aa(EINS) 1 lines, aa(eins) 1/1
- aa(NULL) 0 lines
- aa(ZWEI) 2 lines, aa(zwei) 1/2, aa(zwei) 2/2
bb has 1 members: copy eins, eins1
- bb(EINS1) 1 lines, aa(eins) 1/1
bb has 2 members: copy zwei
- bb(EINS1) 1 lines, aa(eins) 1/1
- bb(ZWEI) 2 lines, aa(zwei) 1/2, aa(zwei) 2/2
cc has 1 members: copy drei cc new
- cc(DREI) 3 lines, aa(drei) 1/3, aa(drei) 2/3, aa(drei) 3/3
bb has 5 members: copy
- bb(DREI) 3 lines, aa(drei) 1/3, aa(drei) 2/3, aa(drei) 3/3
- bb(EINS) 1 lines, aa(eins) 1/1
- bb(EINS1) 1 lines, aa(eins) 1/1
- bb(NULL) 0 lines
- bb(ZWEI) 2 lines, aa(zwei) 1/2, aa(zwei) 2/2
bb has 8 members: copy null eins drei >*4
- bb(DREI) 3 lines, aa(drei) 1/3, aa(drei) 2/3, aa(drei) 3/3
- bb(DREI4) 3 lines, aa(drei) 1/3, aa(drei) 2/3, aa(drei) 3/3
- bb(EINS) 1 lines, aa(eins) 1/1
- bb(EINS1) 1 lines, aa(eins) 1/1
- bb(EINS4) 1 lines, aa(eins) 1/1
- bb(NULL) 0 lines
- bb(NULL4) 0 lines
- bb(ZWEI) 2 lines, aa(zwei) 1/2, aa(zwei) 2/2
bb has 7 members: delete null4
- bb(DREI) 3 lines, aa(drei) 1/3, aa(drei) 2/3, aa(drei) 3/3
- bb(DREI4) 3 lines, aa(drei) 1/3, aa(drei) 2/3, aa(drei) 3/3
- bb(EINS) 1 lines, aa(eins) 1/1
- bb(EINS1) 1 lines, aa(eins) 1/1
- bb(EINS4) 1 lines, aa(eins) 1/1
- bb(NULL) 0 lines
- bb(ZWEI) 2 lines, aa(zwei) 1/2, aa(zwei) 2/2
bb has 3 members: delete eins4 drei4 eins drei
- bb(EINS1) 1 lines, aa(eins) 1/1
- bb(NULL) 0 lines
- bb(ZWEI) 2 lines, aa(zwei) 1/2, aa(zwei) 2/2
bb has 3 members: delete drei4
- bb(EINS1) 1 lines, aa(eins) 1/1
- bb(NULL) 0 lines
- bb(ZWEI) 2 lines, aa(zwei) 1/2, aa(zwei) 2/2
before seqFuenf 5 lines, seqFuenf ::f 1/5, seqFuenf ::f 2/5, seqFue+
nf ::f 3/5, seqFuenf ::f 4/5, seqFuenf ::f 5/5
copy zwei seqFuenf 2 lines, aa(zwei) 1/2, aa(zwei) 2/2
copy null seqFuenf 0 lines
before seqVier 4 lines, seqVier ::f 1/4, seqVier ::f 2/4, seqVier :+
:f 3/4, seqVier ::f 4/4
bb has 4 members: copy .seqVier
- bb(EINS1) 1 lines, aa(eins) 1/1
- bb(FROVIER) 4 lines, seqVier ::f 1/4, seqVier ::f 2/4, seqVier ::+
f 3/4, seqVier ::f 4/4
- bb(NULL) 0 lines
- bb(ZWEI) 2 lines, aa(zwei) 1/2, aa(zwei) 2/2
delete seqFuenf does not exist
delete seqFuenf does not exist
$/tstDsn/
*/
do sx=0 to m.tst_csmRZ \== ''
sys = copies(m.tst_csmRz'/', sx)
say 'csm/sys='sys '+++++++++++++++++++++++++++'
call tst t, 'tstDsn'
pr = tstFileName(sys'tstDsn', 'r')
call tstDsnWr pr'.aa(null) ::f', 0
call tstDsnWr pr'.aa(eins)', 1
call tstDsnWr pr'.aa(zwei)', 2
call tstDsnWr pr'.aa(drei)', 3
call tstDsnWr pr'.seqVier ::f', 4
call tstDsnWr pr'.seqFuenf ::f', 5
call tstDsnRL t, pr'.aa', 'created'
call dsnCopy pr'.aa(eins)', pr'.bb(eins1)'
call tstDsnRL t, pr'.bb', 'copy eins, eins1'
call dsnCopy pr'.aa(zwei)', pr'.bb'
call tstDsnRL t, pr'.bb', 'copy zwei'
call dsnCopy pr'.aa(drei)', pr'.cc'
call tstDsnRL t, pr'.cc', 'copy drei cc new'
call dsnCopy pr'.aa', pr'.bb'
call tstDsnRL t, pr'.bb', 'copy'
call dsnCopy pr'.aa', pr'.bb', 'null>null4 eins>eins4' ,
'drei>drei4'
call tstDsnRL t, pr'.bb', 'copy null eins drei >*4'
call dsnDel pr'.bb(null4)'
call tstDsnRL t, pr'.bb', 'delete null4'
call dsnDel pr'.bb(eins)'
call dsnDel pr'.bb(eins4)'
call dsnDel pr'.bb', 'drei drei4'
call tstDsnRL t, pr'.bb', 'delete eins4 drei4 eins drei'
call dsnDel pr'.bb(drei4)'
call tstDsnRL t, pr'.bb', 'delete drei4'
call tstOut t, 'before' tstDsnr1(pr'.seqFuenf')
call dsnCopy pr'.aa(zwei)', pr'.seqFuenf'
call tstOut t, 'copy zwei' tstDsnr1(pr'.seqFuenf')
call dsnCopy pr'.aa(null)', pr'.seqFuenf'
call tstOut t, 'copy null' tstDsnr1(pr'.seqFuenf')
call tstOut t, 'before' tstDsnr1(pr'.seqVier')
call dsnCopy pr'.seqVier', pr'.bb(froVier)'
call tstDsnRL t, pr'.bb', 'copy .seqVier'
call dsnDel pr'.seqFuenf'
call tstOut t, 'delete' tstDsnr1(pr'.seqFuenf')
call dsnDel pr'.seqFuenf'
call tstOut t, 'delete' tstDsnr1(pr'.seqFuenf')
/* delete all to avoid mixup in next loop */
pr = tstFileName(sys'tstDsn', 'r')
call tstEnd t
end
return
endProcedure tstDsn
tstDsnWr: procedure expose m.
parse arg dsn, li
q = strip(substr(dsn, lastPos('.', dsn) + 1))
do ox=1 to li
o.ox = q ox'/'li
end
call writeDsn dsn, o., li, 1
return
endProcedure tstDsnWr
tstDsnR1: procedure expose m.
parse arg dsn
q = strip(substr(dsn, lastPos('.', dsn) + 1))
if \ dsnExists(dsn) then
return q 'does not exist'
call readDsn dsn, i.
r = q i.0 'lines'
do ix=1 to i.0
r = r',' strip(i.ix)
end
return r
endProcedure tstDsnR1
tstDsnRL: procedure expose m.
parse arg t, dsn, msg
q = strip(substr(dsn, lastPos('.', dsn) + 1))
call mbrList tst_dsnL, dsn
call tstOut t, q 'has' m.tst_dsnL.0 'members:' msg
do mx=1 to m.tst_dsnL.0
call tstOut t, '-' tstDsnR1(dsn'('m.tst_dsnL.mx')')
end
return
endProcedure tstDsnRL
tstDsnEx: procedure expose m.
/*
$=/tstDsnEx/
### start tst tstDsnEx ############################################
dsnExists(A540769.WK.rexx) 1
dsnExists(RZZ/A540769.WK.rexx) 1
dsnExists(A540769.WK.wk.rexxYY) 0
dsnExists(RZZ/A540769.WK.wk.rexxYY) 0
dsnExists(A540769.WK.rexx(wsh)) 1
dsnExists(RZZ/A540769.WK.rexx(wsh)) 1
dsnExists(A540769.WK.rexx(nonono)) 0
dsnExists(RZZ/A540769.WK.rexx(nonono)) 0
dsnExists(A540769.WK.rxxYY(nonon)) 0
dsnExists(RZZ/A540769.WK.rxxYY(nonon)) 0
*** err: error in csm mbrList ?QZ/A540769.WK.RXXYY(NONON) .
. e 1: CSMSI77E INVALID SYSTEM NAME (MUST BE * OR A VALID NAME) +
(COL:8)
. e 2: CSMSI77E SYSTEM=?QZ
dsnExists(?qZ/A540769.WK.rxxYY(nonon)) 0
$/tstDsnEx/
*/
call tst t, 'tstDsnEx'
lst = 'rexx wk.rexxYY rexx(wsh) rexx(nonono) rxxYY(nonon)'
rz = m.tst_csmRZ
do lx =1 to words(lst)
d1 = 'A540769.WK.'word(lst,lx)
call tstOut t, 'dsnExists('d1')' dsnExists(d1)
call tstOut t, 'dsnExists('rz'/'d1')' dsnExists(rz'/'d1)
end
call mAdd t'.TRANS', '00'x '?', '0A'x '?'
call tstOut t, 'dsnExists(?qZ/'d1')' dsnExists('?qZ/'d1)
call tstEnd t
return
endProceudre tstDsnEx
tstFile: procedure expose m.
call catIni
/*
$=/tstFile/
### start tst tstFile #############################################
write read 0 last 10 vor anfang
write read 1 last 80 links1 1 und rechts | ..
write read 2 last 80 liinks2 2 und rechts | ..
write read 5 last 80 links5 5 rechts5
write read 99 last 80 links99 99 rechts
write read 100 last 80 links100 100 rechts
write read 101 last 80 links101 101 rechts
write read 999 last 80 links999 999 rechts
write read 1000 last 80 links1000 1000 rechts
write read 1001 last 80 links1001 1001 rechts
write read 2109 last 80 links2109 2109 rechts
out > eins 1 +
. .
out > eins 2 schluss. +
. .
buf eins
buf zwei
buf drei
out > zwei mit einer einzigen Zeile +
. .
. links1 1 und rechts | . +
. .
$/tstFile/ */
call tst t, "tstFile"
pds = tstFilename('lib', 'r')
call tstFileWr pds, 0, ' links0', ' und rechts | . '
call tstFileWr pds, 1, ' links1', ' und rechts | . '
call tstFileWr pds, 2, 'liinks2', ' und rechts | . '
call tstFileWr pds, 5, 'links5', 'rechts5'
call tstFileWr pds, 99, 'links99', 'rechts'
call tstFileWr pds, 100, 'links100', 'rechts'
call tstFileWr pds, 101, 'links101', 'rechts'
call tstFileWr pds, 999, 'links999', 'rechts'
call tstFileWr pds, 1000, 'links1000', 'rechts'
call tstFileWr pds, 1001, 'links1001', 'rechts'
call tstFileWr pds, 2109, 'links2109', 'rechts'
pd2 = tstFilename('li2', 'r')
call pipeIni
call pipe '+F', s2o(tstPdsMbr(pd2, 'eins'))
call out tstFB('out > eins 1') /* simulate fixBlock on linux */
call out tstFB('out > eins 2 schluss.')
call pipe '-'
call pipe '+F', s2o(tstPdsMbr(pd2, 'zwei'))
call out tstFB('out > zwei mit einer einzigen Zeile')
call pipe '-'
b = jBuf("buf eins", "buf zwei", "buf drei")
call pipe '+ffffff', , s2o(tstPdsMbr(pd2, 'eins')), b,
,jBuf(),
,s2o(tstPdsMbr(pd2, 'zwei')),
,s2o(tstPdsMbr(pds, 'wr0')),
,s2o(tstPdsMbr(pds, 'wr1'))
call pipeWriteNow
call pipe '-'
call tstEnd t
return
endProcedure tstFile
/*--- simulate fixBlock 80 on linux ---------------------------------*/
tstFB: procedure expose m.
parse arg line, recL
if m.err.os \== 'LINUX' then
return line
else if recL == '' then
return left(line, 80)
else
return left(line, recL)
endProcedure tstFB
tstPdsMbr: procedure expose m.
parse arg pds, mbr
if m.err.os = 'TSO' then
return pds'('mbr') ::F'
if m.err.os = 'LINUX' then
return pds'.'mbr
call err 'tstPdsMbr implement os' m.err.os
endProcedure tstPdsMbr
tstFileWR: procedure expose m.
parse arg dsn, num, le, ri
io = file(tstPdsMbr(dsn, 'wr'num))
call jOpen io, m.j.cWri
do x = 1 to num /* simulate fixBlock 80 on LINUX*/
call jWrite io, tstFB(le x ri)
end
call jClose io
if num > 100 then
call jReset io, tstPdsMbr(dsn, 'wr'num)
call jOpen io, m.j.cRead
m.io = 'vor anfang'
do x = 1 to num
if \ jRead(io) then
call err x 'not jRead'
else if m.io <> le x ri then
call err x 'read mismatch' m.io
end
if jRead(io) then
call err x 'jRead but should be eof 1'
if jRead(io) then
call err x'+1 jjRead but should be eof 2'
call jClose io
call tstOut t, 'write read' num 'last' length(m.io) strip(m.io,'t')
return
endProcedure tstFileWr
tstFileList: procedure expose m.
call catIni
/*
$=/tstFileList/
### start tst tstFileList #########################################
empty dir
filled dir
<<pref 2 List>>eins
<<pref 2 List>>zwei
<<pref 2 List>>drei
<<pref 2 List>>vier
filled dir recursive
<<pref 2 List>>eins
<<pref 2 List>>zwei
<<pref 2 List>>drei
<<pref 2 List>>vier
<<pref 1 vier>>eins
<<pref 1 vier>>zwei
<<pref 1 vier>>drei
$/tstFileList/ */
/*
$=/tstFileListTSO/
### start tst tstFileListTSO ######################################
empty dir dsnList 0
empty dir fileList
filled dir .* dsnList 3
<<pref 2 LIST>>DREI
<<pref 2 LIST>>EINS
<<pref 2 LIST>>ZWEI
filled dir fileList
<<pref 2 LIST>>DREI
<<pref 2 LIST>>EINS
<<pref 2 LIST>>ZWEI
filled dir dsnList 6
<<pref 2 LIST>>DREI
<<pref 2 LIST>>EINS
<<pref 1 VIER>>DREI
<<pref 1 VIER>>EINS
<<pref 1 VIER>>ZWEI
<<pref 2 LIST>>ZWEI
filled dir fileList recursive
<<pref 2 LIST>>DREI
<<pref 2 LIST>>EINS
<<pref 1 VIER>>DREI
<<pref 1 VIER>>EINS
<<pref 1 VIER>>ZWEI
<<pref 2 LIST>>ZWEI
$/tstFileListTSO/ */
if m.err.os = 'TSO' then
call tst t, "tstFileListTSO"
else
call tst t, "tstFileList"
fi = file(tstFileName('FileList', 'r'))
call fileMkDir fi
fl = fileList(fi)
call tstFileListDsn t, filePath(fi), 'empty dir'
call tstOut t, 'empty dir fileList'
call jWriteNow t, fl
call tstFileListMake t, fi, 2
call tstFileListDsn t, filePath(fi)'.*', 'filled dir .*'
call tstOut t, 'filled dir fileList'
call jWriteNow t, fl
call tstFileListDsn t, filePath(fi), 'filled dir'
call tstOut t, 'filled dir fileList recursive'
call jWriteNow t, fileList(fi, 'r')
call tstEnd t
return
endProcedure tstFileList
tstFileListDsn: procedure expose m.
parse arg t, fi, msg
call tstOut t, msg 'dsnList' dsnList(tst_FileListDsn, fi)
do ox=1 to m.tst_FileListDsn.0
call tstOut t, m.tst_FileListDsn.ox
end
return
endProcedure tstFileListDsn
tstFileListMake: procedure expose m.
parse arg t, fi, lev
if \ fileIsDir(fi) then
call fileMkDir fi
call mAdd t'.TRANS', filePath(fi) || m.file.sep ,
'<<pref' lev right(filePath(fi),4)'>>'
call jCat fileChild(fi, 'eins','::F'),jBuf('zeile eins','eins' lev)
call jCat fileChild(fi, 'zwei','::F'),jBuf('zeile zwei','zwei' lev)
call jCat fileChild(fi, 'drei','::F'),jBuf('zeile drei','drei' lev)
if lev > 1 then
call tstFileListMake t, fileChild(fi, 'vier'), lev-1
return
endProcedure tstFileListMake
tstMail: procedure expose m.
do i=1 to 2
call mailHead xy, 'mail from walter''s rexx' time() i, A540769
call mailText xy, 'und hier kommt der text' ,
, 'und zeile zwei timestamp' i':' date('s') time() ,
, left('und eine lange Zeile 159', 156, '+')159 ,
, left('und eine lange Zeile 160', 157, '+')160 ,
, left('und eine lange Zeile 161', 158, '+')161 ,
, '<ol><li>'left('und eine lange', 200, '+')203 '</li>',
, '<li bgcolor=yellow>und kurz</li></ol>' ,
, '<h1>und Schluss mit html</h1>'
call mailSend xy
call sleep 3
end
return
endprocedure tstMail
tstF: procedure expose m.
/*
$=/tstF/
### start tst tstF ################################################
f(1 23%c345%c67%%8, eins, zwei ) =1 23eins345 zwei 67%8;
f(1\S23%c345%S67%%8, eins, zwei ) =1\S23eins345zwei67%8;
f(1 23%C345%C67%%8, eins, zwei ) =1 23eins345 zwei 67%8;
f(1 23%c345%S67%%8, eins, zwei ) =1 23eins345zwei67%8;
f(1%S2%c3@2%S4@%c5, eins, zwei ) =1eins2 zwei 3zwei4 zwei 5;
f(1%-2C2%3C3@2%3.2C4, eins, zwei ) =1ei2ei 3zwe4;
f(1@F1%c2@f2%c3@F3%c4, eins, zwei ) =1fEins2fZwei3fDrei4;
tstF2 _ %-9C @%5I @%8I @%+8I @%-8I -----
_ 0 0 0 +0 0 .
_ -1.2 -1 -1 -1 -1 .
_ 2.34 2 2 +2 2 .
_ -34.8765 -35 -35 -35 -35 .
_ 567.91234 568 568 +568 568 .
_ -8901 -8901 -8901 -8901 -8901 .
_ 23456 23456 23456 +23456 23456 .
_ -789012 ***** -789012 -789012 -789012 .
_ 34e6 ***** 34000000 ******** 34000000
_ -56e7 ***** ******** ******** ********
_ 89e8 ***** ******** ******** ********
_ txtli txtli txtli txtli txtli .
_ undEinLan undEi undEinLa undEinLa undEinLa
tstF2 _ %-9C @%5.2I @%12.2I @%+12.2I @%-12.2I -----
_ 0 0.00 0.00 +0.00 0.00 .
_ -1.2 -1.20 -1.20 -1.20 -1.20 .
_ 2.34 2.34 2.34 +2.34 2.34 .
_ -34.8765 ***** -34.88 -34.88 -34.88 .
_ 567.91234 ***** 567.91 +567.91 567.91 .
_ -8901 ***** -8901.00 -8901.00 -8901.00 .
_ 23456 ***** 23456.00 +23456.00 23456.00 .
_ -789012 ***** -789012.00 -789012.00 -789012.00 .
_ 34e6 ***** 34000000.00 +34000000.00 34000000.00 .
_ -56e7 ***** ************ ************ ************
_ 89e8 ***** ************ ************ ************
_ txtli txtli txtli txtli txtli .
_ undEinLan undEi undEinLanger undEinLanger undEinLanger
tstF2 _ %-9C @%7e @% 8E @% 9.3e @% 11.4E -----
_ 0 0.00e00 0.00E00 0.000e00 0.0000E000
_ -1.2 -1.2e00 -1.20E00 -1.200e00 -1.2000E000
_ 2.34 2.34e00 2.34E00 2.340e00 2.3400E000
_ -34.8765 -3.5e01 -3.49E01 -3.488e01 -3.4877E001
_ 567.91234 5.68e02 5.68E02 5.679e02 5.6791E002
_ -8901 -8.9e03 -8.90E03 -8.901e03 -8.9010E003
_ 23456 2.35e04 2.35E04 2.346e04 2.3456E004
_ -789012 -7.9e05 -7.89E05 -7.890e05 -7.8901E005
_ 34e6 3.40e07 3.40E07 3.400e07 3.4000E007
_ -56e7 -5.6e08 -5.60E08 -5.600e08 -5.6000E008
_ 89e8 8.90e09 8.90E09 8.900e09 8.9000E009
_ txtli txtli txtli txtli txtli.
_ undEinLan undEinL undEinLa undEinLan undEinLange
_ 8.76e-07 8.76e-7 8.76E-7 8.760e-7 8.7600E-07
_ 5.43e-11 5.4e-11 5.4E-11 5.43e-11 5.4300E-11
_ -8.76e-07 -8.8e-7 -8.76E-7 -8.760e-7 -8.7600E-07
_ -5.43e-11 -5e-011 -5.4E-11 -5.43e-11 -5.4300E-11
tstF2 _ %-9C @%kt @%kd @%kb -----
_ 0 0s00 0 0 .
_ -1.2 -1s20 -1 -1 .
_ 2.34 2s34 2340m 2 .
_ -34.8765 -0m35 -35 -35 .
_ 567.91234 9m28 568 568 .
_ -8901 -2h28 -9k -9k
_ 23456 6h31 23k 23k
_ -789012 -9d03 -789k -771k
_ 34e6 394d 34M 32M
_ -56e7 -++++ -560M -534M
_ 89e8 +++++ 8900M 8488M
_ txtli txtli txtli txtli
_ undEinLan Text? Text? Text?
_ 8.76e-07 0s00 876n 0 .
_ 5.43e-11 0s00 54p 0 .
_ -8.76e-07 -0s00 -876n -0 .
_ -5.43e-11 -0s00 -54p -0 .
$/tstF/ */
call tst t, 'tstF'
call tstF1 '1 23%c345%c67%%8'
call tstF1 '1\S23%c345%S67%%8'
call tstF1 '1 23%C345%C67%%8'
call tstF1 '1 23%c345%S67%%8'
call tstF1 '1%S2%c3@2%S4@%c5'
call tstF1 '1%-2C2%3C3@2%3.2C4'
call tstF1 '1@F1%c2@f2%c3@F3%c4'
nums = '0 -1.2 2.34 -34.8765 567.91234 -8901 23456' ,
'-789012 34e6 -56e7 89e8 txtli undEinLangerText?'
call tstF2 '_ %-9C @%5I @%8I @%+8I @%-8I', nums
call tstF2 '_ %-9C @%5.2I @%12.2I @%+12.2I @%-12.2I', nums
num2 = ' 8.76e-07 5.43e-11 -8.76e-07 -5.43e-11'
call tstF2 '_ %-9C @%7e @% 8E @% 9.3e @% 11.4E', nums num2
call tstF2 '_ %-9C @%kt @%kd @%kb', nums num2
call tstEnd t
return
endProcedure tstF
tstF1: procedure expose m.
parse arg fmt
e='eins'
z=' zwei '
f2 = 'f2'
m.e.f1 = 'fEins'
m.e.f2 = 'fZwei'
m.e.f3 = 'fDrei'
call tstOut t, "f("fmt"," e"," z") ="f(fmt, e, z)";"
return
endProcedure tstF1
tstF2: procedure expose m.
parse arg fmt, vals
call tstOut t, 'tstF2' fmt '-----'
do vx=1 to words(vals)
call tstOut t, f(fmt, word(vals, vx))
end
return
endProcedure tstF2
tstFWords: procedure expose m.
/*
$=/tstFWords/
### start tst tstFWords ###########################################
??empty?? .
1space .
, %#e-- --
%#a%9c .
*%#a%-7c .
??empty?? eins
1space eins
, %#e-- eins
%#a%9c eins
*%#a%-7c eins .
??empty?? einszwei
1space eins zwei
, %#e-- eins, zwei
%#a%9c eins zwei
*%#a%-7c eins *zwei .
??empty?? einszweidrei
1space eins zwei drei
, %#e-- eins, zwei, drei
%#a%9c eins zwei drei
*%#a%-7c eins *zwei *drei .
$/tstFWords/
*/
ws = ' eins zwei drei '
call tst t, 'tstFWords'
do l=0 to 3
call tstOut t, '??empty?? ' fWords( ,subword(ws,1,l))
call tstOut t, '1space ' fWords(' ' ,subword(ws,1,l))
call tstOut t, ', %#e-- ' fWords(', %#e--' ,subword(ws,1,l))
call tstOut t, '%#a%9c ' fWords('%#a%9c' ,subword(ws,1,l))
call tstOut t, '*%#a%-7c ' fWords('*%#a%-7c' ,subword(ws,1,l))
end
call tstEnd t
return
endProcedure tstFWords
tstFe: procedure expose m.
/*
$=/tstFe/
### start tst tstFe ###############################################
. 1 < 1.00e00> <1.00e00>
. 0 < 0.00e00> <0.00e00>
. -2.1 <-2.10e00> <-2.1e00>
. .3 < 3.00e-1> <3.00e-1>
. -.45678 <-4.57e-1> <-4.6e-1>
. 901 < 9.01e02> <9.01e02>
. -2345 <-2.35e03> <-2.3e03>
. 678e90 < 6.78e92> <6.78e92>
. 123e-4 < 1.23e-2> <1.23e-2>
. 567e-89 < 5.7e-87> <5.7e-87>
. 12e456 < 1.2e457> <1.2e457>
. 78e-901 < 8e-0900> <8e-0900>
. 2345e5789 < 2e05792> <2e05792>
. 123e-4567 < 1e-4565> <1e-4565>
. 8901e23456 < 9e23459> <9e23459>
. -123e-4567 <-1e-4565> <-0e-999>
. 567e890123 <********> <*******>
. 45678e-901234 < 0e-9999> <0e-9999>
. kurz < kurz> <kurz >
. undLangerText <undLange> <undLang>
$/tstFe/
*/
call tst t, 'tstFe'
vAll = '1 0 -2.1 .3 -.45678 901 -2345 678e90 123e-4' ,
'567e-89 12e456 78e-901 2345e5789 123e-4567 8901e23456' ,
'-123e-4567 567e890123 45678e-901234' ,
'kurz undLangerText'
do vx=1 to words(vAll)
v = word(vAll, vx)
call tstOut t, right(v, 20) '<'fe(v, 8, 2, 'e', ' ')'>' ,
'<'fe(v, 7, 1, 'e', '-')'>'
end
call tstEnd t
return
endProcedure
tstFTst: procedure expose m.
/*
$=/tstFTstS/
### start tst tstFTstS ############################################
1956-01-29-23.34.56.987654 SS => 1956-01-29-23.34.56.987654|
1956-01-29-23.34.56.987654 Ss => 1956-01-29-23.34.56|
1956-01-29-23.34.56.987654 S => 1956-01-29-23.34.56|
1956-01-29-23.34.56.987654 SD => 19560129|
1956-01-29-23.34.56.987654 Sd => 560129|
1956-01-29-23.34.56.987654 SE => 29.01.1956|
1956-01-29-23.34.56.987654 Se => 29.01.56|
1956-01-29-23.34.56.987654 St => 23.34.56|
1956-01-29-23.34.56.987654 ST => 23:34:56.987654|
1956-01-29-23.34.56.987654 SY => GB29|
1956-01-29-23.34.56.987654 SM => B2923345|
1956-01-29-23.34.56.987654 SH => C33456|
1956-01-29-23.34.56.987654 Sj => 56029|
1956-01-29-23.34.56.987654 SJ => 714076|
$/tstFTstS/
$=/tstFTsts/
### start tst tstFTsts ############################################
2014-12-23-16.57.38 sS => 2014-12-23-16.57.38.000000|
2014-12-23-16.57.38 ss => 2014-12-23-16.57.38|
2014-12-23-16.57.38 s => 2014-12-23-16.57.38|
2014-12-23-16.57.38 sD => 20141223|
2014-12-23-16.57.38 sd => 141223|
2014-12-23-16.57.38 sE => 23.12.2014|
2014-12-23-16.57.38 se => 23.12.14|
2014-12-23-16.57.38 st => 16.57.38|
2014-12-23-16.57.38 sT => 16:57:38.000000|
2014-12-23-16.57.38 sY => EM23|
2014-12-23-16.57.38 sM => M2316573|
2014-12-23-16.57.38 sH => B65738|
2014-12-23-16.57.38 sj => 14357|
2014-12-23-16.57.38 sJ => 735589|
2014-12-23-16.57.38 su +> E1KCA3JT|
2014-12-23-16.57.38 sL +> 00CE3F48639FB0000000|
$/tstFTsts/
$=/tstFTstD/
### start tst tstFTstD ############################################
23450618 DS => 2345-06-18-00.00.00.000000|
23450618 Ds => 2345-06-18-00.00.00|
23450618 D => 2345-06-18-00.00.00|
23450618 DD => 23450618|
23450618 Dd => 450618|
23450618 DE => 18.06.2345|
23450618 De => 18.06.45|
23450618 Dt => 00.00.00|
23450618 DT => 00:00:00.000000|
23450618 DY => PG18|
23450618 DM => G1800000|
23450618 DH => A00000|
23450618 Dj => 45169|
23450618 DJ => 856296|
$/tstFTstD/
$=/tstFTstd/
### start tst tstFTstd ############################################
120724 dS => 2012-07-24-00.00.00.000000|
120724 ds => 2012-07-24-00.00.00|
120724 d => 2012-07-24-00.00.00|
120724 dD => 20120724|
120724 dd => 120724|
120724 dE => 24.07.2012|
120724 de => 24.07.12|
120724 dt => 00.00.00|
120724 dT => 00:00:00.000000|
120724 dY => CH24|
120724 dM => H2400000|
120724 dH => A00000|
120724 dj => 12206|
120724 dJ => 734707|
$/tstFTstd/
$=/tstFTstE/
### start tst tstFTstE ############################################
09.12.1345 ES => 1345-12-09-00.00.00.000000|
09.12.1345 Es => 1345-12-09-00.00.00|
09.12.1345 E => 1345-12-09-00.00.00|
09.12.1345 ED => 13451209|
09.12.1345 Ed => 451209|
09.12.1345 EE => 09.12.1345|
09.12.1345 Ee => 09.12.45|
09.12.1345 Et => 00.00.00|
09.12.1345 ET => 00:00:00.000000|
09.12.1345 EY => PM09|
09.12.1345 EM => M0900000|
09.12.1345 EH => A00000|
09.12.1345 Ej => 45343|
09.12.1345 EJ => 491228|
$/tstFTstE/
$=/tstFTste/
### start tst tstFTste ############################################
31.05.2467 eS => 2024-05-31-00.00.00.000000|
31.05.2467 es => 2024-05-31-00.00.00|
31.05.2467 e => 2024-05-31-00.00.00|
31.05.2467 eD => 20240531|
31.05.2467 ed => 240531|
31.05.2467 eE => 31.05.2024|
31.05.2467 ee => 31.05.2467|
31.05.2467 et => 00.00.00|
31.05.2467 eT => 00:00:00.000000|
31.05.2467 eY => OF31|
31.05.2467 eM => F3100000|
31.05.2467 eH => A00000|
31.05.2467 ej => 24152|
31.05.2467 eJ => 739036|
$/tstFTste/
$=/tstFTstt/
### start tst tstFTstt ############################################
12.34.56 tS => 0001-01-01-12.34.56.000000|
12.34.56 ts => 0001-01-01-12.34.56|
12.34.56 t => 0001-01-01-12.34.56|
12.34.56 tD => 00010101|
12.34.56 td => 010101|
12.34.56 tE => 01.01.0001|
12.34.56 te => 01.01.01|
12.34.56 tt => 12.34.56|
12.34.56 tT => 12:34:56.000000|
12.34.56 tY => ??01|
12.34.56 tM => ?0112345|
12.34.56 tH => B23456|
12.34.56 tj => 01001|
12.34.56 tJ => 0|
$/tstFTstt/
$=/tstFTstT/
### start tst tstFTstT ############################################
23.45.06.784019 TS => 0001-01-01-23.45.06.784019|
23.45.06.784019 Ts => 0001-01-01-23.45.06|
23.45.06.784019 T => 0001-01-01-23.45.06|
23.45.06.784019 TD => 00010101|
23.45.06.784019 Td => 010101|
23.45.06.784019 TE => 01.01.0001|
23.45.06.784019 Te => 01.01.01|
23.45.06.784019 Tt => 23.45.06|
23.45.06.784019 TT => 23.45.06.784019|
23.45.06.784019 TY => ??01|
23.45.06.784019 TM => ?0123450|
23.45.06.784019 TH => C34506|
23.45.06.784019 Tj => 01001|
23.45.06.784019 TJ => 0|
$/tstFTstT/
$=/tstFTstY/
### start tst tstFTstY ############################################
FE25 YS => 2015-04-25-00.00.00.000000|
FE25 Ys => 2015-04-25-00.00.00|
FE25 Y => 2015-04-25-00.00.00|
FE25 YD => 20150425|
FE25 Yd => 150425|
FE25 YE => 25.04.2015|
FE25 Ye => 25.04.15|
FE25 Yt => 00.00.00|
FE25 YT => 00:00:00.000000|
FE25 YY => FE25|
FE25 YM => E2500000|
FE25 YH => A00000|
FE25 Yj => 15115|
FE25 YJ => 735712|
$/tstFTstY/
$=/tstFTstM/
### start tst tstFTstM ############################################
I2317495 MS => 0001-08-23-17.49.50.000000|
I2317495 Ms => 0001-08-23-17.49.50|
I2317495 M => 0001-08-23-17.49.50|
I2317495 MD => 00010823|
I2317495 Md => 010823|
I2317495 ME => 23.08.0001|
I2317495 Me => 23.08.01|
I2317495 Mt => 17.49.50|
I2317495 MT => 17:49:50.000000|
I2317495 MY => ?I23|
I2317495 MM => I2317495|
I2317495 MH => B74950|
I2317495 Mj => 01235|
I2317495 MJ => 234|
$/tstFTstM/
$=/tstFTstH/
### start tst tstFTstH ############################################
B23456 HS => 0001-01-01-12.34.56.000000|
B23456 Hs => 0001-01-01-12.34.56|
B23456 H => 0001-01-01-12.34.56|
B23456 HD => 00010101|
B23456 Hd => 010101|
B23456 HE => 01.01.0001|
B23456 He => 01.01.01|
B23456 Ht => 12.34.56|
B23456 HT => 12:34:56.000000|
B23456 HY => ??01|
B23456 HM => ?0112345|
B23456 HH => B23456|
B23456 Hj => 01001|
B23456 HJ => 0|
$/tstFTstH/
$=/tstFTstn/
### start tst tstFTstn ############################################
19560423 17:58:29 nS => 1956-04-23-17.58.29.000000|
19560423 17:58:29 ns => 1956-04-23-17.58.29|
19560423 17:58:29 n => 1956-04-23-17.58.29|
19560423 17:58:29 nD => 19560423|
19560423 17:58:29 nd => 560423|
19560423 17:58:29 nE => 23.04.1956|
19560423 17:58:29 ne => 23.04.56|
19560423 17:58:29 nt => 17.58.29|
19560423 17:58:29 nT => 17:58:29.000000|
19560423 17:58:29 nY => GE23|
19560423 17:58:29 nM => E2317582|
19560423 17:58:29 nH => B75829|
19560423 17:58:29 nj => 56114|
19560423 17:58:29 nJ => 714161|
$/tstFTstn/
$=/tstFTstN/
### start tst tstFTstN ############################################
32101230 10:21:32.456789 NS => 3210-12-30-10.21.32.456789|
32101230 10:21:32.456789 Ns => 3210-12-30-10.21.32|
32101230 10:21:32.456789 N => 3210-12-30-10.21.32|
32101230 10:21:32.456789 ND => 32101230|
32101230 10:21:32.456789 Nd => 101230|
32101230 10:21:32.456789 NE => 30.12.3210|
32101230 10:21:32.456789 Ne => 30.12.10|
32101230 10:21:32.456789 Nt => 10.21.32|
32101230 10:21:32.456789 NT => 10:21:32.456789|
32101230 10:21:32.456789 NY => AM30|
32101230 10:21:32.456789 NM => M3010213|
32101230 10:21:32.456789 NH => B02132|
32101230 10:21:32.456789 Nj => 10364|
32101230 10:21:32.456789 NJ => 1172426|
$/tstFTstN/
*/
say "f('%t ')" f('%t ')
call timeIni
allOut = 'Ss DdEetTYMHjJ'
allIn = 'S1956-01-29-23.34.56.987654' ,
's2014-12-23-16.57.38' ,
'D23450618' ,
'd120724' ,
'E09.12.1345' ,
'e31.05.2467' ,
't12.34.56' ,
'T23.45.06.784019' ,
'YFE25' ,
'MI2317495' ,
'HB23456' ,
'n19560423*17:58:29' ,
'N32101230*10:21:32.456789'
do ix=1 to words(allIn)
parse value word(allIn, ix) with iF 2 iV
iv = translate(iv, ' ', '*')
call tst t, "tstFTst"iF
do ox=1 to length(allOut)
ft = iF || substr(allOut, ox, 1)
call tstOut t, left(iV, 30) ft '=>' f('%t'ft, iV)'|'
if 0 & iF = 'Y' then
say '???' ft '>>>' mGet('F_GEN.%t'ft)
end
if ix=2 then do
call tstOut t, left(iV, 30) iF'u' '+>' f('%t'iF'u', iV)'|'
call tstOut t, left(iV, 30) iF'L' '+>' f('%t'iF'L', iV)'|'
end
call tstEnd t
end
return
endProcedure tstFTst
tstFmt: procedure expose m.
call pipeIni
/*
$=/tstFmt/
### start tst tstFmt ##############################################
= a2i b3b d4 fl5 ex6
-11 -11 b3 d4-11+d4++++ -111.1000000 -1.11000e-12
-1 -10 b d4-10+d4+++ null1 null3
- -9 b3b-9 d4-9+d4+++ -11.0000000 -1.11900e-10
-8+ -8 b3b- d4-8+d4++ -18.0000000 -1.18000e010
-7 -7 b3b d4-7+d4+ -7.0000000 -1.70000e-07
- -6 b3 d4-6+d4 -0.1111160 -6.00000e006
-5+ -5 b d4-5+d null2 null2
-4 -4 b3b-4 d4-4+ -11114.0000000 -1.11140e008
- -3 b3b- d4-3 -0.1130000 -1.13000e-04
-2+ -2 b3b d4- -0.1200000 -1.20000e001
-1 -1 b3 d4 -0.1000000 -1.00000e-02
0 0 b d null1 null1
1+ 1 b3 d4 0.1000000 1.00000e-02
2++ 2 b3b d42 0.1200000 1.20000e001
3 3 b3b3 d43+ 0.1130000 1.13000e-04
4+ 4 b3b4+ d44+d 11114.0000000 1.11140e008
5++ 5 b d45+d4 null2 null2
6 6 b3 d46+d4+ 0.1111160 1.11116e005
7+ 7 b3b d47+d4++ 0.1111117 7.00000e-08
8++ 8 b3b8 d48+d4+++ 8.0000000 1.80000e009
9 9 b3b9+ d49+d4++++ 0.9000000 1.19000e-08
10 10 b d410+d4++++ null1 null3
11+ 11 b3 d411+d4+++++ 0.1110000 1.00000e-12
1 12 b3b d412+d4++++++ 11112.0000000 2.00000e012
13 13 b3b1 d 1111.3000000 1.13000e-12
14+ 14 b3b14 d4 111111.0000000 1.40000e013
1 15 b d41 null2 null1
16 16 b3 d416 6.0000000 1.16000e003
17+ 17 b3b d417+ 0.7000000 1.11170e-03
1 18 b3b1 d418+d 11.0000000 1.11800e003
19 19 b3b19 d419+d4 0.1190000 9.00000e-05
20+ 20 b d420+d4+ null1 null2
2 21 b3 d421+d4++ 11.1210000 1.11000e-05
22 22 b3b d422+d4+++ 11111.2000000 2.00000e007
23+ 23 b3b2 d423+d4++++ 0.1111123 1.11230e-09
c3L a2i drei d4 fl5 ex6
-11 -1.10E01 b3 d4-11+d -111.1000000 -1.11000e-12
-1 -1.00E01 b d4-10+d null1 null3
- -9.00E00 b3b-9 d4-9+d4 -11.0000000 -1.11900e-10
-8+ -8.00E00 b3b- d4-8+d4 -18.0000000 -1.18000e010
-7 -7.00E00 b3b d4-7+d4 -7.0000000 -1.70000e-07
- -6.00E00 b3 d4-6+d4 -0.1111160 -6.00000e006
-5+ -5.00E00 b d4-5+d null2 null2
-4 -4.00E00 b3b-4 d4-4+ -11114.0000000 -1.11140e008
- -3.00E00 b3b- d4-3 -0.1130000 -1.13000e-04
-2+ -2.00E00 b3b d4- -0.1200000 -1.20000e001
-1 -1.00E00 b3 d4 -0.1000000 -1.00000e-02
0 0.00E00 b d null1 null1
1+ 1.00E00 b3 d4 0.1000000 1.00000e-02
2++ 2.00E00 b3b d42 0.1200000 1.20000e001
3 3.00E00 b3b3 d43+ 0.1130000 1.13000e-04
4+ 4.00E00 b3b4+ d44+d 11114.0000000 1.11140e008
5++ 5.00E00 b d45+d4 null2 null2
6 6.00E00 b3 d46+d4+ 0.1111160 1.11116e005
7+ 7.00E00 b3b d47+d4+ 0.1111117 7.00000e-08
8++ 8.00E00 b3b8 d48+d4+ 8.0000000 1.80000e009
9 9.00E00 b3b9+ d49+d4+ 0.9000000 1.19000e-08
10 1.00E01 b d410+d4 null1 null3
11+ 1.10E01 b3 d411+d4 0.1110000 1.00000e-12
1 1.20E01 b3b d412+d4 11112.0000000 2.00000e012
13 1.30E01 b3b1 d 1111.3000000 1.13000e-12
14+ 1.40E01 b3b14 d4 111111.0000000 1.40000e013
1 1.50E01 b d41 null2 null1
16 1.60E01 b3 d416 6.0000000 1.16000e003
17+ 1.70E01 b3b d417+ 0.7000000 1.11170e-03
1 1.80E01 b3b1 d418+d 11.0000000 1.11800e003
19 1.90E01 b3b19 d419+d4 0.1190000 9.00000e-05
20+ 2.00E01 b d420+d4 null1 null2
2 2.10E01 b3 d421+d4 11.1210000 1.11000e-05
22 2.20E01 b3b d422+d4 11111.2000000 2.00000e007
23+ 2.30E01 b3b2 d423+d4 0.1111123 1.11230e-09
$/tstFmt/ */
call tst t, "tstFmt"
b = jBuf()
st = b'.BUF'
call pipe '+F', b
call tstDataClassOut '. c3 a2i i b3b c5 d4 c13 fl5 f8n2 ex6 e9n3',
, -11, + 23
call pipe '-'
call fTabAuto fTabReset(abc, 1), b
call fTabReset abc, 1
call fTabAddDetect abc, , st , , 'c3L'
call fTabAdd abc, 'a2i', '% 8E'
call fTabAddDetect abc, 'b3b', st , ,'drei'
call fTabAdd abc, 'd4', '%-7C'
call fTabAddDetect abc, 'fl5', st
call fTabAddDetect abc, 'ex6', st
call fTab abc, b
call tstEnd t
return
endProcedure tstFmt
tstFTab: procedure expose m.
/*
$=/tstFTab/
### start tst tstFTab #############################################
testData begin
..---------a2i-b3b------------------d4------fl5-----ex6---
-11 -11 b3 -11+d4++++ -111.100 -1e-012
-1 -10 b 4-10+d4+++ null1 null3
- -9 b3b-9 d4-9+d4+++ -11.000 -1e-010
-8+ -8 b3b- d4-8+d4++ -18.000 -1.2e10
-7 -7 b3b d4-7+d4+ -7.000 -1.7e-7
- -6 b3 d4-6+d4 -0.111 -6.0e06
-5+ -5 b d4-5+d null2 null2
-4 -4 b3b-4 d4-4+ ******** -1.1e08
- -3 b3b- d4-3 -0.113 -1.1e-4
-2+ -2 b3b d4- -0.120 -1.2e01
-1 -1 b3 d4 -0.100 -1.0e-2
0 0 b d null1 null1
1+ 1 b3 d4 0.100 1.00e-2
2++ 2 b3b d42 0.120 1.20e01
3 3 b3b3 d43+ 0.113 1.13e-4
4+ 4 b3b4+ d44+d ******** 1.11e08
5++ 5 b d45+d4 null2 null2
6 6 b3 d46+d4+ 0.111 1.11e05
7+ 7 b3b d47+d4++ 0.111 7.00e-8
8++ 8 b3b8 d48+d4+++ 8.000 1.80e09
9 9 b3b9+ d49+d4++++ 0.900 1.19e-8
10 10 b 410+d4++++ null1 null3
11+ 11 b3 11+d4+++++ 0.111 1.0e-12
1 12 b3b 2+d4++++++ ******** 2.00e12
13 13 b3b1 d 1111.300 1.1e-12
14+ 14 b3b14 d4 ******** 1.40e13
1 15 b d41 null2 null1
16 16 b3 d416 6.000 1.16e03
17+ 17 b3b d417+ 0.700 1.11e-3
1 18 b3b1 d418+d 11.000 1.12e03
19 19 b3b19 d419+d4 0.119 9.00e-5
20+ 20 b d420+d4+ null1 null2
2 21 b3 d421+d4++ 11.121 1.11e-5
22 22 b3b d422+d4+++ ******** 2.00e07
23+ 23 b3b2 423+d4++++ 0.111 1.11e-9
..---------a2i-b3b------------------d4------fl5-----ex6---
testData end
$/tstFTab/ */
call pipeIni
call tst t, "tstFTab"
b = jBuf()
st = b'.BUF'
call pipe '+F', b
call tstDataClassOut '. c3 a2i i b3b c5 d4 c13 fl5 f8n2 ex6 e9n3',
, -11, + 23
call pipe 'P|'
call fTabReset ft, 2 1, 1 3, '-'
call fTabAddRCT ft, '=' , '%-6C', '.', , 'testData begin',
, 'testData end'
call fTabAddRCT ft, 'a2i' , '%6i'
call fTabAddRCT ft, 'b3b' , '%-12C'
call fTabAddRCT ft, 'd4' , '%10C'
call fTabAddRCT ft, 'fl5' , '%8.3I'
call fTabAddRCT ft, 'ex6' , '%7e'
call fTab ft
call pipe '-'
call tstEnd t
return
endProcedure tstFTab
tstCSV: procedure expose m.
/*
$=/tstCSV/
### start tst tstCSV ##############################################
value,value eins,value zwei
value,"value, , eins",value zwei
value,"","value ""zwei"" oder?"
value,,"value ""zwei"" oder?"
$/tstCSV/ */
m.tstCsv.c.1 = ''
m.tstCsv.c.2 = .eins
m.tstCsv.c.3 = .zwei
m.tstCsv.c.0 = 3
call tst t, "tstCSV"
m.tstCsv.o = 'value'
m.tstCsv.o.eins = 'value eins'
m.tstCsv.o.zwei = 'value zwei'
call tstOut t, csv4Obj(tstCsv'.'o, tstCsv'.'c, 0)
m.tstCsv.o.eins = 'value, , eins'
call tstOut t, csv4Obj(tstCsv'.'o, tstCsv'.'c, 0)
m.tstCsv.o.eins = ''
m.tstCsv.o.zwei = 'value "zwei" oder?'
call tstOut t, csv4Obj(tstCsv'.'o, tstCsv'.'c, 0)
m.tstCsv.o.eins = '---'
call tstOut t, csv4Obj(tstCsv'.'o, tstCsv'.'c, 1, '---')
call tstEnd t
return
endProcedure tstCSV
tstCSV2: procedure expose m.
/*
$=/tstCSV2/
### start tst tstCSV2 #############################################
w: ¢f1=1 fZwei=eins fDr=r!
w: ¢f1=2 fZwei= zwei , 2 fDr=!
w: ¢f1=3 fZwei=schluss fDr=!
W: ¢F1=1 FZWEI=eins FDR=r!
W: ¢F1=2 FZWEI= zwei , 2 FDR=!
W: ¢F1=3 FZWEI=schluss FDR=!
c: ¢f1=1 fComma=eins fDr=r!
c: ¢f1= 2 fComma= zwei , 2 fDr=!
c: ¢f1=3 fComma=schluss fDr=!
C: ¢F1=1 FCOMMA=eins FDR=r!
C: ¢F1= 2 FCOMMA= zwei , 2 FDR=!
C: ¢F1=3 FCOMMA=schluss FDR=!
o: ¢f1=1 fCol=eins fDr=drei fVie=und vier!
o: ¢f1=222222Z fCol=ccccccccC fDr=dddddddD fVie=vvvvvvvvvvvvvv V!
o: ¢f1=3 fCol=schluss fDr=drei fVie=vier!
O: ¢F1=1 FCOL=eins FDR=drei FVIE=und vier!
O: ¢F1=222222Z FCOL=ccccccccC FDR=dddddddD FVIE=vvvvvvvvvvvvvv V!
O: ¢F1=3 FCOL=schluss FDR=drei FVIE=vier!
$/tstCSV2/
*/
call csvIni
call tst t, "tstCSV2"
b = jBuf(' f1 fZwei fDr ', '1 eins r', ' 2 " zwei , 2 "',
, '3 schluss')
call tstCsv22 t, 'w', csvWordRdr(b)
call tstCsv22 t, 'W', csvWordRdr(b, 'u')
b = jBuf(' f1 , fComma, fDr ', '1,eins,r', ' 2 ," zwei , 2 "',
, '3,schluss')
call tstCsv22 t, 'c', csvRdr(b)
call tstCsv22 t, 'C', csvRdr(b, 'u')
b = jBuf(' > f1 >< fCol <fDr fVie',
,' 1eins drei und vier ',
,'222222ZccccccccCdddddddDvvvvvvvvvvvvvv V',
,' 3 schluss dreivier')
call tstCsv22 t, 'o', csvColRdr(b)
call tstCsv22 t, 'O', csvColRdr(b, 'u')
call tstEnd t
return
endProcedure tstCSV2
tstCSV22: procedure expose m.
parse arg t, l, c
call jOpen c, '<'
do while jRead(c)
call tstOut t, l':' o2TexLR(m.c, , '¢', '!')
end
call jCLose c
return
endProcedure tstCSV22
tstCSVExt: procedure expose m.
/*
$=/tstCSVExt/
### start tst tstCSVExt ###########################################
c,classCF,f FEINS v,f FZWEI v
o classCF,F1,f1Feins,"f1,fzwei "
c,classCG,f gDrei v,f GVIER v,f gRef r
d classCG,objG4,objG4gDrei,objG4.gVier,objG4
d classCG,objG3,,objG3.gVier,objG4
o classCG,G2,g2gDrei,,objG3
c,classCH,v,f rr r,f rH r
d classCH,H9,H9value,objG3,H5
d classCH,H8,H8value rrWText,!escText,H9
d classCH,H7,H7value rrText,!textli,H8
d classCH,h6,h6-value6 rrLeer,,H7
o classCH,H5,h5Value,F1,h6
r,G2
$/tstCSVExt/ */
call jIni
if symbol('m.tstCsvExt') == 'VAR' then
m.tstCsvExt = m.tstCsvExt + 1
else
m.tstCsvExt = 1
ee = 'ee'm.tstCsvExt
cF = classNew('n? TstCsvExtF u f FEINS v, f FZWEI v')
cG = classNew('n? TstCsvExtG u f gDrei v, f GVIER v, f gRef r')
cH = classNew('n? TstCsvExtH u v, f rr r, f rH r')
call tst t, "tstCSVExt"
call mAdd t'.'trans, cF 'classCF', cG 'classCG', cH 'classCH'
call csvExtReset ee, t
call csvExtWrite ee, csv2o(f1, cF, 'f1Feins,"f1,fzwei "')
call csvExtWrite ee, csv2o(g2, cG, 'g2gDrei,',
|| ','csv2o('objG3', cG, ',objG3.gVier',
|| ','csv2o('objG4', cG, 'objG4gDrei,objG4.gVier,objG4')))
call csvExtWrite ee, csv2o(h5, cH, 'h5Value,F1',
|| ','csv2o('h6', cH, 'h6-value6 rrLeer,',
|| ','csv2o(h7, cH, 'H7value rrText,textli',
|| ','csv2o(h8, cH, 'H8value rrWText,!escText',
|| ','csv2o(h9, cH, 'H9value,objG3,H5')))))
call csvExtWrite ee, g2
call tstEnd t
return
endProcedure tstCSVExt
tstfUnits: procedure
/*
$=/tstfUnits/
### start tst tstfUnits ###########################################
. 1 ==> 1 =-> -1 =+> +1 =b> 1 .
. 5 ==> 5 =-> -5 =+> +5 =b> 5 .
. 13 ==> 13 =-> -13 =+> +13 =b> 13 .
. 144 ==> 144 =-> -144 =+> +144 =b> 144 .
. 1234 ==> 1234 =-> -1k =+> +1234 =b> 1234 .
. 7890 ==> 7890 =-> -8k =+> +7890 =b> 7890 .
. 0 ==> 0 =-> 0 =+> +0 =b> 0 .
. 234E3 ==> 234k =-> -234k =+> +234k =b> 229k
. 89E6 ==> 89M =-> -89M =+> +89M =b> 85M
. 123E9 ==> 123G =-> -123G =+> +123G =b> 115G
. 4567891E9 ==> 4568T =-> -5P =+> +4568T =b> 4154T
. 0.123 ==> 123m =-> -123m =+> +123m =b> 0 .
. 0.0000456789 ==> 46u =-> -46u =+> +46u =b> 0 .
. 345.567E-12 ==> 346p =-> -346p =+> +346p =b> 0 .
. 123.4567E-15 ==> 123f =-> -123f =+> +123f =b> 0 .
. ABC ==> ABC =-> -ABC =+> ABC =b> ABC
ABCDEFGHIJKLMN ==> JKLMN =-> JKLMN =+> IJKLMN =b> JKLMN
. 1E77 ==> +++++ =-> -++++ =+> ++++++ =b> +++++.
. 1E-77 ==> 0f =-> -0f =+> +0f =b> 0 .
. 18.543E18 ==> 19E =-> -19E =+> +19E =b> 16E
. 20.987E20 ==> 2099E =-> -++++ =+> +2099E =b> 1820E
. 1 ==> 1.000 =-> -1.000 =+> +1.000 =b> 1.000 .
. 5 ==> 5.000 =-> -5.000 =+> +5.000 =b> 5.000 .
. 13 ==> 13.000 =-> -0.013k =+> +0.013k =b> 13.000 .
. 144 ==> 0.144k =-> -0.144k =+> +0.144k =b> 0.141k
. 1234 ==> 1.234k =-> -1.234k =+> +1.234k =b> 1.205k
. 7890 ==> 7.890k =-> -7.890k =+> +7.890k =b> 7.705k
. 0 ==> 0.000 =-> 0.000 =+> +0.000 =b> 0.000 .
. 234E3 ==> 0.234M =-> -0.234M =+> +0.234M =b> 0.223M
. 89E6 ==> 89.000M =-> -0.089G =+> +0.089G =b> 84.877M
. 123E9 ==> 0.123T =-> -0.123T =+> +0.123T =b> 0.112T
. 4567891E9 ==> 4.568P =-> -4.568P =+> +4.568P =b> 4.057P
. 0.123 ==> 0.123 =-> -0.123 =+> +0.123 =b> 0.123 .
. 0.0000456789 ==> 45.679u =-> -0.046m =+> +0.046m =b> 0.000 .
. 345.567E-12 ==> 0.346n =-> -0.346n =+> +0.346n =b> 0.000 .
. 123.4567E-15 ==> 0.123p =-> -0.123p =+> +0.123p =b> 0.000 .
. ABC ==> ABC =-> -ABC =+> ABC =b> ABC
ABCDEFGHIJKLMN ==> HIJKLMN =-> HIJKLMN =+> HIJKLMN =b> HIJKLMN
. 1E77 ==> +++++++ =-> -++++++ =+> +++++++ =b> +++++++.
. 1E-77 ==> 0.000f =-> -0.000f =+> +0.000f =b> 0.000 .
. 18.543E18 ==> 18.543E =-> -19E =+> +19E =b> 16.083E
. 20.987E20 ==> 2099E =-> -2099E =+> +2099E =b> 1820E
$/tstfUnits/
$=/tstfUnitst/
### start tst tstfUnitst ##########################################
. .3 ==> 0s30 ++> 0s30 -+> -0s30 --> -0s30
. .8 ==> 0s80 ++> 0s80 -+> -0s80 --> -0s80
. 1 ==> 1s00 ++> 1s00 -+> -1s00 --> -1s00
. 1.2 ==> 1s20 ++> 1s20 -+> -1s20 --> -1s20
. 59 ==> 59s00 ++> 59s00 -+> -0m59 --> -59s00
. 59.07 ==> 59s07 ++> 59s07 -+> -0m59 --> -59s07
. 59.997 ==> 1m00 ++> 1m00 -+> -1m00 --> -1m00
. 60 ==> 1m00 ++> 1m00 -+> -1m00 --> -1m00
. 60.1 ==> 1m00 ++> 1m00 -+> -1m00 --> -1m00
. 611 ==> 10m11 ++> 10m11 -+> -0h10 --> -10m11
. 3599.4 ==> 59m59 ++> 59m59 -+> -1h00 --> -59m59
. 3599.5 ==> 1h00 ++> 1h00 -+> -1h00 --> -1h00
. 3661 ==> 1h01 ++> 1h01 -+> -1h01 --> -1h01
. 83400 ==> 23h10 ++> 23h10 -+> -0d23 --> -23h10
. 84700 ==> 23h32 ++> 23h32 -+> -1d00 --> -23h32
. 86400 ==> 1d00 ++> 1d00 -+> -1d00 --> -1d00
. 89900 ==> 1d01 ++> 1d01 -+> -1d01 --> -1d01
. 8467200 ==> 98d00 ++> 98d00 -+> -98d --> -98d00
. 8595936.00 ==> 99d12 ++> 99d12 -+> -99d --> -99d12
. 8638704.00 ==> 100d ++> 100d -+> -100d --> -100d
. 8640000 ==> 100d ++> 100d -+> -100d --> -100d
. 863913600 ==> 9999d ++> 9999d -+> -++++ --> -9999d
. 863965440 ==> +++++ ++> +++++ -+> -++++ --> -+++++.
. 8.6400E+9 ==> +++++ ++> +++++ -+> -++++ --> -+++++.
$/tstfUnitst/ */
call jIni
call tst t, "tstfUnits"
numeric digits 9
d = 86400
lst = 1 5 13 144 1234 7890 0 234e3 89e6 123e9,
4567891e9 0.123 0.0000456789 345.567e-12 123.4567e-15 ,
abc abcdefghijklmn 1e77 1e-77 18.543e18 20.987e20
do wx=1 to words(lst)
call tstOut t, right(word(lst, wx), 14) ,
'==>' fUnits( word(lst, wx), 'd') ,
'=->' fUnits( '-'word(lst, wx), 'd') ,
'=+>' fUnits( word(lst, wx), 'd', , , '+'),
'=b>' fUnits( word(lst, wx), 'b')
end
do wx=1 to words(lst)
call tstOut t, right(word(lst, wx), 14) ,
'==>' fUnits( word(lst, wx), 'd', 7, 3) ,
'=->' fUnits( '-'word(lst, wx), 'd', 7, 3) ,
'=+>' fUnits( word(lst, wx), 'd', 7, 3, '+'),
'=b>' fUnits( word(lst, wx), 'b', 7, 3)
end
call tstEnd t
call tst t, "tstfUnitst"
d = 86400
lst = .3 .8 1 1.2 59 59.07 59.997 60 60.1 611 ,
3599.4 3599.5 3661 d-3000 d-1700 d d+3500 ,
d * 98 d * 99.49 d * 99.985 d*100 d * 9999 d * 9999.6 ,
d * 1e5
do wx=1 to words(lst)
call tstOut t, right(word(lst, wx), 14) ,
'==>' fUnits( word(lst, wx), 't' ) ,
'++>' fUnits( word(lst, wx), 't', , , ' '),
'-+>' fUnits('-'word(lst, wx), 't' ),
'-->' fUnits('-'word(lst, wx), 't', , , ' ')
end
call tstEnd t
return
endProcedure tstfUnits
tstSb: procedure expose m.
/*
$=/tstSb/
### start tst tstSb ###############################################
end : 0
char 3 : 1 abc
lit d? : 0 .
lit de : 1 de
lit de ? fg fgh: 1 fg
while HIJ : 0 .
end : 0
while Jih : 1 hi
while ? klj: 1 jklkl ?
end : 1
while ? klj: 0 .
char 3 : 0 .
lit : 0 .
until cba : 0 .
until ?qd : 1 abc
until ?qr : 1 defdef .
until ?qr : 0 .
strEnd ? : 1 ?
strEnd ? : 0 ?
strEnd ? : 1 ab??cd????gh?
strEnd ") ": 1 ab) .
strEnd ") ": 1 ab) cd) ) gh) .
string : 1 'eins?''' v=eins?'
space : 1 >
string : 1 "zwei""" v=zwei"
string ? : 1 ?drei??? v=drei?
*** err: scanErr ending Apostroph missing
. e 1: last token " scanPosition noEnd
. e 2: pos 28 in string 'eins?''' "zwei"""?drei???"noEnd
string : 0 " v=noEnd
$/tstSb/ */
call pipeIni
call tst t, 'tstSb'
call scanSrc s, 'abcdefghijklkl ?'
call out 'end :' scanEnd(s)
call out 'char 3 :' scanChar(s, 3) m.s.tok
call out 'lit d? :' scanLit(s, 'd?') m.s.tok
call out 'lit de :' scanLit(s, 'de') m.s.tok
call out 'lit de ? fg fgh:',
scanLit(s, 'de', '?', 'fg', 'fgh') m.s.tok
call out 'while HIJ :' scanWhile(s, 'HIJ') m.s.tok
call out 'end :' scanEnd(s)
call out 'while Jih :' scanWhile(s, 'Jih') m.s.tok
call out 'while ? klj:' scanWhile(s, '? klj') m.s.tok
call out 'end :' scanEnd(s)
call out 'while ? klj:' scanWhile(s, '? klj') m.s.tok
call out 'char 3 :' scanChar(s, 3) m.s.tok
call out 'lit :' scanLit(s) m.s.tok
call scanSrc s, 'abcdefdef ?'
call out 'until cba :' scanUntil(s, 'cba') m.s.tok
call out 'until ?qd :' scanUntil(s, '?qd') m.s.tok
call out 'until ?qr :' scanUntil(s, '?qr') m.s.tok
call out 'until ?qr :' scanUntil(s, '?qr') m.s.tok
call out 'strEnd ? :' scanStrEnd(s, '?') m.s.tok
call out 'strEnd ? :' scanStrEnd(s, '?') m.s.tok
call scanSrc s, 'ab??cd????gh?ijk'
call out 'strEnd ? :' scanStrEnd(s, '?') m.s.tok
call scanSrc s, 'ab) cd) ) gh) jk) )'
call out 'strEnd ") ":' scanStrEnd(s, ') ') m.s.tok
call out 'strEnd ") ":' scanStrEnd(s, ') ') m.s.tok
call scanSrc s, "'eins?'''" '"zwei"""?drei???"noEnd'
call out 'string :' scanString(s) m.s.tok 'v='m.s.val
call out 'space :' scanWhile(s, ' ') m.s.tok'>'
call out 'string :' scanString(s) m.s.tok 'v='m.s.val
call out 'string ? :' scanString(s, '?') m.s.tok 'v='m.s.val
call out 'string :' scanString(s) m.s.tok 'v='m.s.val
call tstEnd t
return
endProcedure tstSb
tstSb2: procedure expose m.
/*
$=/tstSb2/
### start tst tstSb2 ##############################################
end : 0
char 3 : 1 abc
lit d? : 0 .
lit de : 1 de
lit de ? fg fgh: 1 fg
while HIJ : 0 .
end : 0
while Jih : 1 hi
while ? klj: 1 jklkl ?
end : 1
while ? klj: 0 .
char 3 : 0 .
lit : 0 .
until cba : 0 .
until ?qd : 1 abc
until ?qr : 1 defdef .
until ?qr : 0 .
strEnd ? : 1 ?
strEnd ? : 0 ?
strEnd ? : 1 ab??cd????gh?
strEnd ") ": 1 ab) .
strEnd ") ": 1 ab) cd) ) gh) .
$/tstSb2/ */
call pipeIni
call tst t, 'tstSb2'
call scanSrc s, 'abcdefghijklkl ?'
call out 'end :' scanEnd(s)
call out 'char 3 :' scanChar(s, 3) m.s.tok
call out 'lit d? :' scanLit(s, 'd?') m.s.tok
call out 'lit de :' scanLit(s, 'de') m.s.tok
call out 'lit de ? fg fgh:',
scanLit(s, 'de', '?', 'fg', 'fgh') m.s.tok
call out 'while HIJ :' scanWhile(s, 'HIJ') m.s.tok
call out 'end :' scanEnd(s)
call out 'while Jih :' scanWhile(s, 'Jih') m.s.tok
call out 'while ? klj:' scanWhile(s, '? klj') m.s.tok
call out 'end :' scanEnd(s)
call out 'while ? klj:' scanWhile(s, '? klj') m.s.tok
call out 'char 3 :' scanChar(s, 3) m.s.tok
call out 'lit :' scanLit(s) m.s.tok
call scanSrc s, 'abcdefdef ?'
call out 'until cba :' scanUntil(s, 'cba') m.s.tok
call out 'until ?qd :' scanUntil(s, '?qd') m.s.tok
call out 'until ?qr :' scanUntil(s, '?qr') m.s.tok
call out 'until ?qr :' scanUntil(s, '?qr') m.s.tok
call out 'strEnd ? :' scanStrEnd(s, '?') m.s.tok
call out 'strEnd ? :' scanStrEnd(s, '?') m.s.tok
call scanSrc s, 'ab??cd????gh?ijk'
call out 'strEnd ? :' scanStrEnd(s, '?') m.s.tok
call scanSrc s, 'ab) cd) ) gh) jk) )'
call out 'strEnd ") ":' scanStrEnd(s, ') ') m.s.tok
call out 'strEnd ") ":' scanStrEnd(s, ') ') m.s.tok
call tstEnd t
return
endProcedure tstSb2
tstScan: procedure expose m.
/*
$=/tstScan.1/
### start tst tstScan.1 ###########################################
scan src a034,Und hr123sdfER"st1" 'str2''mit''apo''s' .
scan n tok 4: a034 key val .
scan , tok 1: , key val .
scan n tok 3: Und key val .
scan v tok 1: key val .
scan n tok 10: hr123sdfER key val .
scan q tok 5: "st1" key val st1
scan v tok 1: key val st1
scan a tok 19: 'str2''mit''apo''s' key val str2'mit'apo's
scan v tok 1: key val str2'mit'apo's
$/tstScan.1/ */
call tst t, 'tstScan.1'
call tstScan1 'l"litEins"l"litZwei"ndv" "aq1' ,
,"a034,Und hr123sdfER""st1"" 'str2''mit''apo''s' "
call tstEnd t
/*
$=/tstScan.2/
### start tst tstScan.2 ###########################################
scan src a034,Und hr123sdfER"st1" 'str2''mit''apo''s' .
scan n tok 4: a034 key val .
scan , tok 1: , key val .
scan n tok 3: Und key val .
scan b tok 1: key val .
scan n tok 10: hr123sdfER key val .
scan " tok 5: "st1" key val st1
scan b tok 1: key val st1
scan ' tok 19: 'str2''mit''apo''s' key val str2'mit'apo's
scan b tok 1: key val str2'mit'apo's
$/tstScan.2/ */
call tst t, 'tstScan.2'
call tstScan1 'ndsb1' ,
,"a034,Und hr123sdfER""st1"" 'str2''mit''apo''s' "
call tstEnd t
/*
$=/tstScan.3/
### start tst tstScan.3 ###########################################
scan src a034,'wie 789abc
scan n tok 4: a034 key val .
scan , tok 1: , key val .
*** err: scanErr ending Apostroph missing
. e 1: last token ' scanPosition wie 789abc
. e 2: pos 7 in string a034,'wie 789abc
scan w tok 1: w key val wie 789abc
scan n tok 2: ie key val wie 789abc
scan s tok 1: key val wie 789abc
*** err: scanErr illegal char after number 789
. e 1: last token 789 scanPosition abc
. e 2: pos 14 in string a034,'wie 789abc
scan d tok 3: 789 key val wie 789abc
scan n tok 3: abc key val wie 789abc
$/tstScan.3/ */
call tst t, 'tstScan.3'
call tstScan1 'nds1' ,
,"a034,'wie 789abc"
call tstEnd t
/*
$=/tstScan.4/
### start tst tstScan.4 ###########################################
scan src litEinsefr 23 sdfER'str1'litZwei "str2""mit quo"s .
scan l tok 7: litEins key val .
scan n tok 3: efr key val .
scan b tok 1: key val .
scan d tok 2: 23 key val .
scan b tok 1: key val .
scan n tok 5: sdfER key val .
scan a tok 6: 'str1' key val str1
scan l tok 7: litZwei key val str1
scan b tok 1: key val str1
scan q tok 15: "str2""mit quo" key val str2"mit quo
scan n tok 1: s key val str2"mit quo
scan b tok 1: key val str2"mit quo
$/tstScan.4/ */
call tst t, 'tstScan.4'
call tstScan1 'l"litEins"l"litZwei"ndbaq1' ,
,"litEinsefr 23 sdfER'str1'litZwei ""str2""""mit quo""s "
call tstEnd t
/*
$=/tstScan.5/
### start tst tstScan.5 ###########################################
scan src aha q3 = f ab=cdEf eF='strIng' .
scan s tok 1: key val .
scan k tok 0: key aha val def
scan k tok 1: f key q3 val f
scan s tok 1: key q3 val f
scan k tok 4: cdEf key ab val cdEf
scan s tok 1: key ab val cdEf
scan k tok 8: 'strIng' key eF val strIng
scan s tok 1: key eF val strIng
$/tstScan.5/ */
call tst t, 'tstScan.5'
call tstScan1 'k1'," aha q3 = f ab=cdEf eF='strIng' "
call tstEnd t
return
endProcedure tstScan
/*--- one single test scan with lines to scan in stem ln -------------*/
tstScan1:
parse arg classs, ln
call tstOut t, 'scan src' ln
call scanSrc scanOpt(s), ln
m.s.key = ''
m.s.val = ''
do forever
x = tstScanType(s, classs)
if x == '' then
leave
call tstOut t, 'scan' x 'tok' length(m.s.tok)':' m.s.tok ,
'key' m.s.key 'val' m.s.val
end
return
endProcedure tstScan1
tstScanType: procedure expose m.
parse arg s, opt
cx = 1
a2 = ''
res = 0
do while cx <= length(opt)
f = substr(opt, cx, 1)
cx = cx + 1
if pos(substr(opt, cx, 1), "'""") > 0 then do
m.tstScanType.src = opt
m.tstScanType.pos = cx
call scanString tstScanType
a2 = m.tstScanType.val
cx = m.tstScanType.pos
end
if f == 'a' then
res = scanString(s, "'")
else if f == 'b' then
res = scanSpace(s)
else if f == 'c' then
res = scanChar(s, a2)
else if f == 'd' then
if a2 == 0 then
res = scanNatIA(s)
else
res = scanNat(s)
else if f == 'k' then
res = scanKeyValue(s, 'def')
else if f == 'l' then
res = scanLit(s, a2)
else if f == 'q' then
res = scanString(s, '"')
else if f == 'v' then
res = scanVerify(s, a2)
else if f == 'w' then
res = scanWord(s)
else if f == 'y' then
res = scanVerify(s, a2, 'm')
if res then
return f
end
return scanType(s)
endProcedure tstScanType
tstScanRead: procedure expose m.
/*
$=/tstScanRead/
### start tst tstScanRead #########################################
name erste
space
name Zeile
space
nextLine
nextLine
space
name dritte
space
name Zeile
space
name schluss
space
$/tstScanRead/ */
call scanReadIni
call tst t, 'tstScanRead'
b = jBuf('erste Zeile ',,' dritte Zeile schluss ')
s = jOpen(jReset0(scanRead(b)), m.j.cRead)
do while \scanEnd(s)
if scanName(s) then call tstOut t, 'name' m.s.tok
else if scanVerify(s, ' ') then call tstOut t, 'space'
else if scanReadNL(s) then call tstOut t, 'nextLine'
else if \scanEnd(s) then call scanErr s, 'cannot scan'
end
call jClose s
call tstEnd t
/*
$=/tstScanReadMitSpaceLn/
### start tst tstScanReadMitSpaceLn ###############################
name erste
spaceLn
name Zeile
spaceLn
name dritte
spaceLn
name Zeile
spaceLn
name schluss
spaceLn
$/tstScanReadMitSpaceLn/ */
call tst t, 'tstScanReadMitSpaceLn'
s = scanReadOpen(scanRead(b))
do forever
if scanName(s) then call out 'name' m.s.tok
else if scanSpace(s) then call out 'spaceLn'
else if \scanEnd(s) then call scanErr s, 'cannot scan'
else leave
end
call scanReadClose s
call tstEnd t
/*
$=/tstScanJRead/
### start tst tstScanJRead ########################################
1 jRead n tok erste val .
2 jRead s tok val .
3 jRead n tok Zeile val .
4 jRead s tok val .
5 jRead n tok dritte val .
6 jRead s tok val .
7 jRead n tok Zeile val .
8 jRead s tok val .
9 jRead n tok schluss val .
10 jRead s tok val .
11 jRead 0 tok 1 val 1
12 jRead s tok val 1
13 jRead + tok + val 1
14 jRead s tok val 1
15 jRead 0 tok 2. val 2..
16 jRead s tok val 2..
17 jRead + tok + val 2..
18 jRead . tok . val 2..
19 jRead s tok val 2..
20 jRead 0 tok +.3 val +.3
21 jRead 0 tok -45e-3 val -45E-3
22 jRead s tok val -45E-3
23 jRead " tok "a""b" val a"b
24 jRead s tok val a"b
25 jRead ' tok 'c''d' val c'd
className 1: ScanRes 18: ScanRes
$/tstScanJRead/ */
call tst t, 'tstScanJRead'
call jWrite jOpen(b,'>>'), '1 + 2. +. +.3-45e-3 "a""b"' "'c''d'"
s = jOpen(jReset0(scanRead(jClose(b))), '<')
do x=1 while jRead(s)
v = m.s
call out x 'jRead' m.v.type 'tok' m.v.tok 'val' m.v.val
v.x = v
end
call jClose s
call out 'className 1:' className(objClass(v.1)),
'18:' className(objClass(v.18))
call tstEnd t
/*
$=/tstScanReadPos/
### start tst tstScanReadPos ######################################
1
2
345678
4
5678
4
$/tstScanReadPos/ */
call tst t, 'tstScanReadPos'
b = jBuf(1, 2, 345678, 4)
call scanReadOpen scanReadReset(scanOpt(tstScn), b)
do while scanNat(scanSkip(tstScn))
call tstOut t, m.tstScn.tok
end
call scanSetPos tstScn, 3 3
do while scanNat(scanSkip(tstScn))
call tstOut t, m.tstScn.tok
end
call tstEnd t
return
endProcedure tstScanRead
tstScanUtilInto: procedure expose m.
/*
$=/tstScanUtilIntoL/
TEMPLATE P3
DSN('DBAF.DA540769.A802A.P00003.BV5I3NRN.REC')
DISP(OLD,KEEP,KEEP)
TEMPLATE P4
DSN('DBAF.DA540769.A802A.P00004.BV5I3NTK.REC')
DISP(OLD,KEEP,KEEP)
LOAD DATA LOG NO RESUME NO REPLACE COPYDDN(TCOPYD)
STATISTICS INDEX(ALL) REPORT NO UPDATE ALL
EBCDIC CCSID(00500,00000,00000)
SORTKEYS
-- ENFORCE NO
SORTDEVT DISK
SORTNUM 160
WORKDDN(TSYUTD,TSOUTD)
INTO TABLE OA1P.TWB981 PART 1 INDDN TREC134
WORKDDN(TSYUTS,TSOUTS)
INTO TABLE "A540769"
."TWK802A1"
PART 00001 INDDN P0
WHEN(00001:00002) = X'0041'
( "DE1"
POSITION( 00003:00010) DECIMAL
, "CH2"
POSITION( 00011:00015) CHAR(00005)
, "TS3"
POSITION( 00016:00041) TIMESTAMP EXTERNAL
, "TI4"
POSITION( 00042:00049) TIME EXTERNAL
, "DA5"
POSITION( 00050:00059) DATE EXTERNAL
, "IN6"
POSITION( 00060:00063) INTEGER
, "RE7"
POSITION( 00064:00067) FLOAT(21)
)
INTO TABLE "A540769"."TWK802A1"
PART 00002 INDDN P0
WHEN(00001:00002) = X'0041'
( "DE1"
POSITION( 00003:00010) DECIMAL
, "CH2"
POSITION( 00011:00015) CHAR(00005)
)
dobido
$/tstScanUtilIntoL/
$=/tstScanUtilInto/
### start tst tstScanUtilInto #####################################
-- 1 scanUtilInto
. ( "DE1"
. POSITION( 00003:00010) DECIMAL
. , "CH2"
. POSITION( 00011:00015) CHAR(00005)
. , "TS3"
. POSITION( 00016:00041) TIMESTAMP EXTERNAL
. , "TI4"
. POSITION( 00042:00049) TIME EXTERNAL
. , "DA5"
. POSITION( 00050:00059) DATE EXTERNAL
. , "IN6"
. POSITION( 00060:00063) INTEGER
. , "RE7"
. POSITION( 00064:00067) FLOAT(21)
. ) .
. -- table OA1P.TWB981 part 00001
-- 2 scanUtilInto
. ( "DE1"
. POSITION( 00003:00010) DECIMAL
. , "CH2"
. POSITION( 00011:00015) CHAR(00005)
. ) .
. -- table A540769.TWK802A1 part 00002
-- 3 scanUtilInto
$/tstScanUtilInto/ */
call scanReadIni
b = jBuf()
call mAddst b'.BUF', mapInline('tstScanUtilIntoL')
call tst t, 'tstScanUtilInto'
s = jOpen(jReset0(scanUtilOpt(ScanRead(b))), '<')
do ix=1
call out '--' ix 'scanUtilInto'
if \ scanUtilInto(s) then
leave
call out ' -- table' m.s.tb 'part' m.s.part
end
call tstEnd t
return
endProcedure tstSCanUtilInto
tstScanWin: procedure expose m.
/*
$=/tstScanWin/
### start tst tstScanWin ##########################################
info 0: last token scanPosition erste Zeile dr+
itteZe\npos 1 in line 1: erste Zeile
name erste
spaceNL
name Zeile
spaceNL
name dritteZeeeile
info 5: last token dritteZeeeile scanPosition zeile4 +
. fuenfueberSechs\npos 1 in line 4: zeile4
spaceNL
name zeile4
spaceNL
name fuenfueberSechsUnddSiebenUNDundUndUAcht
spaceNL
info 10: last token scanPosition undZehnueberElfundNochWeiterZwoe+
lfundim1\npos 9 in line 10: undZehn
name undZehnueberElfundNochWeiterZwoelfundim13
spaceNL
name Punkt
infoE 14: last token Punkt scanPosition \natEnd after line 13: im13+
. Punkt
$/tstScanWin/ */
call scanWinIni
call tst t, 'tstScanWin'
b = jBuf('?erste Zeile?',,'? dritteZeeeile?', '? zeile4 ',
,'? fuenf?', '?ueberSechsUnddS?', '?iebenUNDundUndU?',
,'?Acht ?', '? ?', '? undZehn?',
,'?ueberElfundNoch?', '?WeiterZwoelfund?', '?im13 Punkt?')
s = jOpen(jReset0(scanWin(b, '15@2')), m.j.cRead)
call tstOut t, 'info 0:' scanInfo(s)
do sx=1 while \scanEnd(s)
if scanSpace(s) then call tstOut t, 'spaceNL'
else if scanName(s) then call tstOut t, 'name' m.s.tok
else if \scanEnd(s) then call scanErr s, 'cannot scan'
if sx // 5 = 0 then
call tstOut t, 'info' sx':' scanInfo(s)
end
call tstOut t, 'infoE' sx':' scanInfo(s)
call tstEnd t
/*
$=/tstScanWinRead/
### start tst tstScanWinRead ######################################
info 0: last token scanPosition erste Zeile z3 +
com Ze\npos 1 in line 1: erste Zeile
name erste
spaceNL
name Zeile
spaceNL
name z3
info 5: last token z3 scanPosition com Zeeeile z4 come4 f+
uenf\npos 4 in line 3: z3 com Zeeeile
spaceNL
name z4
spaceNL
name fuenf
spaceNL
info 10: last token scanPosition com Sechs com sieben comA+
cht com\npos 15 in line 5: fuenf c
name com
spaceNL
name Sechs
spaceNL
name com
info 15: last token com scanPosition sieben comAcht com com +
. com\npos 2 in line 7: m sieben com
spaceNL
name sieben
spaceNL
name Acht
spaceNL
info 20: last token scanPosition ueberElfundNochWeit com elfundim+
13\npos 1 in line 11: ueberElfundNoch
name ueberElfundNochWeit
spaceNL
name im13
spaceNL
name Punkt
info 25: last token Punkt scanPosition \natEnd after line 13: im13 +
. Punkt
infoE 26: last token Punkt scanPosition \natEnd after line 13: im13+
. Punkt
$/tstScanWinRead/ */
call tst t, 'tstScanWinRead'
b = jBuf('?erste Zeile?',,'? z3 com Zeeeile?', '? z4 come4 ',
,'? fuenf c?', '?om Sechs co?', '?m sieben com?',
,'?Acht com com ?', '? com ?', '? com undZehn?',
,'?ueberElfundNoch?', '?Weit com elfund?', '?im13 Punkt?')
s = jReset0(scanWin(b, '15@2'))
call scanOpt s, , , 'com'
call tstOut t, 'info 0:' scanInfo(jOpen(s, m.j.cRead))
do sx=1 while \scanEnd(s)
if scanName(s) then call tstOut t, 'name' m.s.tok
else if scanSpace(s) then call tstOut t, 'spaceNL'
else if \scanEnd(s) then call scanErr s, 'cannot scan'
if sx // 5 = 0 then
call tstOut t, 'info' sx':' scanInfo(s)
end
call tstOut t, 'infoE' sx':' scanInfo(s)
call tstEnd t
/*
$=/tstScanWinPos/
### start tst tstScanWinPos #######################################
infoA1 1: last token 1 scanPosition 2 +
. 3\npos 2 in line 1: 1
1
2
345678
4
infoB1: last token scanPosition \natEnd after line 4: 4
infoC1: last token scanPosition 678 4\npos 4 in line+
. 3: 345678
678
4
infoA0 1: last token -2 scanPosition -1 -0 1 +
. 2\npos 3 in line -2: -2
-2
-1
-0
1
2
345678
4
infoB0: last token scanPosition \natEnd after line 4: 4
infoC0: last token scanPosition 5678 4\npos 3 in line 3: 345678
5678
4
$/tstScanWinPos/ */
call tst t, 'tstScanWinPos'
b = jBuf(1, 2, 345678, 4)
do ox=1 to 0 by -1
if ox then
s = scanWinOpen(scanWinReset(scanOpt(tstScn), b, 20))
else
s = scanWinOpen(scanWinReset(scanOpt(tstScn), b, 10),
,'-2 -1 -0')
do nx=1 while scanNum(scanSkip(s))
if nx = 1 then
call tstOut t, 'infoA'ox nx':' scanInfo(s)
call tstOut t, m.s.tok
end
call tstOut t, 'infoB'ox':' scanInfo(s)
call scanSetPos s, 3 3+ox
call tstOut t, 'infoC'ox':' scanInfo(s)
do while scanNat(scanSkip(s))
call tstOut t, m.s.tok
end
call scanClose s
end
call tstEnd t
return
endProcedure tstScanWin
tstScanSqlStmt: procedure expose m.
/*
$=/tstScanSqlStmt/
### start tst tstScanSqlStmt ######################################
cmd1 select current time stamp from s.1
cmd2 update ";--""'/*"
cmd3 delete '*/''"' / 3 - 1
cmd4 terminator test
cmd5 und so
cmd6 term: ist
cmd7 term> in com nein >
cmd8 .
$/tstScanSqlStmt/ */
call pipeIni
call scanWinIni
call tst t, 'tstScanSqlStmt'
b = jBuf('select -- /* c1', ' /* c1 */ current/* c2 " '' ',
,'c3"', ' c4 */time', 'stamp-- c5', 'from s.1; /* c6 */ ;' ,
,';update ";--""''/*";; del123',
, 'ete ''*/''''"'' / 3 - 1 -- c7', '/*c8 */ ' ,
, ';terminator test; ','terminator|; und-- ', 'so| | |',
, 'term: --#SET TERMINATOR : oder', 'ist: ',
, 'term> /*--#SET TERMINATOR > oder', ' */ in com nein >:')
call scanWinOpen scanSqlStmtOpt(scanWinReset(tstJcat, b, 30), ';')
call scanSqlOpt tstJcat
do sx=1 until nx = ''
nx = scanSqlStmt(tstJCat)
call tstOut t, 'cmd'sx nx
end
call scanReadCLose tstJCat
call tstEnd t
/*
$=/tstScanSqlStmtRdr/
### start tst tstScanSqlStmtRdr ###################################
cmd1 select current time stamp from s.1
cmd2 update ";--""'/*"
cmd3 delete '*/''"' / 3 - 1
cmd4 terminator test
cmd5 und so
cmd6 term: ist
cmd7 term> in com nein >
$/tstScanSqlStmtRdr/ */
call tst t, 'tstScanSqlStmtRdr'
r = jOpen(ScanSqlStmtRdr(b, 30), '<')
do sx=1 while jRead(r)
call tstOut t, 'cmd'sx m.r
end
call jClose r
call tstEnd t
return
endProcedure tstScanSqlStmt
tstScanSql: procedure expose m.
call scanWinIni
/*
$=/tstScanSqlId/
### start tst tstScanSqlId ########################################
sqlId ABC
spaceNL
sqlId AB__345EF
spaceNL
$/tstScanSqlId/ */
call tst t, 'tstScanSqlId'
b = jBuf('abc -- kommentar', right('ab_', 72), '_345ef-- kom')
s = scanOpen(scanSqlReset(tstScn, b))
do sx=1 while \scanEnd(s)
if scanSqlID(s) then call tstOut t, 'sqlId' m.s.val
else if scanSpace(s) then call tstOut t, 'spaceNL'
else call scanErr s, 'cannot scan'
end
call tstEnd t
/*
$=/tstScanSqlDelimited/
### start tst tstScanSqlDelimited #################################
sqlDeId ABC
spaceNL
sqlDeId AB_3F
spaceNL
sqlDeId abc
spaceNL
sqlDeId ab_Ef
spaceNL
$/tstScanSqlDelimited/ */
call tst t, 'tstScanSqlDelimited'
b = jBuf('abc -- kommentar',,' -- ',,right('ab_', 72),'3F-- kom',
, '"abc" -- ko', ' -- ',,right('"ab_', 72),'Ef"-- kom')
s = scanOpen(scanSqlReset(tstScn, b))
do sx=1 while \scanEnd(s)
if scanSqlDeID(s) then call tstOut t, 'sqlDeId' m.s.val
else if scanSpace(s) then call tstOut t, 'spaceNL'
else call scanErr s, 'cannot scan'
end
call tstEnd t
/*
$=/tstScanSqlQualified/
### start tst tstScanSqlQualified #################################
sqlQuId ABC 1 ABC
sqlQuId AB_3F 1 AB_3F
sqlQuId abc 1 abc
sqlQuId ab_Ef 1 ab_Ef
sqlQuId EINS.Zwei.DREI 3 EINS
sqlQuId vi er.fu enf 2 vi er
$/tstScanSqlQualified/ */
call tst t, 'tstScanSqlQualified'
b = jBuf('abc -- kommentar',,' -- ',,right('ab_', 72),'3F-- kom',
, '"abc" -- ko', ' -- ',right('"ab_', 72),'Ef"-- kom',
, 'eins."Zwei', '" -- com', ' . -- com', ' -- com',
, 'drei -- ko', '"vi er"."fu enf " -- co')
s = scanOpen(scanSqlReset(tstScn, b))
do sx=1 while \scanEnd(s)
if scanSqlQuID(s) then
call tstOut t, 'sqlQuId' m.s.val m.s.val.0 m.s.val.1
else if scanSpace(s) then call tstOut t, 'spaceNL'
else call scanErr s, 'cannot scan'
end
call tstEnd t
/*
$=/tstScanSqlNum/
### start tst tstScanSqlNum #######################################
sqlNum 1
spaceNL
sqlNum 2..
spaceNL
sqlNum .3
spaceNL
sqlNum 4.5
spaceNL
sqlNum +6
spaceNL
sqlNum +7.03
spaceNL
sqlNum -8
spaceNL
sqlNum -.9
spaceNL
sqlNum 1E2
spaceNL
sqlNum -2.E-2
spaceNL
sqlNum +.3E+3
spaceNL
$/tstScanSqlNum/ */
call tst t, 'tstScanSqlNum'
b = jBuf('1 2. .3 4.5 +6 + --kom', , ' -- com ', , ' 7.03 -8 - .9',
'1e2 - 2.e-2 + .3e+3')
s = scanOpen(scanSqlReset(tstScn, b))
do sx=1 while \scanEnd(s)
if scanSqlNum(s) then
call tstOut t, 'sqlNum' m.s.val
else if scanSpace(s) then call tstOut t, 'spaceNL'
else call scanErr s, 'cannot scan'
end
call tstEnd t
/*
$=/tstScanSqlNumUnit/
### start tst tstScanSqlNumUnit ###################################
sqlNumUnit 1 KB
spaceNL
sqlNumUnit .3 MB
sqlNumUnit .5
sqlNumUnit +6.E-5 B
spaceNL
sqlNumUnit -7
char *
spaceNL
sqlNumUnit -.8
char T
char B
spaceNL
*** err: scanErr bad unit TB after +9..
. e 1: last token Tb scanPosition .
. e 2: pos 41 in line 1: 1 kb .3mB.5 + 6.e-5B -7* -.8 TB + 9.T+
b
sqlNumUnit +9..
spaceNL
$/tstScanSqlNumUnit/ */
call tst t, 'tstScanSqlNumUnit'
b = jBuf('1 kb .3mB.5 + 6.e-5B -7* -.8 TB + 9.Tb')
s = scanOpen(scanSqlReset(tstScn, b))
do sx=1 while \scanEnd(s)
if scanSqlNumUnit(s, 0, 'B KB MB') then
call tstOut t, 'sqlNumUnit' m.s.val
else if scanSpace(s) then call tstOut t, 'spaceNL'
else if scanChar(s ,1) then call tstOut t, 'char' m.s.tok
else call scanErr s, 'cannot scan'
end
call tstEnd t
/*
$=/tstScanSqlClass/
### start tst tstScanSqlClass #####################################
i a 1 A
d "bC" 1 bC
q d.e 2 D.E
q f." g".h 3 F. g.H
s 'ij''kl' 3 ij'kl
s x'f1f2' 3 12
s X'f3F4F5' 3 345
.. . 3 .
n .0 3 .0
n 123.4 3 123.4
n 5 3 5
i g 1 G
$/tstScanSqlClass/ */
call tst t, 'tstScanSqlClass'
b = jBuf('a "bC" d.e f." g".h' "'ij''kl' x'f1f2' X'f3F4F5'" ,
, '. .0 123.4 5 g')
h = scanOpen(scanSqlReset(tstScn, b))
do sx=1 while scanSqlClass(h)
call tstOut t, m.h.sqlClass m.h.tok m.h.val.0 m.h.val
end
call tstEnd t
return
endProcedure tstScanSql
/****** tstData begin *************************************************/
tstData: procedure expose m.
parse arg ty 2 le 'n' nu, l, r, num
abs = abs(num)
if nu \== '' then do
if abs // 5 = 0 then
return 'null' || (abs % 5 // nu + 1)
end
if ty = 'c' then do
if le = '' then
le = 8
le = abs // le + 1
if r = '' then
r = '+'
return left(l || num || r, le, right(r, 1))
end
if pos(ty, 'ief') < 1 then
call err 'bad type' ty
nn = abs
if abbrev(num, '-') | abbrev(num, '+') then
parse var num si 2 nn
else
si = ''
if ty == 'e' then
ex = 'e' || left('-', abs // 2) || (abs // 15)
else
ex = ''
if le \== '' then
nn = right(nn, abs // max(1, le - length(si||ex)) + 1, 1)
if ty \== 'i' & (abs // 4) \= 0 & length(nn) > 1 then
nn = overlay('.', nn, length(nn) - abs // length(nn))
return si || nn || ex
endProcedure tstData
tstDataClassFo: procedure expose m.
parse arg flds
ty = ''
do fx=1 by 2 to words(flds)
if word(flds, fx) = '.' then
ty = ty', v'
else
ty = ty', f' word(flds, fx) 'v'
end
t = classNew('n* tstData u' substr(ty, 2))
fo = oNew(m.t.name)
ff = oFldD(fo)
do fx=1 to m.ff.0
f = fo || m.ff.fx
m.f = word(flds, 2*fx)
end
return fo
endProcedure tstDataClassFo
tstDataClassOut: procedure expose m.
parse arg flds, f, t
fo = tstDataClassFo(flds)
ff = oFldD(fo)
do x=f to t
o = oCopy(fo)
do fx=1 to m.ff.0
f = o || m.ff.fx
m.f = tstData(m.f, substr(m.ff.fx, 2),
, '+'substr(m.ff.fx,2)'+', x)
end
call out o
end
return
endProcedure tstDataClassOut
/****** tst **********************************************************
test infrastructure
***********************************************************************/
/*--- migrate all compares to new ones:
tstCI input compare
tstCO ouput migrated compares
tstCIO input and output -------------------------------------*/
tstUtTime: procedure expose m.
say 'begin' utTime() sysvar('sysnode')
do 3000000
end
call sleep 1
say 'end ' utTime()
return
tstUtc2d: procedure expose m.
/*
$=/tstUtc2d/
### start tst tstUtc2d ############################################
. ff 255
. ffff 65535
. 10000 65536 65536 = 1 * 16 ** 4
. 10001 65537
. ffffff 16777215
. 1000000 16777216 16777216 = 1 * 16 ** 6
. 1000001 16777217
. 20000FF 33554687
. 100000000 4294967296 4294967296 = 1 * 16 ** 8
. 300000000 12884901888 12884901888 = 3 * 16 ** 8
. 3020000EF 12918456559
$/tstUtc2d/
*/
numeric digits 33
call tst t, 'tstUtc2d'
all = 'ff ffff 10000 10001 ffffff 1000000 1000001 20000FF' ,
'100000000 300000000 3020000EF'
do ax = 1 to words(all)
a = word(all, ax)
if substr(a, 2) = 0 then
b = right(left(a, 1) * 16 ** (length(a)-1), 15) ,
'=' left(a, 1) '* 16 **' (length(a)-1)
else
b = ''
call tstout t, right(a, 15)right(utc2d(x2c(a)), 15)b
end
call tstEnd t
return
endProcedure tstUtc2d
tstCI: procedure expose m.
parse arg m, nm
m.m.CIO = 0
signal tstCIwork
tstCIO: procedure expose m.
parse arg m, nm
m.m.CIO = 1
tstCIwork:
m.m.name = nm
m.m.cmp.1 = left('### start tst' nm '', 67, '#')
do ix=2 to arg()-1
m.m.cmp.ix = arg(ix+1)
end
m.m.cmp.0 = ix-1
if m.m.CIO then
call tstCO m
return
tstCO: procedure expose m.
parse arg m
call tst2dpSay m.m.name, m'.CMP', 68
return
/*--- initialise m as tester with name nm
use inline input nm as compare lines -----------------------*/
tstReset: procedure expose m.
parse arg m, nm
call tstIni
m.m.name = nm
m.m.inIx = 0
m.m.out.0 = 0
m.m.err = 0
m.err.count = 0
m.tst.act = m
if \ datatype(m.m.trans.0, 'n') then
m.m.trans.0 = 0
m.m.trans.old = m.m.trans.0
return
endProcedure tstReset
tst: procedure expose m.
parse arg m, nm, cmpSt
call tstReset m, nm
m.tst.tests = m.tst.tests+1
if cmpSt == '' then do
cmpSt = mCut(t'.CMP', 0)
call tst4dp cmpSt, mapInline(nm)
end
m.m.cmp = cmpSt
m.m.moreOutOk = 0
call mAdd mCut(m'.IN', 0), 'tst in line 1 eins ,' ,
, 'tst in line 2 zwei ; ' ,
, 'tst in line 3 drei .schluss.'
call tstOut m, left('### start tst' nm '', 67, '#')
call errReset 'h', 'return tstErrHandler(ggTxt)'
m.m.errCleanup = m.err.cleanup
if m.tst.ini.j \== 1 then do
m.tst_m = m
/* call err implement outDest 'i', 'call tstOut' quote(m)', msg'
*/ end
else do
drop m.tst_m
m.m.jWriting = 0
call jOpen jReset(oMutatName(m, 'Tst')), '>'
m.m.in.jReading = 0
call jOpen jReset(oMutatName(m'.IN', 'Tst')), '<'
if m.tst.ini.e \== 1 then do
m.m.oldJin = m.j.in
m.m.oldOut = m.j.out
m.j.in = m'.IN'
m.j.out = m
end
else do
if m.pipe.0 <> 2 then
call tstErr m, 'm.pipe.0' m.pipe.0 '<> 2'
call pipe '+Ff', m , m'.IN'
end
end
return m
endProcedure tst
tstEnd: procedure expose m.
parse arg m, opt opt2
cmp = m.m.cmp
m.m.jReading = 0
m.m.jWriting = 0
drop m.tst_m
if m.tst.ini.j == 1 then do
m.m.jReading = 0
m.m.jWriting = 0
if m.tst.ini.e \== 1 then do
m.j.in = m.m.oldJin
m.j.out = m.m.oldOut
end
else do
if m.j.in \== m'.IN' | m.j.out \== m then
call tstErr m, m.j.in '\==' m '|' m.j.out '\==' m
call pipe '-'
if m.pipe.0 <> 2 then
call tstErr m, 'm.pipe.0' m.pipe.0 '<> 2'
end
end
if m.m.err = 0 then
if m.m.errCleanup \= m.err.cleanup then
call tstErr m, 'err.Cleanup' m.err.cleanup '<> old',
m.m.errCleanup
if m.m.out.0 \= m.cmp.0 & \ (m.m.moreOutOk,
& m.m.out.0 > m.cmp.0) then do
call tstErr m, 'old' m.cmp.0 'lines \= new' m.m.out.0
do nx = m.m.out.0 + 1 to min(m.m.out.0+10, m.cmp.0)
say 'old - ' m.cmp.nx
end
end
call errReset 'h'
m.tst.act = ''
soll = 0
if opt = 'err' then do
soll = opt2
if m.m.err \= soll then
call err soll 'errors expected, but got' m.m.err
end
if m.m.err \= soll then do
say 'new lines:' (m.m.out.0 - 1)
call tst2dpSay m.m.name, m'.OUT', 68
end
say left('###' m.m.name 'end with' m.m.err 'errors ', 67, '#')
if 1 & m.m.err \= soll then
call err 'dying because of' m.m.err 'errors'
m.m.trans.0 = m.m.trans.old
return
endProcedure tstEnd
tst2dp: procedure expose m.
parse arg st, dp, ml
dx = m.dp.0
do sx=1 to m.st.0
li = m.st.sx
cx = 1
do until cx > length(li)
c = substr(li, cx, 1)
ou = left('.', strip(c) == '' | pos(c, '.+') > 0)
ex = min(length(li),cx+ml-length(ou)-2)
ou = ou || substr(li, cx, ex+1-cx)
dx = dx + 1
c = right(ou, 1)
if ex < length(li) then
m.dp.dx = ou || '+'
else if strip(c) == '' | pos(c, '.+') > 0 then
m.dp.dx = ou || '.'
else
m.dp.dx = ou
cx = ex +1
end
end
m.dp.0 = dx
return
endProcedure tst2dp
tst2dpSay: procedure expose m.
parse arg name, st, ml
say '$=/'name'/'
call tst2dp st, mCut('TST.TMP', 0), 68
do nx=1 to m.tst.tmp.0
say ' ' m.tst.tmp.nx
end
say '$/'name'/'
return tst2dpSay
tst4dp: procedure expose m.
parse arg st, dp
sx = m.st.0
inData = 0
data = ''
do dx=1 to m.dp.0
li = strip(m.dp.dx)
if pos(left(li, 1), '.+') > 0 then
li = substr(li, 2)
if right(li, 1) == '+' then do
inData = 1
data = data || left(li, length(li)-1)
iterate
end
if right(li, 1) == '.' then
li = left(li, length(li)-1)
sx = sx + 1
m.st.sx = repAll(data || li, '$ä', '/*', '$ö', '*/')
inData = 0
data = ''
end
m.st.0 = sx
if inData then
call err 'end inData'
return
endProcedure tst4dp
/*--- write to test: say lines and compare them ----------------------*/
tstOut: procedure expose m.
parse arg m, arg
do tx=m.m.trans.0 by -1 to 1
arg = repAll(arg, word(m.m.trans.tx, 1),
, subword(m.m.trans.tx, 2))
end
call mAdd m'.OUT', arg
nx = m.m.out.0
cmp = m.m.cmp
c = m.cmp.nx
if nx > m.cmp.0 then do
if nx = m.cmp.0+1 & \ m.m.moreOutOK then
call tstErr m, 'more new Lines' nx
end
else if c \== arg then do
do cx=1 to min(length(c), length(arg)) ,
while substr(c, cx, 1) == substr(arg, cx, 1)
end
msg = 'old line' nx '<> new overnext, firstDiff' cx',',
'len old' length(c)', new' length(arg)
if cx > 10 then
msg = overlay('|', msg, cx-10)
call tstErr m, msg
say c
end
say arg
return 0
endProcedure tstOut
tstWrite: procedure expose m.
parse arg m, var
cl = objClass(var)
if cl == m.class_N then do
call tstOut m, 'tstR: @ obj null'
end
else if cl == m.class_S then do
call tstOut m, var
end
else if abbrev(var, m.o_escW) then do
call tstOut m, o2String(var)
end
else if cl == m.class_V then do
call tstOut m, m.var
end
else if oKindOf(var, 'JRW') then do
call tstOut m, 'tstWriteO kindOf JRW jWriteNow begin <<<'
call jWriteNow m, var
call tstOut m, 'tstWriteO kindOf JRW jWriteNow end >>>'
end
else if oKindOf(var, 'ORun') then do
call tstOut m, 'tstWriteO kindOf ORun oRun begin <<<'
call oRun var
call tstOut m, 'tstWriteO kindOf ORun oRun end >>>'
end
else do
do tx=m.m.trans.0 by -1 to 1 ,
while word(m.m.trans.tx, 1) \== var
end
if tx < 1 then
call mAdd M'.TRANS', var 'tstWriteoV' ||(m.m.trans.0+1)
call classOut , var, 'tstR: '
end
return
endProcedure tstWrite
tstRead: procedure expose m.
parse arg mP
if right(mP, 3) \== '.IN' then
call err 'tstRead bad m' mP
m = left(mP, length(mP)-3)
ix = m.m.inIx + 1
m.m.inIx = ix
if ix <= m.m.in.0 then do
call tstOut m, '#jIn' ix'#' m.m.in.ix
m.mP = m.m.in.ix
return 1
end
call tstOut m, '#jIn eof' ix'#'
return 0
endProcedure tstRead
tstFilename: procedure expose m.
parse arg suf, opt
if m.err.os == 'TSO' then do
parse value dsnCsmSys(suf) with sys '/' suf
dsn = dsn2jcl('~tmp.tst.'suf)
if sys \== '*' then
dsn = sys'/'dsn
if opt = 'r' then do
if dsnExists(dsn) then
call dsnDel dsn
do fx=1 to dsnList(tstFileName, dsn)
call dsnDel m.tstFileName.fx
end
end
return dsn
end
else if m.err.os == 'LINUX' then do
if abbrev(suf, '/') then
fn = suf
else
fn = .Stream%%new('~/tmp/tst/'suf)%%qualify /* full path */
cx = lastPos('/', fn)
if cx > 0 then do
dir = left(fn, cx-1)
if \sysIsFileDirectory(dir) then
call adrSh "mkdir -p" dir
if \sysIsFileDirectory(dir) then
call err 'tstFileName could not create dir' dir
end
if opt \= 'r' then
nop
else if sysIsFile(fn) then
call sysFileDelete fn
else if sysIsFileDirectory(fn) then
call adrSh 'rm -r' fn
return fn
end
else
call err 'tstFilename does not implement os' m.err.os
endProcedure tstFilename
/*--- say total errors and fail if not zero --------------------------*/
tstTotal: procedure expose m.
say '######'
/* say '###### astStatsTotals'
do sx=1 to words(m.comp_astStats)
k = word(m.comp_astStats, sx)
say f('%5c %7i %7i %7i', k, m.comp_astStats.k,
, m.comp_astStatT.k, m.comp_astStat1.k)
end
say '######' */
say '######' m.tst.tests 'tests with' ,
m.tst.err 'errors in' m.tst.errNames
say '######'
say '######'
if m.tst.err \== 0 then
call err m.tst.err 'errors total'
return
endProcedure tstTotal
/*--- test err: message, count it and continue -----------------------*/
tstErr: procedure expose m.
parse arg m, msg
say '### error' msg
m.m.err = m.m.err + 1
m.tst.err = m.tst.err + 1
nm = m.m.name
if wordPos(nm, m.tst.errNames) < 1 then
m.tst.errNames = m.tst.errNames nm
return 0
endProcedure tstErr
/*--- tstErrHandler: intercept errors --------------------------------*/
tstErrHandler: procedure expose m.
parse arg ggTxt
m = m.tst.act
if m == '' then
call err ggTxt
m.err.count = m.err.count + 1
call splitNl err, errMsg(' }'ggTxt)
call tstOut m.tst.act, '*** err:' m.err.1
do x=2 to m.err.0
call tstOut m, ' e' (x-1)':' m.err.x
end
return 0
endSubroutine tstErrHandler
tstTrc: procedure expose m.
parse arg msg
m.tst.trc = m.tst.trc + 1
say 'tstTrc' m.tst.trc msg
return m.tst.trc
endProcedure tstTrc
/*--- tstIni: global initialization ----------------------------------*/
tstIni: procedure expose m.
if m.tst.ini \== 1 then do
m.tst.ini = 1
call mapIni
m.tst.err = 0
m.tst.trc = 0
m.tst.errNames = ''
m.tst.tests = 0
m.tst.act = ''
end
if m.tst.ini.j \== 1 & m.j.ini == 1 then do
m.tst.ini.j = 1
call classNew 'n Tst u JRW', 'm',
, "jOpen",
, "jRead return tstRead(m)",
, jWrite1Met("call tstWrite m, m.var")
end
if m.tst.ini.e \== 1 & m.pipe.ini == 1 then do
m.tst.ini.e = 1
end
return
endProcedure tstIni
/* copy tstAll end **************************************************/
/* copy wshCopy begin ************************************************/
wshIni: procedure expose m.
call compIni
call csvIni
call sqlIni
call scanWinIni
call fTabIni
return
endProcedure wshIni
/* copy wshCopy end ************************************************/
/* copy db2Util begin ************************************************/
tstDb2Ut: procedure expose m.
/*
$=/tstDb2Ut/
$/tstDb2Ut/
*/
call pipeIni
call tst t, 'tstDb2Ut'
call mAdd mCut(t'.IN', 0), ' template old ,' ,
, 'LOAD DATA INDDN oldDD ' ,
, '( cols )'
call db2UtilPunch 'rep iDsn=DSN.INPUT.UNL'
call tstEnd t
return
endProcedure tstDb2Ut
/* ???????????? achtung nicht fertig |
Idee: allgemein Punch Umformungs Utility
aber man müsste wohl auf scan Util umstellen
und abstürzen wenn man etwas nicht versteht
GrundGerüst von cadb2 umgebaut
????????????????? */
db2UtilPunch: procedure expose m.
parse upper arg args
call scanSrc scanOpt(s), args
a.rep = 1
a.tb = ''
a.trunc = 0
a.iDD = ''
a.iDSN = ''
do while scanKeyValue(scanSkip(s), 1)
ky = m.s.key
say '????ky' ky m.s.val
if wordPos(ky, 'REP TB TRUNC IDD IDSN') < 1 then
call scanErr s, 'bad key' ky
a.ky = m.s.val
end
if a.iDSN \== '' then do
if a.iDD == '' then
a.iDD = 'IDSN'
call out ' TEMPLATE' a.iDD 'DSN('a.iDsn')'
end
do while in() & word(m.in, 1) <> 'LOAD'
call out m.in
end
ll = space(m.in, 1)
if \ abbrev(ll, 'LOAD DATA ') then
call err 'bad load line:' m.in
call out subword(m.in, 1, 2) 'LOG NO'
if abbrev(ll, 'LOAD DATA INDDN ') then
call db2UtilPunchInDDn word(ll, 4)
else if \ abbrev(ll, 'LOAD DATA LOG ') then
call err 'bad load line' ix':' m.i.ix
if a.rep then
call out ' STATISTICS INDEX(ALL) UPDATE ALL'
call out ' DISCARDS 1'
call out ' ERRDDN TERRD'
call out ' MAPDDN TMAPD '
call out ' WORKDDN (TSYUTD,TSOUTD) '
call mAdd o, ' SORTDEVT DISK '
do ix=ix+1 to m.i.0
if pos('CHAR(', m.i.ix) > 0 then
call mAdd o, strip(m.i.ix, 't') 'TRUNCATE'
else if word(m.i.ix, 1) word(m.i.ix, 3) == 'PART INDDN' then
call mAdd o, m.i.ix,
, ' RESUME NO REPLACE COPYDDN(TCOPYD)' ,
, ' DISCARDDN TDISC '
else
call mAdd o, m.i.ix
end
call writeDsn oDsn ':~'iDsn, 'M.O.', , 1
return
endProcedure db2UtilPunch
db2UtilPunchInDDn:
parse arg inDDn
if a.iDD == '' then
ll = ' INDDN' inDDn
else
ll = ' INDDN' a.iDD
if a.rep then
call out ll 'RESUME NO REPLACE COPYDDN(TCOPYD)'
else
call out ll 'RESUME YES'
call out ' DISCARDDN TDISC'
return
endSubroutine db2UtilPunchInDDn
/* copy db2Util end ************************************************/
/* copy time begin ****************************************************
timestamp format yz34-56-78-hi.mn.st.abcdef
11.12.14 wk: added lrsn2uniq
11.05.13 wk: numeric digits transparent: in jeder Procedure drin
time2jul, tst externalisiert
**********************************************************************/
/*--- timestamp to julian --------------------------------------------*/
time2jul: procedure expose m.
parse arg yyyy '-' mm '-' dd '-'
if yyyy < 1100 then
yyyy = 11 || right(yyyy, 2, 0)
/* date function cannot convert to julian, only from julian
use b (days since start of time epoch) instead */
return right(yyyy, 2) ,
|| right(date('b', yyyy || mm || dd, 's') ,
- date('b', yyyy-1 || '1231', 's') , 3, 0)
endProcedure time2jul
/*--- current timestamp ---------------------------------------------*/
timestampNow: procedure expose m.
parse value date('s') time('l') with y 5 m 7 d t
return y'-'m'-'d'-'translate(t, '.', ':')
/*--- timestamp expand: expand to timestamp of 26 chars -------------*/
timestampExp: procedure expose m.
parse arg tst .
if length(tst) < m.timeStamp_Len then
return overlay(tst, m.timeStamp_01)
else
return left(tst, timeStamp_Len)
endProcedure tiemstampExp
/*--- timestamp check return '' if correct or error text ------------*/
timestampcheck: procedure expose m.
parse arg tst
if length(tst) < m.timestamp_d0Len | \ abbrev(m.timestamp_11,
, translate(tst, '111111111', '023456789')) then
return 'bad timestamp' tst
parse arg yyyy '-' mo '-' dd '-' hh '.' mm '.' ss '.' u
if mo < 1 | mo > 12 then
return 'bad month in timestamp' tst
if dd < 1 | dd > 3 || substr('101010110101', mo, 1) then
return 'bad day in timestamp' tst
if mo = 2 then
if dd > date('d', yyyy'0301', 's') - 32 then
return 'bad day in timestamp' tst
if hh > 23 & \ abbrev(24 00 00 000000, hh mm ss u) then
return 'bad hour in timestamp' tst
if mm > 59 then
return 'bad minute in timestamp' tst
if ss > 59 then
return 'bad second in timestamp' tst
return ''
endProcedure timestampCheck
/*--- timestamp to days since 1.1.0001 ------------------------------*/
timestamp2days: procedure expose m.
parse arg yyyy '-' mo '-' dd '-' hh '.' mm '.' ss
numeric digits 20
return date('b', yyyy || mo || dd, 's') ,
+ (((hh * 60) + mm) * 60 + ss) / 86400
/*--- days since 1.1.0001 (with time+microsecs) to timestamp --------*/
timeDays2tst: procedure expose m.
parse arg d
numeric digits 20
r = min(format(d // 1 * 86400, 5, 6), 86399.999999)
s = trunc(r)
t = date('s', trunc(d), 'b')
return left(t, 4)'-'substr(t, 5, 2)'-'right(t, 2) ,
|| '-' || right((s % 3600), 2, 0) ,
|| '.' || right((s // 3600 % 60), 2, 0) ,
|| '.' || right((s // 60), 2, 0) ,
|| substr(r, 6)
endProcedure timeDays2tst
/*--- timestamp diff in days ----------------------------------------*/
timestampDiff: procedure expose m.
parse arg t1, t2
numeric digits 20
return timestamp2days(t1) - timestamp2Days(t2)
/*--- convert 2 digit year to 4 digit -------------------------------*/
timeYear24: procedure expose m.
parse arg s
y = left(date('S'), 4)
s4 = left(y, 2)right(s, 2, 0)
if s4 > y + 30 then
return (left(y, 2) - 1)substr(s4, 3)
else if s4 < y - 69 then
return (left(y, 2) + 1)substr(s4, 3)
else
return s4
endProcedure timeYear24
/*--- convert 2 or 4 digit year Y (A=0...T=19) ----------------------*/
timeYear2Y: procedure expose m.
parse arg y
return substr('ABCDEFGHIJKLMNOPQRST' , ((y + 10) // 20) + 1, 1)
/*--- convert 2 or 4 digit year Y (A=0...T=19) ----------------------*/
timeY2Year: procedure expose m.
parse arg i
j = pos(i, 'ABCDEFGHIJKLMNOPQRST') - 1
if j < 0 then
call err 'timeYearY24 bad input' i
y = left(date('S'), 4)
r = y - (y+10) // 20 + j
if r < y - 15 then
return r + 20
else if r > y + 4 then
return r - 20
else
return r
endProcedure timeY2Year
/*--- convert numeric month to M (Jan=B=1, dec=12=M) ----------------*/
timeMonth2M: procedure expose m.
parse arg m
return substr('BCDEFGHIJKLM', m, 1)
/*--- convert M to numeric Month (Jan=B=1, dec=12=M) ----------------*/
timeM2Month: procedure expose m.
parse arg m
p = pos(m, 'BCDEFGHIJKLM')
if p= 0 then
call err 'bad M month' m
return right(p, 2, 0)
/*--- convert numeric hour 78 to H8 (A=0..D=3) ----------------------*/
timeHour2H: procedure expose m.
parse arg h
h = right(h, 2, 0)
return substr('ABCD', left(h, 1)+1, 1)substr(h, 2)
/*--- convert H8 to numeric Hour 78 (A=0..D=3) ----------------------*/
timeH2Hour: procedure expose m.
parse arg h
p = pos(left(h, 1), 'ABCD') - 1
if p < 0 | length(h) \== 2 then
call err 'bad H hour' h
return p || substr(h, 2)
/*--- read timeZoneOffset and leapSeconds registers
and set variables for uniq ----------------------------------*/
timeIni: procedure expose m.
parse arg debug
numeric digits 25
/* offsets documented in z/OS Data Areas Vol.1 */
cvtOH = '00000010' /* cvt control block Address */
cvtext2O = x2d('00000560') /* offset to extension 2 */
cvtldtoO = x2d('00000038') /* offset to timezone */
cvtlsoO = x2d('00000050') /* offset to leapSeconds */
/* CVT CB address + extention2 */
cvtExt2A = C2D(STORAGE(cvtOH,4)) + cvtext2O
/* cvtLdto timeZone address +offset */
m.time_Zone = c2d(STORAGE(d2x(cvtext2A+cvtldtoO, 8), 8))
m.time_StckUnit = 1e-6 / 256 / 16
/* cvtLso LeapSecs address +offset */
m.time_Leap = c2d(STORAGE(d2x(cvtext2A+cvtlsoO, 8), 8))
m.time_LZT_TAI10_us16 = (m.time_zone - m.time_leap) % 256
m.time_UQDigits = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ012345678'
/* find lrsn of day 0, 0 out last 6 bits */
m.time_UQZero = x2d(left(timeTAI102Lrsn( ,
'2004-12-31-00.00.22.000000'), 14)) % 64 * 64
m.timeStamp_01 = '0001-01-01-00.00.00.000000'
m.timeStamp_11 = '1111-11-11-11.11.11.111111'
m.timeStamp_99 = '9999-12-31-23.59.59.999999'
m.timeStamp_len = length(m.timestamp_11)
m.timeStamp_d0Llen = m.timestamp_len - 7
m.time_ini = 1
return
endSubroutine timeIni
/*--- TAI10 timestamp yyyy-mm.... -> stckE value char(16)
BLSUETID is described in z/OS MVS IPCS Customization -------*/
timeTAI102stckE: procedure expose m.
/* timestamp must include microSeconds |||*/
parse arg year'-'mo'-'da'-'hh'.'mm'.'secs
tDate = mo'/'da'/'year hh':'mm'.'secs
ACC=left('', 16, '00'x)
ADDRESS LINKPGM "BLSUETID TDATE ACC"
RETURN acc
endProcedure timeTAI102stckE
timeTAI102lrsn: procedure expose m.
parse arg tst
return c2x(left(timeTAI102StckE(tst), 10))
timeLZT2stckE: procedure expose m.
parse arg tst
numeric digits 23
s =timeTAI102StckE(tst)
return d2c(c2d(left(s, 8)) - m.time_lzt_TAI10_us16,8) || substr(s,9)
endProcedure timeLZT2stckE
timeLZT2lrsn: procedure expose m.
parse arg tst
return c2x(left(timeLZT2StckE(tst), 10))
/*--- expand lrsn to 20 hexDigits -------------------------------*/
timeLrsnExp: procedure expose m.
parse arg s
return left(copies('00', length(s) <= 12 & \abbrev(s, 0))s, 20,0)
/*--- expand stcK(e) to 16 Byte ---------------------------------*/
timeStckExp: procedure expose m.
parse arg s
return left(copies('00'x, length(s) <= 8 & s >> '09'x)s, 16,'00'x)
/*--- conversion from StckE Clock Value to TAI10 Timestamp
BLSUETOD is described in z/OS MVS IPCS Customization --------*/
timeStckE2TAI10: PROCEDURE expose m.
parse arg stck /* must be 16 characters ||||| */
TDATE = left('' , 26)
ADDRESS LINKPGM "BLSUETOD stck TDATE"
/* return format : mo/dd/yyyy hh:mm:ss.uuuuuu */
/* Timestamp format: yyyy-mm-dd-hh.mm.ss.uuuuuu */
parse var TDATE mo '/' dd '/' yyyy hh ':' mm ':' secs
RETURN yyyy'-'mo'-'dd'-'hh'.'mm'.'secs
endProcedure timeStckE2TAI10
/*--- conversion from Lrsn Clock Value to TAI10 Timestamp ----------*/
timeLrsn2TAI10:
return timeStckE2TAI10(x2c(arg(1))'000000000000'x)
/*--- conversion from Lrsn Clock Value to LZT Local Zurich Time -----*/
timeStckE2LZT: procedure expose m.
parse arg s
numeric digits 23
return timeStckE2TAI10(d2c(c2d(left(s, 8)) ,
+ m.time_LZT_TAI10_us16, 8) || substr(s, 9))
endProcedure timeStckE2LZT
/*--- conversion from Lrsn Clock Value to LZT Local Zurich Time -----*/
timeLrsn2LZT: procedure expose m.
parse arg lrsn
return timeStckE2LZT(x2c(lrsn) || '000000000000'x)
/* convert a lrsn to the uniq variable ********************************/
timeLrsn2uniq: procedure expose m.
parse arg lrsn
/* unique are bits 0:41 of the TodClock value
minus 31.12.2004 represented
by base 35 by 'ABC...YZ01..8'
*/
lrsn = left(timeLrsnExp(lrsn), 14)
numeric digits 20
diff = x2d(lrsn) - m.time_UQZero
if diff < 0 then
return'< 2005'
return right(i2q(diff % 64, m.time_UQDigits), 8, 'A')
endProcedure timeLrsn2Uniq
/* convert a uniq variable to lrsn ************************************/
timeUniq2lrsn: procedure expose m.
parse arg uniq
numeric digits 20
u1 = q2i(left(uniq, 8, 'A'), m.time_UQDigits) * 64
lrsn = '00'right(d2x(u1 + m.time_UQZero), 12, 0)'000000'
return lrsn
endProcedure uniq2lrsn
/*--- translate a number in q-system to decimal
arg digits givs the digits corresponding to 012.. in the q sysem
q = length(digits) --------------------------------------------*/
q2i: procedure expose m.
parse arg v, digits
b = length(digits)
i = 0
do x = 1 to length(v)
q = substr(v, x, 1)
r = pos(q, digits)
if r < 1 then
call err 'bad digit' q 'in' v 'valid digits' digits
i = i * b + r - 1
end
return i
endProcedure q2i
/*--- translate a decimal number to q-system - inverse of q2i --------*/
i2q: procedure expose m.
parse arg i, digits
if i = 0 then
return left(digits, 1)
b = length(digits)
v = ''
do while i > 0
v = substr(digits, 1 + (i // b), 1) || v
i = i % b
end
return v
endProcedure i2q
/* copy time end -----------------------------------------------------*/
/* copy sort begin ****************************************************/
sortComparator: procedure expose m.
parse arg cmp, le, ri
if cmp == '' then
cmp = '<<='
if length(cmp) < 6 then
m.sort_comparator = 'cmp =' le cmp ri
else if pos(';', cmp) < 1 then
m.sort_comparator = "aLe =" le"; aRi =" ri"; cmp =" cmp
else
m.sort_comparator = "aLe =" le "; aRi =" ri";" cmp
return
endProcedure sort
sortWords: procedure expose m.
parse arg wrds, cmp
if words(wrds) <= 1 then
return strip(wrds)
m.sort_ii.0 = words(wrds)
do sx=1 to m.sort_ii.0
m.sort_ii.sx = word(wrds, sx)
end
call sort sort_ii, sort_oo, cmp
r = m.sort_oo.1
do sx=2 to m.sort_oo.0
r = r m.sort_oo.sx
end
return r
endProcedure sortWords
sortWordsQ: procedure expose m.
parse arg wrds, cmp
call sortComparator cmp, 'word(le, lx)', 'word(ri, rx)'
return strip(sortWord1(wrds))
endProcedure sortWordsQ
sortWord1: procedure expose m.
parse arg wrds
if words(wrds) <= 1 then
return wrds
h = words(wrds) % 2
le = sortWord1(subWord(wrds, 1, h))
ri = sortWord1(subWord(wrds, h+1))
lx = 1
rx = 1
res = ''
do forever
interpret m.sort_comparator
if cmp then do
res = res word(le, lx)
if lx >= words(le) then
return res subword(ri, rx)
lx = lx + 1
end
else do
res = res word(ri, rx)
if rx >= words(ri) then
return res subword(le, lx)
rx = rx + 1
end
end
endProcedure sortWord1
sort: procedure expose m.
parse arg i, o, cmp
call sortComparator cmp, 'm.l.l0', 'm.r.r0'
call sort1 i, 1, m.i.0, o, 1, sort_work, 1
m.o.0 = m.i.0
return
endProcedure sort
sort1: procedure expose m.
parse arg i, i0, le, o, o0, w, w0
if le <= 3 then do
if le = 3 then do
call sortMerge i, i0, i0+1, i, i0+1, i0+2, w, w0
call sortMerge i, i0+2, i0+3, w, w0, w0+2, o, o0
end
else if le = 2 then
call sortMerge i, i0, i0+1, i, i0+1, i0+2, o, o0
else if le = 1 then
m.o.o0 = m.i.i0
return
end
h = (le + 1) % 2
call sort1 i, i0, h, o, o0+le-h, w, w0
call sort1 i, i0+h, le-h, w, w0, o, o0
call sortMerge o, o0+le-h, o0+le, w, w0, w0+le-h, o, o0
return
endProcedure sort1
sortMerge: procedure expose m.
parse arg l, l0, le, r, r0, re, o, o0
do while l0 < le & r0 < re
interpret m.sort_comparator
if cmp then do
m.o.o0 = m.l.l0
l0 = l0 + 1
end
else do
m.o.o0 = m.r.r0
r0 = r0 + 1
end
o0 = o0 + 1
end
do while l0 < le
m.o.o0 = m.l.l0
l0 = l0 + 1
o0 = o0 + 1
end
do while r0 < re
m.o.o0 = m.r.r0
r0 = r0 + 1
o0 = o0 + 1
end
return
endProcedure sortMerge
/* copy sort end ****************************************************/
/* copy match begin ***************************************************/
/*--- wildCard matching with the following wildchars:
* 0-n chars
? 1 char
fill matched expressions instem st if st is non empty
return 1 if mask matches wert ----------------------------------*/
match: procedure expose m.
parse arg wert, mask
if symbol('m.match_m.mask') == 'VAR' then
interpret m.match_m.mask
else
interpret matchGen('MATCH_M.'mask, mask, 'm')
endProcedure match
matchGG: procedure expose m.
parse arg wert, cd, vars
interpret cd
endProcedure matchGG
matchVars: procedure expose m.
parse arg wert, mask, vars
if symbol('m.match_v.mask') == 'VAR' then
interpret m.match_v.mask
else
interpret matchGen('MATCH_V.'mask, mask, 'v')
endProcedure match
matchRep: procedure expose m.
parse arg wert, mask, mOut
vars = 'MATCH_VV'
mm = mask'\>'mOut
if symbol('m.match_r.mm') == 'VAR' then
interpret m.match_r.mm
else
interpret matchGen('MATCH_R.'mm, mask, 'r', mOut)
endProcedure matchRep
matchGen: procedure expose m.
parse arg m, mask, opt, mOut
a = matchScan(match_sM, mask)
if symbol('m.match_g') \== 'VAR' then
m.match_g = 0
if opt \== 'r' then do
r = matchgenMat(a, opt, 1, m.a.0, 0)
end
else do
m.match_g = m.match_g + 1
sub = 'MATCH_G'm.match_g
m.sub = matchgenMat(a, 'v', 1, m.a.0, 0)
o = matchScan(match_sO, mOut)
r = matchGenRep(o, m.a.wildC)
r = 'if matchGG(wert, m.'sub', vars) then return' r';' ,
'else return "";'
end
m.m = r
return r
endProcedure matchGen
matchScan: procedure expose m.
parse arg a, mask, opt
s = match_scan
call scanSrc s, mask
ax = 0
vx = 0
m.a.wildC = ''
do forever
if scanUntil(s, '*?&\') then do
if m.a.ax == 'c' then do
m.a.ax.val = m.a.ax.val || m.s.tok
end
else do
ax = ax + 1
m.a.ax = 'c'
m.a.ax.val = m.s.tok
end
end
else if scanChar(s, 1) then do
if pos(m.s.tok, '*?') > 0 then do
ax = ax + 1
vx = vx + 1
m.a.ax = m.s.tok
m.a.ax.ref = vx
m.a.wildC = m.a.wildC || m.s.tok
end
else if m.s.tok == '\' then do
call scanChar s, 1
if pos(m.s.tok, '\*?&') < 1 then
return scanErr(s, 'bad char after \')
if abbrev(m.a.ax, 'c') then
m.a.ax.val = m.a.ax.val || m.s.tok
else do
ax = ax + 1
m.a.ax = 'c'
m.a.ax.val = m.s.tok
end
end
else if m.s.tok == '&' then do
if opt \== 'r' then
call scanErr s, '& in input'
if \ scanChar(s,1) | pos(m.s.tok, 'ms123456789')<1 then
call scanErr s, 'bad & name' m.s.tok
ax = ax + 1
m.a.ax = '&'
m.a.ax.ref = m.s.tok
end
else
call scanErr s, 'bad char 1 after until'
end
else
leave
end
m.a.0 = ax
if vx \== length(m.a.wildC) then
call scanErr 'vars' m.a.wildC 'mismatches' vx
return a
endProcedure matchScan
matchGenMat: procedure expose m.
parse arg a, opt, fx, tx, minLL
ml = 0
if fx == 1 then do
do ax=1 to m.a.0
if m.a.ax == '?' then
ml = ml + 1
else if m.a.ax == 'c' then
ml = ml + length(m.a.ax.val)
m.a.minLen.ax = ml
end
end
r = ''
ret1 = ''
ret1After = ''
lO = 0
do fy=fx to tx
if m.a.fy == 'c' then do
r = r 'if substr(wert,' (1+lO)
if fy < m.a.0 then
r = r',' length(m.a.fy.val)
r = r') \==' quote(m.a.fy.val, "'") 'then return 0;'
lO = lO + length(m.a.fy.val)
end
else if m.a.fy == '?' then do
lO = lO + 1
if opt == 'v' then
ret1 = ret1 'm.vars.'m.a.fy.ref ,
'= substr(wert,' lO', 1);'
end
else if m.a.fy == '*' then
leave
else
call err 'bad match ast' a'.'fy m.a.fy
end
rO = 0
do ty=tx by -1 to fy
if m.a.ty == 'c' then do
rO = rO + length(m.a.ty.val)
r = r 'if substr(wert, length(wert) -' (rO - 1)',' ,
length(m.a.ty.val)')' ,
'\==' quote(m.a.ty.val, "'") 'then return 0;'
end
else if m.a.ty == '?' then do
rO = rO + 1
if opt == 'v' then
ret1 = ret1 'm.vars.'m.a.fy.ref ,
'= substr(wert, length(wert) -' (rO-1)', 1);'
end
else if m.a.ty == '*' then
leave
else
call err 'bad match ast' a'.'fy m.a.fy
end
if fy > ty then do /* every thing is handled with fix len */
if fx = tx & abbrev(m.a.fx, 'c') then
r = 'if wert \==' quote(m.a.fx.val, "'") ,
'then return 0;'
else
r = 'if length(wert) \==' (lO + rO) 'then return 0;' r
end
else do
myMiLe = m.a.minLen.ty
if fy > 1 then do
fq = fy -1
myMiLe = myMiLe - m.a.minLen.fq
end
if minLL < myMiLe then
r = 'if length(wert) <' myMiLe 'then return 0;' r
if fy = ty & m.a.fy == '*' then /* single * */
ret1 = ret1 'm.vars.'m.a.fy.ref ,
'= substr(wert,' (1+lO)', length(wert) -' (lO+rO)');'
else if fy < ty & abbrev(m.a.fy, '*') ,
& abbrev(m.a.ty, '*') then do
/* several variable length parts */
suMiLe = m.a.minLen.ty - m.a.minLen.fy
m.match_g = m.match_g + 1
sub = 'MATCH_G'm.match_g
m.sub = matchGenMat(a, opt, fy+1, ty, suMiLe)
if rO = 0 then
subV = 'substr(wert, lx)'
else do
r = r 'wSub = left(wert, length(wert) -' rO');'
subV = 'substr(wSub, lx)'
end
r = r 'do lx = length(wert) -' (suMiLe+rO-1) ,
'by -1 to' (lO+1)';' ,
'if \ matchGG('subV', m.'sub', vars) then' ,
'iterate;'
ret1 = ret1 'm.vars.'m.a.fy.ref '= substr(wert,' (lO+1) ,
|| ', lx -' (lO+1)');'
ret1After = 'end; return 0;'
end
else
call err 'matchGenMat bad case' a'.'fy m.a.fy a'.'ty m.a.ty
end
if opt == 'v' & fx == 1 then do
if r <> '' then
r = 'm.vars.0 = -9;' r
ret1 = ret1 'm.vars.0 =' length(m.a.wildC)';'
end
r = r ret1 'return 1;' ret1After
return r
endProcedure matchGenMat
matchGenRep: procedure expose m.
parse arg o, wildC
xQ = 0
xS = 0
do ox=1 to m.o.0
if m.o.ox == '?' then do
xQ = pos('?', wildC, xQ+1)
if xQ < 1 then
call err 'unmatchted ?' ox
m.o.ox.re2 = xQ
end
else if m.o.ox == '*' then do
xS = pos('*', wildC, xS+1)
if xS < 1 then
call err 'unmatchted *' ox
m.o.ox.re2 = xS
end
else if m.o.ox == '&' & m.o.ox.ref >> '0' then do
if m.o.ox.ref > length(wildC) then
call err '&'m.o.ox.ref 'but wildcards' wildC
xQ = m.o.ox.ref
xS = xQ
m.o.ox.re2 = xQ
end
end
r = ''
do ox=1 to m.o.0
if abbrev(m.o.ox, 'c') then
r = r '||' quote(m.o.ox.val, "'")
else if m.o.ox == '&' & m.o.ox.re2 == 's' then
r = r '|| wert'
else if m.o.ox == '&' & m.o.ox.re2 == 'm' then
r = r '||' quote(mask, "'")
else if pos(m.o.ox, '*?&') > 0 then
r = r '|| m.vars.'m.o.ox.re2
end
if r=='' then
return "''"
else
return substr(r, 5)
endProcedure matchGenRep
/* copy match end *****************************************************/
/* copy comp begin *****************************************************
the shell compiler
syntax and semantics of the shell language see javaDoc
***********************************************************************/
/***** initialisation *************************************************/
/*--- module initialisation ------------------------------------------*/
compIni: procedure expose m.
if m.compIni = 1 then
return
m.compIni = 1
call pipeIni
call scanReadIni
cc = classNew('n Compiler u')
call mNewArea 'COMP.AST', '='
m.comp_chOp = '.-<@|?%^'
m.comp_chKind = '.-=#@:%^'
m.comp_chKindDesc = 'Obj Str Skel Text Exe Wsh Call Fun'
m.comp_chKiNO = '=:#'
m.comp_chKiNBOE = '=<#:' /* nonBLock only expression not Primary*/
m.comp_chDol = '$'
m.comp_chSpa = ' 'x2c('09')
call mPut 'COMP_EXTYPE.b', m.comp_chDol'{}' /* braces */
call mPut 'COMP_EXTYPE.d', m.comp_chDol /* data */
call mPut 'COMP_EXTYPE.s', m.comp_chDol /* strip */
call mPut 'COMP_EXTYPE.w', m.comp_chDol||m.comp_chSpa /* word */
m.comp.idChars = m.ut_alfNum'@_'
m.comp.wCatC = 'compile'
m.comp.wCatS = 'do withNew with for forWith ct proc arg table'
m.comp_astOps = m.comp_chOp'!)&'
m.comp_astOut = '.-@<^' /*ast kind for call out */
m.comp_astStats = ''
return
endProcedure compIni
compKindDesc: procedure expose m.
parse arg ki
kx = pos(ki, m.comp_chKind)
if length(ki) == 1 & kx > > 0 then
return "kind"word(m.comp_chKindDesc, kx)"'"ki"'"
else
return "badKind'"ki"'"
endProcedure compKindDesc
/*--- constructor of Compiler ----------------------------------------*/
comp: procedure expose m.
parse arg src
nn = oNew('Compiler')
m.nn.cmpRdr = in2File(src)
return nn
endProcedure comp
/*--- compile and run ------------------------------------------------*/
compRun: procedure expose m.
parse arg spec, inO, ouO, infoA
cmp = comp(inO)
r = compile(cmp, spec)
if infoA \== '' then
m.infoA = 'run'
if ouO \== '' then
call pipe '+F', ouO
call oRun r
if ouO \== '' then
call pipe '-'
return 0
endProcedure compRun
/*--- compile the source and return an oRunner with the code ---------*/
compile: procedure expose m.
parse arg m, spec
ki = '@'
spec = strip(spec, 'l')
if spec \== '' then
if pos(left(spec, 1), m.comp_chKind'*') > 0 then do
ki = left(spec, 1)
spec = substr(spec, 2)
end
call compBegin m, ki, spec
s = m.m.scan
res = compileWsh(m)
if 0 then
call compAstSay res, 0
if \ scanEnd(s) & m.m.out == '' then
return scanErr(s, 'wsh' compKindDesc(ki) "expected: compile",
"stopped before end of input")
call compEnd m
if res == '' then
return ''
cd = compAst2Rx(m, '!', res)
if 0 then
say cd
return oRunner(cd)
endProcedure compile
compBegin: procedure expose m.
parse arg m, ki, spec
m.m.scan = m'.scan'
m.m.out = ''
m.m.end = ''
m.m.defKind = ki
s = m.m.scan
if m.m.cmpRdr == '' then
call scanOpt scanSrc(s, spec), , '0123456789'
else
call scanReadOpen scanReadReset(scanOpt(s, , '0123456789'),
, m.m.cmpRdr), spec' '
return m
endProcedure compBegin
compEnd: procedure expose m.
parse arg m
if m.m.cmpRdr \== '' then
call scanReadClose m.m.scan
return m
endProcedure compEnd
/*--- compile wsh until eof or unknown syntax ------------------------*/
compileWsh: procedure expose m.
parse arg m
s = m.m.scan
res = compAst(m, '¢')
eOld = m.err.count
do while m.m.out == '' & \ scanEnd(s)
one = ''
if \ scanLit(s, '$#') then do
oldPos = scanPos(s)
one = compileOne(m, m.m.defKind)
if one == '' | m.one.0 = 0 then
if oldPos == scanPos(s) then
leave
end
else if pos(scanLook(s, 1), m.comp_chKind'*') > 0 then do
call scanChar s, 1
m.m.defKind = m.s.tok
one = compileOne(m, m.m.defKind)
end
else if \ scanName(s) then do
call scanErr s, 'kind or hook expected after $#'
end
else if m.s.tok == 'out' then do
m.m.out = scanPos(s)
leave
end
else if m.s.tok == 'end' then do
if m.m.end = '' then
m.m.end = scanPos(s)
one = compileOne(m)
end
else if m.s.tok == 'version' then do
call scanSpace s
vers = 'v41 v42'
if \ scanWord(s) | wordPos(m.s.tok, vers) < 1 then
call scanErr s, 'only versions' vers 'are supported'
call scanNl s, 1
end
else do
say 'interpreting hook' m.s.tok':' strip(scanLook(s))
interpret 'one = wshHook_'m.s.tok'(m)'
end
if m.err.count <> eOld then
return ''
if one \== '' then
call mAdd res, one
end
return compUnnest(res)
endProcedure compileWsh
/*--- compile or use hook for one part from spec or input -----------*/
compileOne: procedure expose m.
parse arg m, ki, hook
s = m.m.scan
m.m.comp_assVars = 0
call compSpComment m
if ki == '*' | m.m.end \== '' then do
do until scanLook(s, 2) == '$#' | scanEnd(s)
call scanNl s, 1
end
return ''
end
return compUnit(m, ki, '$#')
endProcedure compileOne
/*--- parse the whole syntax of a unit ------------------------------*/
compUnit: procedure expose m.
parse arg m, ki, stopper
s = m.m.scan
if pos(ki, m.comp_chKind) < 1 then
return scanErr(s, 'bad kind' ki 'in compUnit(...'stopper')')
else if ki <> '#' then do
a = compAst(m, '¢')
do forever
one = compPipe(m, ki)
if one \== '' then
call mAdd a, one
if \ scanLit(m.m.scan, '$;', '<>', '$<>') then
return compUnNest(a)
end
end
else do
res = compAST(m, '¢')
call scanChar s
if verify(m.s.tok, m.comp_chSpa) > 0 then
call mAdd res, compAst(m, '=', strip(m.s.tok, 't'))
do while scanNL(s, 1) & \ abbrev(m.s.src, stopper)
call mAdd res, compAst(m, '=', strip(m.s.src, 't'))
end
return res
end
endProcedure compUnit
compUnnest: procedure expose m.
parse arg a
do while m.a.0 = 1 & pos(m.a.kind, '¢-.;') > 0
n = m.a.1
if m.a.kind \== m.n.kind then
return a
call mFree a
a = n
end
return a
endProcedure compUnnest
/*--- compile an expression, type d=data, b=block w=word, s=strip ---*/
compExpr: procedure expose m.
parse arg m, type, ki, textEnd
s = m.m.scan
if symbol('m.comp_exType.type') \== 'VAR' then
call err s, 'bad type' type 'in compExpr'
if ki == '#' then do
if textEnd == '' then
call scanChar(s)
else if textEnd <= m.s.pos then
return ''
else
call scanChar s, textEnd - m.s.pos
if type == 's' then
res = compAst(m, '=', strip(m.s.tok))
else
res = compAst(m, '=', , m.s.tok)
res = compAST(m, '-', , res)
m.res.containsC = 1
m.res.containsD = 1
return res
end
else if ki == '%' | ki == '^' then do
call compSpComment m
vr = compVar(m, left('c', ki == '^'))
if vr == '' then
return ''
if m.vr.var == 'c' then
res = compAst(m, 'M')
else
res = compAst(m, ki, , compASTAddOp(m, vr, '&'))
call compSpComment m
if textEnd == '' | textEnd < m.s.pos then do
ex = compOpBE(m, '=', 1, , textEnd)
if ex \== '' then do
call mAdd res, ex
call compSpComment m
end
end
m.res.containsC = 1
m.res.containsD = 1
return res
end
if length(ki) \== 1 | pos(ki, '.-=@') < 1 then
return scanErr(s, 'bad kind' ki 'in compExpr')
res = compAST(m, translate(ki, '-;', '=@'))
m.res.containsC = 0
txtKi = translate(ki, '++=+', '.-=@')
laPrim = 0
gotTxt = 0
if pos(type, 'sb') > 0 then
m.res.containsC = compSpComment(m) >= 2
do forever
if textEnd \== '' then
if m.s.pos >= textEnd then
leave
if scanVerify(s, m.comp_exType.type, 'm') then do
if textEnd \== '' then
if m.s.pos > textEnd then do
m.s.tok = left(m.s.tok, length(m.s.tok) ,
+ textEnd - m.s.pos)
m.s.pos = textEnd
end
one = compAST(m, txtKi, m.s.tok)
if verify(m.s.tok, m.comp_chSpa) > 0 then
gotTxt = 1
end
else do
old = scanPos(s)
if \ scanLit(s, m.comp_chDol) then
leave
if pos(scanLook(s, 1), '.-') > 0 then
one = compCheckNN(m, compOpBE(m, , 1, 0),
, 'primary block or expression expected')
else
one = compPrimary(m)
if one = '' then do
call scanBackPos s, old
leave
end
laPrim = m.res.0 + 1
end
call mAdd res, one
if compComment(m) then
m.res.containsC = 1
end
if pos(type, 'bs') > 0 then do
do rx=m.res.0 by -1 to laPrim+1
one = m.res.rx
m.one.text = strip(m.one.text, 't')
if length(m.one.text) <> 0 then
leave
call mFree one
end
m.res.0 = rx
end
m.res.containsD = laPrim > 0 | gotTxt
return compAstFree0(res, '')
endProcedure compExpr
/*--- compile a primary and return code ------------------------------*/
compPrimary: procedure expose m.
parse arg m, ops
s = m.m.scan
if scanString(s) then
return compASTAddOp(m, compAST(m, '=', m.s.val), ops)
r = compVar(m, left('c', right(ops, 1) == '^'))
if r == '' then
return ''
if m.r.var \== 'c' then
return compASTAddOp(m, compAst(m, '&', m.r.var, r), ops)
else
return compASTAddOp(m, compAst(m, 'M'),
, left(ops, length(ops)-1))
endProcedure compPrimary
/*--- oPBE ops (primary or block or expression)
oDef = default Kind, oPre = opPrefix,
uniq=1 extract unique, uniq='<' prefix <
withEx <> 0: expression allowed ------------------------------*/
compOpBE: procedure expose m.
parse arg m, oDef, uniq, withEx, textEnd
s = m.m.scan
old = scanPos(s)
op = compOpKind(m, oDef)
if uniq == '<' & left(op, 1) \== '<' then
op = left('<', uniq == '<') || op
if pos(scanLook(s, 1), '/¢') > 0 then do
if uniq == 1 & length(op) == 1 then
if op == '.' then
op = '|.'
else if op == '=' then
op = '-='
else if pos(op, '-@<') > 0 then
op = op || op
return compBlock(m, op)
end
if compSpComment(m) == 0 ,
& pos(right(op, 1), m.comp_chKiNBOE) <= 0 then
return compPrimary(m, op)
if withEx \== 0 then do
res = compExpr(m, 's', right(op, 1), textEnd)
/* if pos(right(op, 1), m.comp_chKiNO) > 0 then
op = left(op, length(op)-1) ?????? */
if res \== '' then
return compASTAddOp(m, res, left(op, length(op)-1))
end
call scanBackPos s, old
return ''
endProcedure compOPBE
/*--- compile var of ^or % clause ------------------------------------*/
compCallVar: procedure expose m.
parse arg m, ki
call compSpComment m
vr = compVar(m, left('c', ki == '^'))
if vr == '' then
call scanErr m.m.scan, 'var expected after' ki
call compSpComment m
if m.vr.var == 'c' then
return compAst(m, 'M')
else
return compAst(m, ki, , compASTAddOp(m, vr, '&'))
endProcedure compCallVar
/*--- compile a pipe and return code ---------------------------------*/
compPipe: procedure expose m.
parse arg m, ki
s = m.m.scan
res = compAST(m, 'P', ' ', '', '')
do forever
one = compExprStmts(m, ki)
if one \== '' then do
if m.res.0 > 2 then
call scanErr s, '$| before statements needed'
call mAdd res, one
end
pre = left(m.comp_chDol, scanLit(s, m.comp_chDol))
if scanLook(s, 2) == '<>' then
leave
if scanLit(s, '<') then do
if m.res.2 == '' then
m.res.2 = compAst(m, '.')
else
call mAdd m.res.2, compAst(m, '+', ', ')
call mAdd m.res.2, compOpBE(m, '<', '<')
m.res.text = m.res.text'f'
end
else if scanLit(s, '>>', '>') then do
if m.res.1 <> '' then
call scanErr s, 'duplicate output'
m.res.text = if(m.s.tok == '>', 'F', 'A') ,
||substr(m.res.text, 2)
m.res.1 = compOpBE(m, '<', '<')
end
else if scanLit(s, '|') then do
if m.res.0 < 3 then
call scanErr s, 'stmts expected before |'
call compSpNlComment m
call mAdd res, compCheckNE(m, compExprStmts(m, ki),
, 'stmts or expressions after | expected')
end
else
leave
end
call scanBack s, pre
if m.res.0 > 3 | m.res.1 \== '' | m.res.2 \== '' then
return res
one = if(m.res.0 = 3, m.res.3)
call mFree res
return one
endProcedure compPipe
/*--- compile expressions and stmts ---------------------------------*/
compExprStmts: procedure expose m.
parse arg m, ki
kiTxt = translate(ki, ';-', '@=')
s = m.m.scan
res = compAst(m, '¢')
withNew = ''
nlLe = 0 /* sophisticated logic using left and right NLs*/
tb = ''
do forever
if tb \== '' then do
fx=0
fy = m.tb.0
fL = m.tb.fy
aa = ''
do forever
call compSpComment m
px = m.s.pos
do until px < m.ff.end | fx >= m.tb.0
fx = fx + 1
ff = m.tb.fx
end
if fx > m.tb.0 then do
if compExpr(m, 's', m.fL.colKind) == '' then
leave
call err 'fallout table'
end
e1 = compExpr(m, 's', m.ff.colKind, m.ff.end)
if e1 == '' then
leave
else if fx > m.tb.0 then
call err 'fallout table'
if m.ff.colOps \== '' then
e1 = compAstAddOp(m, e1, m.ff.colOps)
if aa == '' then
aa = compAst(m, '¢')
call mAdd aa, compAst(m, 'A', ,
, compAst(m, '=', m.ff.name), e1)
end
if aa \== '' then
call mAdd res, compAst(m, 'F', 'with',
, compAst(m, '.', ,
, compAst(m, '+', "oNew('"m.tb.class"')")),
, aa, compAst(m, '*', '!.'))
/* px = m.s.pos
e1 = compExpr(m, 'w', '=')
if e1 \== '' then do
aa = compAst(m, '¢')
fx = 0
do until e1 == ''
do fx=fx+1 to m.tb.0 until px < m.ff.end
ff = m.tb.fx
end
if fx > m.tb.0 then
call scanErr s, 'right of all table fields'
if m.s.pos <= m.ff.pos then
call scanErr s, 'before table field' m.ff.name
call mAdd aa, compAst(m, 'A', ,
, compAst(m, '=', m.ff.name), e1)
call compSpComment m
px = m.s.pos
e1 = compExpr(m, 'w', '=')
end
call mAdd res, compAst(m, 'F', 'with',
, compAst(m, 'o', "oNew('"m.tb.class"')"),
, aa, compAst(m, '*', '$.'))
end
*/ nlRi = scanNL(s)
end
else if ki == ':' then do
call compSpNlComment m, '*'
nlRi = 0
end
else if ki == '@' then do
call compSpNlComment m
one = compExpr(m, 's', ki)
if one == '' then
nlRi = 0
else if m.one.0 < 1 then
call scanErr s, 'assert not empty' m.one.0
else do
do forever /* scan all continued rexx lines */
nlRi = 1
la = m.one.0
la = m.one.la
if m.la.kind \== '+' then
leave
m.la.text = strip(m.la.text, 't')
if right(m.la.text, 1) \== ',' then
leave
m.la.text = strip(left(m.la.text,
, length(m.la.text)-1), 't')' '
call compSpNlComment m
cont = compExpr(m, 's', '@')
if cont == '' | m.cont.kind \== m.one.kind then
call scanErr s, 'bad rexx continuation'
call mAddSt one, cont
call mFree cont
end
call mAdd res, one
end
end
else if ki == '%' | ki == '^' then do
do cc=0 while compSpNlComment(m)
end
one = compExpr(m, 's', ki)
nlRi = one \== ''
if nlRi then
call mAdd res, one
end
else do
do cc=0 while compComment(m)
end
one = compExpr(m, 'd', ki)
nlRi = scanNL(s)
if one == '' then do
if nlLe & nlRi & cc < 1 then
call mAdd res,compAst(m, kiTxt, ,compAst(m,'='))
end
else if m.one.containsD | (nlLe & nlRi,
& \ (cc > 0 | m.one.containsC)) then do
call mAdd res, one
end
else do
call mFree one
end
end
nlLe = nlRi
if \ nlRi then do
one = compStmt(m, ki)
if one \== '' then do
call mAdd res, one
end
else if scanLit(s, 'table', '$table') then do
tb = compTable(m, ki)
end
else do
if withNew \== '' then do
r = compAst(m, 'F', 'withNew', '', res,
, compAst(m, '*', '!.'))
m.r.class = classNew('n* CompTable u' ,
substr(m.m.comp_assVars, 3))
m.r.1 = compAst(m, '.', ,
, compAst(m, '+', "oNew('"m.r.class"')"))
res = withNew
call mAdd res, r
m.m.comp_assVars = assVars
end
if scanLit(s, 'withNew', '$withNew') then do
withNew = res
assVars = m.m.comp_assVars
m.m.comp_assVars = ''
res = compAst(m, '¢')
end
else
return compAstFree0(res)
end
end
end
endProcedure compExprStmts
/*--- compile a single statement -------------------------------------*/
compStmt: procedure expose m.
parse arg m, ki
s = m.m.scan
res = compAss(m)
if res \== '' then
return res
pre = ''
old = scanPos(s)
if scanLit(s,m.comp_chDol'$',m.comp_chDol'@',m.comp_chDol,'@') then
pre = m.s.tok
if pre == m.comp_chDol'$' then
return compCheckNN(m, compOpBE(m,'=', 1),
, 'block or expression expected after $$')
if right(pre, 1) == '@' then do
one = compOpBE(m, '@')
if one \== '' then
return compAstAddOp(m, one, ')')
end
wCat = compName(m, 'sv')
fu = m.s.tok
if right(pre, 1) == '@' & wCat \== 's' then
call scanErr s, 'primary, block or expression expected'
if fu == 'arg' then do
res = compAst(m, 'R')
do forever
call compSpComment m
if scanLit(s, ',') then
a1 = compAst(m, '+', ',')
else do
gotV = 1
a1 = compVar(m, 'v')
end
if a1 \== '' then
call mAdd res, a1
else if gotV == 1 then
return res
else
call scanErr s, 'empty arg'
end
end
if fu == 'ct' then do
call compSpComment m
return compAst(m, 'C', , compCheckNN(m, compStmt(m, ki),
, 'ct statement'))
end
if fu == 'do' then do
call compSpComment m
pre = compExpr(m, 's', '@')
res = compAst(m, 'D', , pre)
p1 = m.pre.1
if pre \== '' then do
txt = ''
do px=1 to m.pre.0
pC = m.pre.px
if m.pC.kind \== '+' then
leave
txt = txt m.pC.text
cx = pos('=', txt)
if cx > 0 then do
m.res.text = strip(left(txt, cx-1))
leave
end
end
end
call compSpComment m
call mAdd res, compCheckNN(m, compStmt(m, ki), 'stmt after do')
return res
end
if wordPos(fu, 'for forWith with') > 0 then do
res = compAst(m, 'F', fu)
call compSpComment m
if fu \== 'with' then do
b = compVar(m)
end
else do
b = compAss(m)
if b == '' then
b = compCheckNE(m, compExpr(m, 's', '.'),
, "assignment or expression after with")
end
call compSpComment m
st = compCheckNN(m, compStmt(m, ki), "var? statement after" fu)
if b = '' then do
b = compBlockName(m, st)
if b \== '' then
b = compAst(m, '=', b)
else if \ abbrev(fu, 'for') then
call scanErr s, "variable or named block after" fu
end
call mAdd res, b, st
return res
end
if fu == 'proc' then do
call compSpComment m
nm = ''
if compName(m, 'v') == 'v' then do
nm = m.s.tok
call compSpComment m
end
st = compCheckNN(m, compStmt(m, ki), 'proc statement')
if nm == '' then do
nm = compBlockName(m, st)
if nm == '' then
call scanErr s, 'var or namedBlock expected after proc'
end
return compAst(m, 'B', '', compAst(m, '=', nm), st)
end
call scanBack s, pre || fu
return ''
endProcedure compStmt
compBlockName: procedure expose m.
parse arg m, a
a1 = m.a.1
if m.a.kind == '¢' then
return m.a.text
else if m.a.kind == '*' & m.a1.kind == '¢' then
return m.a1.text
return ''
endProcedure compBlockName
compVar: procedure expose m.
parse arg m, vk
if pos('o', vk) > 0 then call err(sdf)/0
s = m.m.scan
ty = compName(m, 'v' || vk)
if ty \== '' then do
r = compAst(m, '=', m.s.tok)
m.r.var = ty
return r
end
if \ scanLit(s, '{') then
return ''
call scanLit s, '?', '>'
f = m.s.tok
r = compCheckNE(m, compExpr(m, 'b', '='), 'var name')
if \scanLit(s, '}') then
call scanErr s, 'closing } missing after {'
m.r.var = f
return r
endProcedure compVar
compAss: procedure expose m.
parse arg m, vk
s = m.m.scan
old = scanPos(s)
call scanLit s, m.comp_chDol'=', '='
pr = m.s.tok
if pr \== '' then
call compSpComment m
v = compVar(m, vk)
if v \== '' then do
call compSpComment m
if \ scanLit(s, '=') then do
call scanBackPos s, old
return ''
end
end
else if pr == '' then
return ''
else
oldInfo = scanInfo(s)
eb = compCheckNE(m, compOpBE(m, '=', 1),
, 'block or expression in assignment after' pr)
if m.eb.kind == '¢' then
eb = compAstAddOp(m, eb, '-')
if v == '' then do
v = compBlockName(m, eb)
if v == '' then
call scanEr3 s, 'var or namedBlock expected',
'in assignment after' pr, oldInfo
v = compAst(m, '=', v)
m.v.var = 'v'
end
if m.m.comp_assVars \== 0 then
if m.v.kind == '=' & m.v.var == 'v' then do
if words(m.v.text) \= 1 then
call compAstErr v, 'bad var'
if m.eb.kind == '*' then
ki = left(m.eb.text, 1)
else
ki = m.eb.kind
if pos(ki, '-=s') > 0 then
f = ', f' m.v.text 'v'
else if pos(ki, '.<@o') > 0 then
f = ', f' m.v.text 'r'
else
call compAstErr eb, 'string or object'
if pos(f, m.m.comp_assVars) < 1 then
m.m.comp_assVars = m.m.comp_assVars || f
end
return compAst(m, 'A', , v, eb)
endProcedure compAss
/*--- block deals with the correct kind and operators
the content is parsed by compUnit ------------------------------*/
compBlock: procedure expose m.
parse arg m, ops
s = m.m.scan
if \ scanLit(s, '¢', '/') then
return ''
start = m.s.tok
if ops == '' | pos(right(ops, 1), m.comp_chKind) < 1 then
return scanErr(s, 'bad kind' ops 'for block')
ki = right(ops, 1)
ops = left(ops, length(ops)-1)
starter = start
if start == '¢' then
stopper = m.comp_chDol'!'
else do
call scanVerify s, '/', 'm'
starter = '/'m.s.tok'/'
stopper = m.comp_chDol || starter
if \scanLit(s, '/') then
call scanErr s, 'ending / after stopper' stopper 'expected'
end
res = compUnit(m, ki, stopper)
if \ scanLit(s, stopper, substr(stopper, 2)) then
call scanErr s, 'ending' stopper 'expected after' starter
if abbrev(starter, '/') then
m.res.text = substr(starter, 2, length(starter)-2)
return compAstAddOp(m, res, ops)
endProcedure compBlock
/*--- compile table body and return table ----------------------------*/
compTable: procedure expose m.
parse arg m, ki
s = m.m.scan
call compSpComment m
if scanNl(s) then
call compSpComment m
res = compAst(m, 'T', 'c')
flds = ''
pB = 1
do forever
opKi = compOpKind(m)
if compName(m, 'v') \== 'v' then
if opKi == '' then
leave
else
call scanErr s, 'table col expected after' opKi
f1 = compAst(m, 'T')
m.f1.pos = pB
if opKi == '' then
opKi = translate(ki, '=', ':')
m.f1.colKind = right(opKi, 1)
m.f1.colOps = left(opKi, length(opKi)-1)
m.f1.name = m.s.tok
if pos(left(opKi, 1), '-=#') > 0 then
flds = flds', f' m.s.tok 'v'
else
flds = flds', f' m.s.tok 'r'
call compSpComment m
pB = m.s.pos
m.f1.end = pB
m.f1.text = 'f blabla' m.f1.name m.f1.pos pB opKi
call mAdd res, f1
if scanLit(s, ',') then
call compSpComment m
end /* ?????????????????????????
do while compName(m, 'v') == 'v'
f1 = compAst(m, 'T')
m.f1.end = m.s.pos
m.f1.pos = m.s.pos - length(m.s.tok)
m.f1.name = m.s.tok
m.f1.text = 'f' m.f1.name m.f1.pos m.f1.end
call mAdd res, f1
flds = flds', f' m.s.tok 'v'
call compSpComment m
end ???????? */
if \ scanNl(s) then
call scanErr s, 'name or nl after table expected'
if m.res.0 < 1 then
call scanErr s, 'no names in table'
m.f1.end = ''
m.res.class = classNew('n* CompTable u' substr(flds, 3))
m.res.text = 'c' cl
return res
endProcedure compTable
/**** lexicals ********************************************************/
/*--- skip a comment. return 0 if there is none ----------------------*/
compComment: procedure expose m.
parse arg m
s = m.m.scan
got = 0
do forever
if scanLit(s, m.comp_chDol'**') then
m.s.pos = 1 + length(m.s.src) /* before next nl */
else if scanLit(s, m.comp_chDol'*+') then
call scanNL s, 1
else if scanLit(s, m.comp_chDol'*(') then do
do forever
if scanVerify(s, m.comp_chDol, 'm') then iterate
if scanNL(s) then iterate
if compComment(m) then iterate
if \ scanLit(s, m.comp_chDol) then
call scanErr s, 'source end in comment'
if scanLit(s, '*)') then
return 1
if scanLit(s, m.comp_chDol) then iterate
if scanString(s) then iterate
end
end
else
return got
got = 1
end
endProcedure compComment
/*--- skip spaces and comments ---------------------------------------*/
compSpComment: procedure expose m.
parse arg m, xtra
s = m.m.scan
got = 0
do forever
if scanVerify(s, m.comp_chSpa) then
got = bitOr(got, 1)
else if compComment(m) then
got = bitOr(got, 2)
else if xtra == '' then
return got
else if \ scanLit(s, xtra) then
return got
else do
got = bitOr(got, 4)
m.s.pos = 1+length(m.s.src)
end
end
endProcedure compSpComment
/*--- skip spaces, NLs and comments ----------------------------------*/
compSpNlComment: procedure expose m.
parse arg m, xtra
found = 0
do forever
if compSpComment(m, xtra) < 1 then
if \ scanNL(m.m.scan) then
return found
found = 1
end
endProcedure compSpNlComment
/*--- scan a name in one of the categories
v=var, c=compile, s=stmt ----------------------------------*/
compName: procedure expose m.
parse arg m, cats
s = m.m.scan
if \ scanName(s) then
return ''
if wordPos(m.s.tok, m.comp.wCatS) > 0 then do
if pos('s', cats) > 0 then
return 's'
end
else if wordPos(m.s.tok, m.comp.wCatC) > 0 then do
if pos('c', cats) > 0 then
return 'c'
end
else if pos('v', cats) > 0 then do
return 'v'
end
call scanBack s, m.s.tok
return ''
endProcedure compName
compOpKind: procedure expose m.
parse arg m, op
s = m.m.scan
if scanVerify(s, m.comp_chOp || m.comp_chKiNO) then
op = m.s.tok
else if op == '' then
return ''
/* ??????? temporary until old syntax vanished ????? */
x = verify(op, '%^', 'm')
if x > 0 & x < length(op) then
call scanErr s, 'old syntax? run not at end'
if right(op, 1) == '<' then
op = op'='
kx = verify(op, m.comp_chKiNO, 'm')
if kx \== 0 & kx \== length(op) then
call scanErr s, 'kind' substr(op, kx, 1) 'not after ops'
if pos(right(op, 1), m.comp_chKind) == 0 then
call scanErr s, 'no kind after ops' op
return op
endProcedure compOpKind
compSpNlComment: procedure expose m.
/**** small helper routines ******************************************/
/*--- if va == null then issue an error with msg --------------------*/
compCheckNN: procedure expose m.
parse arg m, va, msg
if va == '' then
call scanErr m.m.scan, msg 'expected'
return va
endProcedure compCheckNN
/*--- return true iff expression is empty ---------------------------*/
compIsEmpty: procedure expose m.
parse arg m, a, block0
do forever
if a == '' then
return 1
else if m.a.kind == '*' then
a = m.a.1
else if m.a.kind \== '¢' then
return 0
else if block0 then
return 0
else if m.a.0 = 1 then
a = m.a.1
else
return m.a.0 < 1
end
endProcedure compIsEmpty
/*--- if va == null or empty then issue an error with msg -----------*/
compCheckNE: procedure expose m.
parse arg m, ex, msg
e1 = left(ex, 1)
if compIsEmpty(m, ex, 1) then
call scanErr m.m.scan, msg 'expected'
return ex
endProcedure compCheckNE
/**** AST = Astract Syntax Tree ****************************************
------- atoms, no children
= string constant
+ rexx fragment
------- containers (any number of children)
- string expression
. object expression
; rexx statements
¢ block
------- molecules
* operand chain ==> 1 operands in text, as in syntax plus
) run ($@ stmt), & variable access, ! execute
& variable access==> 1
A assignment ==> 2
B proc ==> 2
C ct ==> 1
D do ==> 2
F for + with ==> 2
P Pipe ==> * 1=input 2=output , 3..* piped stmtBlocks
R aRg * list of arguments/separators
T Table
M compile
% RunOut ==> 1,2 (Run, arguments)
^ RunRet ==> 1,2 (Run, arguments)
***********************************************************************/
/*--- create a new AST -----------------------------------------------*/
compAST: procedure expose m.
parse arg m, ki, txt
n = mNew('COMP.AST')
if length(ki) <> 1 then
return err('compAST bad kind' ki) / 0
m.n.kind = ki
m.n.text = txt
if pos(ki, '¢;-.*&ABCDFPRTM%^') > 0 then do
do cx=1 to arg()-3
m.n.cx = arg(cx+3)
end
m.n.0 = cx-1
if ki == '*' then do
if verify(txt, m.comp_astOps) > 0 then
return err('compAst ki=* bad ops:' txt) / 0
end
else if txt \== '' & pos(ki, '&*FPT') < 1 then
return err('kind' ki 'text='txt'|')/0
end
else if pos(ki, '=+') > 0 then do
m.n.0 = 'kind'ki
end
else do
return err( "compAst kind '"ki"' not supported") / 0
end
return n
endProcedure compAST
/*--- free AST if empty ----------------------------------------------*/
compASTFree0: procedure expose m.
parse arg a, ret
if m.a.0 > 0 then
return a
call mFree a
return ret
endProcedure compAstFree0
/*--- add operandands to an AST -------------------------------------*/
compASTAddOp: procedure expose m.
parse arg m, a, ops
if verify(ops, m.comp_astOps) > 0 then
return err('addOp bad ops:' ops) / 0
k = if(m.a.kind=='*', left(m.a.text, 1), m.a.kind)
do while right(ops, 1) == k
ops = left(ops, length(ops)-1)
end
if ops == '' then
return a
if ki \== '*' then
return compAst(m, '*', ops, a)
m.a.text = ops || m.a.text
return a
endProcedure compAstAddOp
/*--- return the kind of an AST --------------------------------------*/
compASTKind: procedure expose m.
parse arg m, a
m.m.astOps = ''
if \ abbrev(a, 'COMP.AST.') then
return left(a, 1)
c = a
do while m.c.kind == 'ops'
if m.c.text \== '' then
return left(m.c.text, 1)
c = m.c.1
end
if a == c then
return '?'
return compAstKind(m, c)
endProcedure compASTKind
compAstSay: procedure expose m.
parse arg a, lv
if \ abbrev(a, 'COMP.AST.') then do
if a \== '' then
return err('bad ast' a)
say left('', 19)': * empty ast'
return
end
say lefPad(left('', lv) m.a.kind, 10) ,
|| rigPad(if(dataType(m.a.0, 'n'), m.a.0), 3),
'@'rigPad(substr(a, 10), 4)':' m.a.text'|'
if dataType(m.a.0, 'n') then do cx=1 to m.a.0
call compAstSay m.a.cx, lv+1
end
return
endProcedure compAstSay
compAstErr: procedure expose m.
parse arg a, txt
call errSay txt
call compAstSay a, 0
return err(txt)
endProcedure compAstErr
/*--- return the code for an AST with operand chain trg --------------*/
compCode2rx: procedure expose m.
parse arg m, ops, f
if ops == '' then
return f
o1 = right(ops, 1)
oR = left(ops, length(ops)-1)
if pos(o1, ')!') > 0 then
return compCode2rx(m, oR, strip(f))
if pos(o1, '-.<|?@') > 0 then
return compRun2rx(m, ops, quote(oRunner(f)))
call err 'compCode2rx bad ops' ops 'code='f
endProcedure compCode2rx
compCon2rx: procedure expose m.
parse arg m, ops, f, a
do ox=length(ops) by -1 to 1 while pos(substr(ops,ox,1), '.-')>0
end
if substr(ops, ox+1, 1) == '.' then
f = s2o(f)
if length(f) < 20 then
v = quote(f, "'")
else if a \== '' & m.a.text == f then
v = 'm.'a'.text'
else
v = 'm.'compAst(m, '=', f)'.text'
if substr(ops, ox+1, 1) == '.' then
return compObj2rx(m, left(ops, ox), v)
else
return compString2rx(m, left(ops, ox), v)
endProcedure compCon2rx
compString2rx: procedure expose m.
parse arg m, ops, f
if ops == '' then
return f
o1 = right(ops, 1)
oR = left(ops, length(ops)-1)
if pos(o1, '!') then
return compCode2rx(m, oR, 'call out' f)
if o1 == '-' then
return compString2rx(m, oR, f)
if o1 == '.' then
return compObj2rx(m, oR, 's2o('f')')
if o1 == '&' then do
o2 = substr('1'ops, length(ops), 1)
if pos(o2, '.<^%@)') < 1 then
return compString2rx(m, oR, 'vGet('f')')
else
return compObj2rx(m, oR, 'vGet('f')')
end
if o1 == '<' then
return compFile2rx(m, oR, 'file('f')')
call err 'compString2rx bad ops' ops
endProcedure compString2rx
compObj2rx: procedure expose m.
parse arg m, ops, f
if ops == '' then
return f
o1 = right(ops, 1)
oR = left(ops, length(ops)-1)
if o1 == '.' then
return compObj2rx(m, oR, f)
if o1 == '-' then
return compString2rx(m, oR, 'o2string('f')')
if o1 == '!' then
return compCode2rx(m, oR, 'call out' f)
if o1 == '<' then
return compFile2rx(m, oR, 'o2file('f')')
if o1 == '@' then
return compRun2Rx(m, oR, f)
if pos(o1, ')%^') > 0 then
return compRun2rx(m, ops, f)
call err 'compObj2rx bad ops' ops 'for' f
endProcedure compObj2rx
compRun2rx: procedure expose m.
parse arg m, ops, f
if ops == '' then
return f
o1 = right(ops, 1)
oR = left(ops, length(ops)-1)
if o1 == '@' then
return compRun2Rx(m, oR, f)
if pos(o1, ')%') > 0 then
return compCode2Rx(m, oR, 'call oRun' f)
if o1 == '^' then
if pos(right(oR, 1), '.<^%') < 1 then
return compString2Rx(m, oR, 'oRun('f')')
else
return compObj2Rx(m, oR, 'oRun('f')')
return compObj2rx(m, ops, f)
endProcedure compRun2rx
compFile2rx: procedure expose m.
parse arg m, ops, f
if ops == '' then
return f
o1 = right(ops, 1)
oR = left(ops, length(ops)-1)
if pos(o1, '<.@') > 0 then
return compFile2rx(m, oR, f)
if o1 == '|' | o1 == '?' then
return compObj2Rx(m, oR, 'jSingle('f ||if(o1=='?', ", ''")')')
return compRun2rx(m, ops, f)
endProcedure compFile2rx
compAst2rx: procedure expose m.
parse arg m, ops, a
ki = m.a.kind
/* astStats ausgeschaltet
if pos(ki, m.comp_astStats) < 1 then do
m.comp_astStats = m.comp_astStats ki
m.comp_astStats.ki = 0
m.comp_astStatT.ki = 0
end
m.comp_astStats.ki = m.comp_astStats.ki + 1
if m.a.text \== '' then
m.comp_astStatT.ki = m.comp_astStatT.ki + 1
if ki == '*' then do
k2 = vGet(a'.1>>KIND')
if symbol('m.comp_astStat1.k2') \== 'VAR' then
m.comp_astStat1.k2 = 1
else
m.comp_astStat1.k2 = m.comp_astStat1.k2 + 1
end */
if ki == '+' & ops == '' then
return m.a.text
if ki == '=' then
return compCon2Rx(m, ops, m.a.text, a)
if ki == '*' then
return compAst2Rx(m, ops || m.a.text, m.a.1)
o1 = right(ops, 1)
oR = left(ops, max(0, length(ops)-1))
if ki == '-' then
return compString2rx(m, ops, compCatRexxAll(m, a,,, ' || '))
if ki == '.' then
return compObj2Rx(m, ops, compCatRexxAll(m, a,,, ' || '))
if ki == ';' then
return compCode2Rx(m, ops, compCatRexxAll(m, a,,,' || '))
if ki == '¢' then do
a1 = m.a.1
if m.a.0 == 1 & m.a1.kind == '¢' then
return compAst2Rx(m, ops, a1)
if o1 == '-' then do
res = compAst2CatStr(m, a)
if res \== '' then /* () necessary if part of expression */
return compString2rx(m, oR, '('strip(res)')')
end
if o1 == '.' then
return compAst2Rx(m, ops'|', a)
if pos(o1, '|?') > 0 then
if m.a.0 = 1 & compAstOut(a1) then
return compAst2Rx(m, oR, a1)
res = ''
do ax=1 to m.a.0
res = res';' compAst2rx(m, '!', m.a.ax)
end
if verify(res, '; ') = 0 then
res = 'nop'
else
res = 'do'res'; end'
if pos(o1, '-@!)') > 0 then
return compCode2Rx(m, ops, res)
if pos(o1, '|?<') > 0 then
return compCode2Rx(m, ops'<@', res)
end
if ki == '&' then do
nm = compAst2Rx(m, '-', m.a.1)
if m.a.text=='' | m.a.text=='v' then
return compString2rx(m, ops'&', nm)
else if m.a.text == '?' then
return compString2rx(m, ops, 'vIsDefined('nm')')
else if m.a.text == '>' then
return compString2rx(m, ops, 'vIn('nm')')
else
call compAstErr a, 'bad text' m.a.text 'in ast &'
end
if ki == '%' | ki == '^' then do
c1 = compAst2Rx(m, '.', m.a.1)
if m.a.0 > 1 then
c1 = c1',' compAst2Rx(m, '', m.a.2)
return compRun2Rx(m, ops || ki, c1)
end
if ki == 'A' then do /* assignment */
nm = compAst2Rx(m, '-', m.a.1)
vl = m.a.2
if m.vl.kind == '=' | m.vl.kind == '-' ,
| (m.vl.kind == '*' & right(m.vl.text, 1) == '-') then
return compCode2Rx(m, ops,
, 'call vPut' nm',' compAst2Rx(m, '-', vl))
else
return compCode2Rx(m, ops,
, 'call vPut' nm',' compAst2Rx(m, '.', vl))
end
if ki == 'B' then do /* proc */
call vPut utInter('return' compAst2Rx(m, '-', m.a.1)),
, oRunner(compAst2Rx(m ,'!', m.a.2))
return ''
end
if ki == 'C' then do /* ct */
call utInter compAst2Rx(m, '!', m.a.1)
return ''
end
if ki == 'D' then do /* do */
res = 'do' compAst2rx(m, '', m.a.1)
if m.a.text \== '' then
res = res"; call vPut '"m.a.text"'," m.a.text
return compCode2Rx(m, ops, res';' compAst2Rx(m, '!', m.a.2),
|| "; end")
end
if ki == 'F' then do /* for... */
a1 = m.a.1
st = compAst2Rx(m, '!', m.a.2)
if abbrev(m.a.text, 'for') then do
if m.a.1 == '' then
v = "''"
else
v = compAst2Rx(m, '-', m.a.1)
if m.a.text == 'for' then
s1 = 'do while vIn('v')'
else if m.a.text \== 'forWith' then
call compAstErr a, 'bad for...'
else
s1 = 'call vWith "+"; do while vForWith('v')'
return compCode2Rx(m, ops, s1';' st'; end')
end
else if \ abbrev(m.a.text, 'with') then
call compAstErr a, 'bad with...'
if m.a1.kind \== 'A' then do
v = compAst2Rx(m, '.', a1)
end
else do
v = compAst2Rx(m, ,a1)
if \ abbrev(v, 'call vPut ') | pos(';', v) > 0 then
call scanErr s, 'bad vPut' v
v = 'vPut('substr(v, 11)')'
end
ret1 = 'call vWith "+",' v';' st
if m.a.0 <= 2 then
return ret1"; call vWith '-'"
a3 = m.a.3
if m.a3.kind \== '*' then
call compAstErr a, 'for/with a.3 not *'
return ret1';' compObj2Rx(m, m.a3.text, "vWith('-')")
end
if ki == 'P' then do /* pipe */
if ((left(m.a.text, 1) == ' ') \== (m.a.1 == '')) ,
| ((substr(m.a.text, 2) == '') \== (m.a.2 == '')) ,
| (m.a.0 <= 3 & m.a.text == '') then
call compAstErr a, 'bad/trivial astPipe'
res = ''
do ax=3 to m.a.0
a1 = ''
if ax < m.a.0 then /* handle output */
t1 = 'N'
else if m.a.1 == '' then
t1 = 'P'
else do
t1 = left(m.a.text, 1)
a1 = compAst2Rx(m, '.', m.a.1)
end
if ax == 3 then do /* handle input */
t1 = '+'t1 || substr(m.a.text, 2)
if m.a.2 \== '' then
a1 = a1',' compAst2Rx(m, '.', m.a.2)
end
else
t1 = t1'|'
res = res"; call pipe '"t1"'," a1 ,
";" compAst2Rx(m, '!', m.a.ax)
end
return compCode2Rx(m, ops, substr(res, 3)"; call pipe '-'")
end
if ki == 'R' then do /* aRg statement */
prs = 'parse arg ,'
pts = ''
do ax=1 to m.a.0
a1 = m.a.ax
if m.a1.kind = '+' & m.a1.text == ',' then
prs = prs','
else do
prs = prs 'ggAA'ax
pts = pts'; call vPut' compAst2Rx(m, '-', a1)', ggAA'ax
end
end
return compCode2rx(m, ops, prs pts)
end
if ki == 'M' then do
if m.a.0 = 0 then
args = ''
else
args = ',' compAst2Rx(m, , m.a.1)
return compRun2rx(m, ops, 'compile(comp(in2Buf())' args')')
end
call compAstErr a, 'compAst2rx bad ops='ops 'kind='ki 'ast='a
endProcedure compAst2rx
compAstOut: procedure expose m.
parse arg a
if m.a.kind \== '*' then
return pos(m.a.kind, m.comp_astOut) > 0
return pos(left(m.a.text, 1), m.comp_astOut) > 0
endProcedure compAstOut
compAst2CatStr: procedure expose m.
parse arg m, a
res = ''
if compAstOut(a) then
res = compCatRexx(res, compAst2rx(m, , a), ' ')
else if m.a.kind \== '¢' then
return ''
else do ax=1 to m.a.0
b = compAst2CatStr(m, m.a.ax)
if b == '' then
return ''
res = compCatRexx(res, b, ' ')
end
return res
endProcedure compAst2CatStr
compCatRexxAll: procedure expose m.
parse arg m, a, ops, mi, sep
res = ''
do ax=1 to m.a.0
a1 = m.a.ax
res = compCatRexx(res, compAst2rx(m, ops, m.a.ax), mi , sep)
end
return strip(res)
endProcedure compCatRexxAll
/*--- cat two rexx parts, avoid strange effects--------------------*/
compCatRexx: procedure expose m.
parse arg le, ri, mi, sep
if mi \== '' then
return le || mi || ri
lr = right(le, 1)
rl = left(ri, 1)
if (lr == "'" | lr == '"') then do
if rl == lr then /* "a","b" -> "ab" */
return left(le, length(le)-1) || substr(ri, 2)
else if rl == '(' then /* "a",( -> "a" || ( */
return le||sep||ri /* avoid function call */
end
else if pos(lr, m.comp.idChars) > 0 then
if pos(rl, m.comp.idChars'(') > 0 then
return le || sep || ri /* a,b -> a || b */
return le || ri
endProcedure compCatRexx
/* copy comp end *****************************************************/
/* copy scan begin ************************************************
Achtung: inc generiert SB aus scan, Aenderungen nur in scan|
SB = scanBasic: single line, no reader, no newLines, class not needed
scanSrc(m, source) starts scanning a single line = scanBasic
scanLook(m,len) : returns next len chars, pos is not moved
scanChar(m,len) : scans next len chars
scanString(m,q): scan a String with quote q. (with doubble = 1)
scanVerify(m,c,o): verify(...,c,o,...)
scanEnd(m) : returns whether we reached end of input
scanLit(m,lit) : scan Literal lit if present or return 0
scanChar(m,n) : scan next n characters
scanName(m) : scan a name
ScanNat(m) : scan a natural number (without sign)
scanString(m,q): scan a String with quote q. (with doubble = 1)
scanVerify(m,c,o): verify(...,c,o,...)
scanKeyValue(m): scan a key = value clause (with spaces)
scanWord(m,st,uc) : scan a space delimited word or a string,
st=stopper, if u=1 then uppercase non-strings
scanSpace(m) : skips over spaces (and nl and comment if \ basic
scanInfo(m) : text of current scan location
scanErr(m, txt): error with current scan location
m is an address, to store our state
returns: true if scanned, false otherwise
if a scan function succeeds, the scan position is moved
m.m.tok ==> last token
m.m.val ==> last value for scanString/Word
m.m.pos ==> scan position
m.m.src ==> scan source
***********************************************************************/
/*--- start basic scannig: set new src, reset outFields -------------*/
scanSrc: procedure expose m.
parse arg m, m.m.src
m.m.pos = 1
m.m.tok = ''
m.m.scanIsBasic = 1
return m
endProcedure scanSrc
scanBasic: procedure expose m.
parse arg src
if symbol('m.scan.0') == 'VAR' then
m.scan.0 = m.scan.0 + 1
else
m.scan.0 = 1
return scanSrc('SCAN.'m.scan.0, src)
endProcedure scanBasic
scanEr3: procedure expose m.
parse arg m, txt, info
return err('s}'txt'\n'info)
scanErr: procedure expose m.
parse arg m, txt
if arg() > 2 then
return err(m,'old interface scanErr('m',' txt',' arg(3)')')
return scanEr3(m, txt, scanInfo(m))
/*--- scanInfo: text of current scan position for scanErr -----------*/
scanInfo: procedure expose m.
parse arg m
if m.m.scanIsBasic then
return scanSBInfo(m)
else
interpret objMet(m, 'scanInfo')
endProcedure scanInfo
scanSBInfo: procedure expose m.
parse arg m
return 'last token' m.m.tok 'scanPosition' ,
strip(substr(m.m.src, m.m.pos, 40), 't') ,
|| '\npos' m.m.Pos 'in string' strip(m.m.src, 't')
/*--- return the next len characters until end of src ----------------*/
scanLook: procedure expose m.
parse arg m, len
if len == '' then
return substr(m.m.src, m.m.pos)
else
return substr(m.m.src, m.m.pos,
, min(len, 1 + length(m.m.src) - m.m.pos))
endProcedure scanLook
/*--- scan len chararcters, atmost to end of src ---------------------*/
scanChar: procedure expose m.
parse arg m, len
m.m.tok = scanLook(m, len)
m.m.pos = m.m.pos + length(m.m.tok)
return m.m.tok \== ''
endProcedure scanChar
/*--- scan the literal lit ------------------------------------------*/
scanLit: procedure expose m.
parse arg m
do ax=2 to arg()
if abbrev(substr(m.m.src, m.m.pos), arg(ax)) then do
m.m.tok = arg(ax)
m.m.pos = m.m.pos + length(arg(ax))
return 1
end
end
m.m.tok = ''
return 0
endProcedure scanLit
/*--- scan with verify, vOpt is passed to verify ---------------------*/
scanVerify: procedure expose m.
parse arg m, alpha, vOpt, onlyIfMatch
if arg() > 3 then
call err 'deimplement onlyIfMatch???'
if vOpt == '' then /* empty string does not take default */
nx = verify(m.m.src, alpha, , m.m.pos)
else
nx = verify(m.m.src, alpha, vOpt, m.m.pos)
if nx = 0 then
if onlyIfMatch == 1 then
nx = m.m.pos
else
nx = length(m.m.src) + 1
m.m.tok = substr(m.m.src, m.m.pos, nx - m.m.pos)
m.m.pos = nx
return m.m.tok \== ''
endProcedure scanVerify
/*--- scan while in charset ------------------------------------------*/
scanWhile: procedure expose m.
parse arg m, chSet
return scanVerify(m, chSet, 'n')
/*--- scan until in charset ------------------------------------------*/
scanUntil: procedure expose m.
parse arg m, chSet
return scanVerify(m, chSet, 'm')
/*--- scan until (and over) string End -------------------------------*/
scanStrEnd: procedure expose m.
parse arg m, sep
sx = m.m.pos
bx = sx
do forever
ex = pos(sep, m.m.src, sx)
if ex = 0 then do
m.m.val = m.m.val || substr(m.m.src, bx)
return 0
end
m.m.val = m.m.val || substr(m.m.src, bx, ex-bx)
bx = ex + length(sep)
if \ abbrev(substr(m.m.src, bx), sep) then do
m.m.tok = m.m.tok || substr(m.m.src, m.m.pos, bx-m.m.pos)
m.m.pos = bx
return 1
end
sx = bx + length(sep)
end
endProcedure scanStrEnd
/*--- scan a string with quote char qu ------------------------------*/
scanString: procedure expose m.
parse arg m, prefs
if prefs = '' then do
call scanLit m, "'", '"'
end
else do
do px=1 to words(prefs) until scanLit(m, word(prefs, px))
end
end
if m.m.tok == '' then
return 0
m.m.val = ''
if \ scanStrEnd(m, m.m.tok) then
return scanErr(m, 'ending Apostroph missing')
return 1
endProcedure scanString
/*--- scan a word and put value into *.val
a word is either delimited by space or stopper
or a string (with single or double quotes -------*/
scanWord: procedure expose m.
parse arg m, stopper, ucWord
if scanString(m) then
return 1
if stopper == '' then
stopper = ' ''"'
if \scanUntil(m, stopper) then
return 0
if ucWord == 1 then
m.m.val = translate(m.m.tok)
else
m.m.val = m.m.tok
return 1
endProcedure scanWord
/*--- skip, scan and return word or scanErr -------------------------*/
scanRetWord: procedure expose m.
parse arg m, stopper, ucWord, eWhat
if scanWord(scanSKip(m), stopper, ucWord) then
return m.m.val
else
return scanErr(m, eWhat 'expected')
endProcedure scanRetWord
/*--- scan a key = word phrase
put key into m.key and word into m.m.val -------*/
scanKeyValue: procedure expose m.
parse arg m, def, uc
if \ scanWord(m, ' =''"') then
return 0
m.m.key = m.m.val
if \ scanLit(scanSkip(m), '=') then
m.m.val = def
else if \ scanWord(scanSkip(m)) then
return scanErr(m, 'word expected after' m.m.key '=')
if uc == 1 then
upper m.m.key m.m.val
return 1
endProcedure scanKeyValue
/*--- scan over space, nl, comments ---------------------------------*/
scanSpace: procedure expose m.
parse arg m
if m.m.scanIsBasic then
return scanSpaceOnly(m)
else
return scanSpNlCo(m)
endProcedure scanSpace
scanSpaceOnly: procedure expose m.
parse arg m
nx = verify(m.m.src, ' ', , m.m.pos)
if nx = 0 then
nx = length(m.m.src) + 1
m.m.tok = left(' ', nx <> m.m.pos)
m.m.pos = nx
return m.m.tok == ' '
endProcedure scanSpaceOnly
/*--- skip over space and return m ----------------------------------*/
scanSkip: procedure expose m.
parse arg m
call scanSpace m
return m
endProcedure scanSkip
/*--- return true if at end of src -----------------------------------*/
scanEnd: procedure expose m.
parse arg m
if m.m.pos <= length(m.m.src) then
return 0
else if m.m.scanIsBasic then
return 1
else
return m.m.atEnd
endProcedure scanEnd
/*--- scan a natural number (no sign, decpoint ...) Ignore After -----*/
scanNatIA: procedure expose m.
parse arg m
return scanVerify(m, '0123456789')
/*--- scan an integer (optional sign, no decpoint ...) Ignore After --*/
scanIntIA: procedure expose m.
parse arg m
poX = m.m.pos
call scanLit m, '-', '+'
if \ scanNatIA(m) then do
m.m.pos = poX
return 0
end
m.m.tok = substr(m.m.src, poX, m.m.pos - poX)
return 1
endProcedure scanIntIA
/*--- scanOpt set the valid characters for names, and comments
it must be called
before any of the following functions ---------------------*/
scanOpt: procedure expose m.
parse arg m, m.m.scanName1, namePlus, m.m.scanComment, nest
if m.m.scanName1 == '' then
m.m.scanName1 = m.ut_alfa
if namePlus == '' then
m.m.scanNameR = m.m.scanName1 || '0123456789'
else
m.m.scanNameR = m.m.scanName1 || namePlus
m.m.scanNestCom = nest == 1
return m
endProcedure scanOpt
/*--- return true if at comment --------------------------------------*/
scanSBCom: procedure expose m.
parse arg m
m.m.tok = ''
if m.m.scanComment == '' then
return 0
if \ abbrev(substr(m.m.src, m.m.pos), m.m.scanComment) then
return 0
m.m.tok = substr(m.m.src, m.m.pos)
m.m.pos = 1 + length(m.m.src)
return 1
endProcedure scanSBCom
/*--- scan a Name, first char in *.scanName1, rest in *.scanNameR ----*/
scanName: procedure expose m.
parse arg m
if pos(substr(m.m.src, m.m.pos, 1),
, m.m.scanName1) <= 0 then do
m.m.tok = ''
return 0
end
return scanVerify(m, m.m.scanNameR)
endProcedure scanName
/*--- check character after a number
must not be Identifier or plus ----------------------------*/
scanCheckNumAfter: procedure expose m.
parse arg m, res, plus
if \ res then
return 0
if pos(substr(m.m.src, m.m.pos, 1), m.m.scanNameR || plus) > 0 then
call scanErr m, 'illegal char after number' m.m.tok
return 1
endProcedure scanCheckNumAfter
/*--- scan a natural number check character after -------------------*/
scanNat: procedure expose m.
parse arg m
if arg() \== 1 then
return err('old interface scanNat') / 0
return scanCheckNumAfter(m, scanNatIA(m), '.')
endProcedure ScanNat
/*--- scan an Integer check character after -------------------------*/
scanInt: procedure expose m.
parse arg m
if arg() \== 1 then
return err('old interface scanInt') / 0
return scanCheckNumAfter(m, scanIntIA(m), '.')
endProcedure ScanInt
/*--- scan a Number check character after ---------------------------*/
scanNum: procedure expose m.
parse arg m
if arg() \== 1 then
return err('old interface scanNum') / 0
return scanCheckNumAfter(m, scanNumIA(m))
endProcedure ScanInt
/*--- scan a number (optional sign, decpoint, exponent) Ignore After-*/
scanNumIA: procedure expose m.
parse arg m
poX = m.m.pos
call scanLit m, '-', '+'
cx = scanNumUSPos(m)
if cx == 0 then do
m.m.pos = poX
return 0
end
m.m.tok = substr(m.m.src, poX, cx-poX)
m.m.val = translate(m.m.tok)
m.m.pos = cx
return 1
endProcedure scanNumIA
/*--- scan unsigned number (optional decpoint, exponent) Ignore After-*/
scanNumUSPos: procedure expose m.
parse arg m
poX = m.m.pos
cx = verify(m.m.src, '0123456789', , poX)
if cx > 0 then
if substr(m.m.src, cx, 1) == '.' then
cx = verify(m.m.src, '0123456789', , cx+1)
if cx < 1 then do
if abbrev('.', substr(m.m.src, poX)) then
return 0
end
else if abbrev('.', substr(m.m.src, poX, cx-poX)) then do
return 0
end
else if pos(substr(m.m.src, cx, 1), 'eE') > 0 then do
cy = cx + 1 + (pos(substr(m.m.src, cx+1, 1), '-+') > 0)
cx = verify(m.m.src, '0123456789', , cy)
if cx==cy | (cx == 0 & cy > length(m.s.src)) then
call scanErr m, 'exponent expected after E'
end
if cx >= poX then
return cx
else
return length(m.s.src)+1
/*
m.m.tok = substr(m.m.src, poX, cx-poX)
m.m.pos = cx
end
else do
m.m.tok = substr(m.m.src, poX)
m.m.pos = length(m.s.src)+1
end
m.m.val = translate(m.m.tok)
return 1 */
endProcedure scanNumUSPos
scanType: procedure expose m.
parse arg m, opt
m.m.tok = ''
if scanName(m) then
m.m.type = 'n'
else if scanNum(m) then
m.m.type = 0
else if scanString(m) then
m.m.type = left(m.m.tok, 1)
else if scanSpace(m) then
m.m.type = 's'
else do
call scanChar m, 1
m.m.type = m.m.tok
end
return m.m.type
endProcedure scanType
/* copy scan end *************************************************/
/* copy scanRead begin ***********************************************
Scan: scan an input: with multiple lines
==> all of scan
returns: true if scanned, false otherwise
m.m.tok ==> last token
m.m.val ==> last value for scanString/Word/KeyValue
m.key ==> key for scanKeyValue
m.m.pos ==> scan position
m.m.src ==> scan source
***********************************************************************/
scanReadIni: procedure expose m.
if m.scanRead_ini == 1 then
return
m.scanRead_ini = 1
call jIni
ts = classNew('n ScanRes u f TOK v, f VAL v, f KEY v, f TYPE v')
call classNew 'n ScanRead u JRW', 'm',
, 'oReset return scanReadReset(m, arg)',
, 'scanNL return scanReadNL(m, unCond)',
, 'scanCom return scanSBCom(m)',
, 'scanInfo return scanReadInfo(m)',
, 'scanPos return scanReadPos(m)',
, "jOpen call scanReadOpen m, arg(3)" ,
, "jClose call scanReadClose m" ,
, 'isWindow 0',
, "jRead if scanType(m) == '' then return 0;" ,
" m.m = oClaCopy('"ts"', m, ''); return 1"
call classNew "n EditRead u JRW", "m" ,
, "jRead return editRead(m)",
, "jOpen" ,
, "jReset m.m.linex = arg - 1"
call classNew 'n ScanSqlStmtRdr u JRW', 'm',
, "jReset call scanSqlStmtRdrReset m, arg, arg2",
, "jOpen call scanOpen m'.SCAN'" ,
, "jClose call scanClose m'.SCAN'" ,
, "jRead r = scanSqlStmt(m'.SCAN');if r==''then return 0" ,
"; m.m = r; return 1"
return
endProcedure scanReadIni
scanOpen: procedure expose m.
parse arg m
interpret objMet(m, 'jOpen')
return m
endProcedure scanOpen
scanClose: procedure expose m.
parse arg m
interpret objMet(m, 'jClose')
return m
endProcedure scanOpen
/*--- scan over white space, nl, comments ...-------------------------*/
scanSpNlCo: procedure expose m.
parse arg m
res = 0
do while scanSpaceOnly(m) | scanCom(m) | scanNl(m)
res = 1
end
m.m.tok = left(' ', res)
return res
endProcedure scanSpNlCo
/*--- scan next line -------------------------------------------------*/
scanNL: procedure expose m.
parse arg m, unCond
interpret objMet(m, 'scanNL')
/*--- scan one comment -----------------------------------------------*/
scanCom: procedure expose m.
parse arg m
interpret objMet(m, 'scanCom')
/*--- go back the current token --------------------------------------*/
scanBack: procedure expose m.
parse arg m, tok
if m.m.pos <= length(tok) then
call scanErr sc, 'cannot back "'tok'" length'
cx = m.m.pos - length(tok)
if substr(m.m.src, cx, length(tok)) \== tok then
return scanErr(m, 'cannot back "'tok'" value')
m.m.pos = cx
return
endProcedure scanBack
/*--- return position in simple format -------------------------------*/
scanPos: procedure expose m.
parse arg m
interpret objMet(m, 'scanPos')
endProcedure scanPos
/*--- set position to position in arg to------------------------------*/
scanBackPos: procedure expose m.
parse arg m, to
cur = scanPos(m)
wc = words(cur)
if wc <> words(to) ,
| subWord(cur, 1, wc-1) <> subWord(to, 1, wc-1) then
call scanErr m 'cannot back from' cur 'to' to
m.m.pos = word(to, wc)
return
endProcedure scanBackPos
/*--- begin scanning the lines of a reader ---------------------------*/
scanRead: procedure expose m.
parse arg rdr, n1, np, co
return scanOpt(oNew(m.class_ScanRead, rdr), n1, np, co)
scanReadReset: procedure expose m.
parse arg m, m.m.rdr
return oMutate(m, m.class_ScanRead)
endProcedure scanReadReset
scanReadOpen: procedure expose m.
parse arg m, line0
call jOpen m.m.rdr, '<'
return scanSetPos0(m, (line0 == '') 1, line0)
endProcedure scanReadOpen
scanReadClose: procedure expose m.
parse arg m
call jClose m.m.rdr
m.m.atEnd = 'closed'
return m
endProcedure scanReadClose
/*--- scan over next newLine
if unCond \== 1 only if we are already at endOfLine
return true if we scanned a NL ------------------------------*/
scanReadNL: procedure expose m.
parse arg m, unCond
m.m.tok = ''
if unCond \== 1 then
if m.m.pos <= length(m.m.src) then
return 0
if m.m.atEnd then
return 0
m.m.tok = substr(m.m.src, m.m.pos)
r = m.m.rdr
if \ jRead(r) then do
m.m.atEnd = 1
m.m.pos = 1 + length(m.m.src)
return 0
end
m.m.src = m.r
m.m.pos = 1
m.m.lineX = m.m.lineX + 1
return 1
endProcedure scanReadNl
/*--- postition scanner to lx px (only with jBuf) -------------------*/
after rdr is positioned to line before -------------------------*/
scanSetPos: procedure expose m.
parse arg m, lx px
call jPosBefore m.m.rdr, lx
return scanSetPos0(m, lx px)
/*--- postition scanner to lx px
after rdr is positioned to line before -------------------------*/
scanSetPos0: procedure expose m.
parse arg m, lx px, line0
call scanReset m, line0
call scanNl m
m.m.lineX = lx
m.m.pos = px
return m
endProcedure scanSetPos0
/*--- reset scanner fields ------------------------------------------*/
scanReset: procedure expose m.
parse arg m, m.m.src
m.m.pos = 1
m.m.tok = ''
m.m.scanIsBasic = 0
m.m.atEnd = 0
m.m.lineX = 0
m.m.val = ''
m.m.key = ''
return m
endProcedure
scanTextCom: procedure expose m.
parse arg m, untC, untWrds
if \ m.m.scanNestCom then
return scanText(m, untC, untWrds)
else if wordPos('*/', untWrds) > 0 then
return scanText(m, untC'*/', untWrds)
res = scanText(m, untC'*/', untWrds '*/')
if res then
if scanLook(m, 2) == '*/' then
call scanErr m, '*/ without preceeding comment start /*'
return res
endProcedure scanTextCom
scanText: procedure expose m.
parse arg m, untC, untWrds
res = ''
do forever
if scanUntil(m, untC) then do
res = res || m.m.tok
if m.m.pos > length(m.m.src) then do
/* if windowing we need to move the window| */
if scanNl(m, 0) then
if right(res, 1) \==' ' & scanLook(m, 1)\==' ' then
res = res' '
iterate
end
end
c9 = scanLook(m, 9)
do sx=1 to words(untWrds)
if abbrev(c9, word(untWrds, sx)) then do
m.m.tok = res
return 1
end
end
if scanCom(m) | scanNl(m, 0) then do
if right(res, 1) \== ' ' & scanLook(m, 1) \== ' ' then
res = res' '
end
else if scanString(m) then
res = res || m.m.tok
else if scanChar(m, 1) then
res = res || m.m.tok
else if scanEnd(m) then do
m.m.tok = res
return res \== '' /* erst hier NACH scanCom, scanNl */
end
else
call scanErr m, 'bad pos'
end
endProcedure scanText
scanReadPos: procedure expose m.
parse arg m, msg
return m.m.lineX m.m.pos
endProcedure scanReadPos
scanReadInfo: procedure expose m.
parse arg m
msg = 'last token' m.m.tok 'scanPosition' ,
strip(substr(m.m.src, m.m.pos, 40), 't')
if scanEnd(m) then
msg = msg'\natEnd after'
else
msg = msg'\npos' m.m.pos 'in'
return msg 'line' m.m.lineX':' strip(m.m.src, 't')
endProcedure scanReadInfo
/*--- use scan sqlEdit macro --> temporarily here --------------------*/
/*--- read next line from edit data ----------------------------------*/
editRead: procedure expose m.
parse arg m
m.m.lineX = m.m.lineX + 1
if adrEdit('(ll) = line' m.m.lineX, 12) \= 0 then
return 0
m.m = ll
return 1
endProcedure editRead
/*--- search loop in edit macro --------------------------------------*/
scanSqlSeekId: procedure expose m.
parse arg m, lx, cmd, opts
if opts = '' then
opts = word
/* line 1 col 0, otherwise first word is skipped*/
if adrEdit("cursor =" max(trunc(lx), 1) 0, 12) = 12 then
return -1
do while adrEdit("seek" cmd opts, 4) = 0 /* find each command*/
call adrEdit "(fx) = cursor"
if m.debug then do
call adrEdit "(LI) = LINE" fx
call debug 'scanSqlSeekId after' lx 'found' cmd 'at' fx li
end
call jReset m.m.rdr, fx
call jOpen m, '<'
m.m.lineX = fx
do while word(scanPos(m), 1) <= fx & scanSqlClass(m)
if m.m.sqlClass = 'i' & m.m.val == cmd then
return fx
end
call jClose m
end
return -1
endProcedure scanSqlSeekId
/* copy scanRead end **************************************************/
/* copy scanWin begin *************************************************
scan the the concatenation of the lines of a reader
any token my be split over several line
except the end-of-line-comment-token
***********************************************************************/
scanWinIni: procedure expose m.
if m.scanWin.ini = 1 then
return
m.scanWin.ini = 1
call scanReadIni
call classNew 'n ScanWin u ScanRead', 'm',
, "oReset call scanWinReset m, arg, arg2",
, "jOpen call scanWinOpen m, arg(3)",
, "jClose call scanReadClose m",
, 'scanNL return scanWinNl(m, unCond)',
, 'scanCom return scanWinCom(m)',
, 'scanInfo return scanWinInfo(m)',
, 'scanPos return scanWinPos(m)',
, 'isWindow 1'
return
endProcedure scanWinIni
/*--- instanciate a new window scanner -------------------------------*/
scanWin: procedure expose m.
parse arg rdr, wOpts
return oNew(m.class_ScanWin, rdr, wOpts)
/*--- set the reader and window attributes of scanner m -------------*/
scanWinReset: procedure expose m.
parse arg m, m.m.rdr, winOpt
return scanSqlOpt(scanWinOpt(oMutate(m, m.class_ScanWin), winOpt))
/*--- set the window scanner attributes -----------------------------*/
scanWinOpt: procedure expose m.
parse arg m, cuLe wiLi wiBa
if pos('@', cuLe) > 0 then
parse var cuLe cuLe '@' m.m.cutPos
else
m.m.cutPos = 1
cuLe = word(cuLe 72, 1)
m.m.cutLen = cuLe /* fix recLen */
wiLe = cuLe * (1 + word(wiLi 5, 1))
m.m.posMin = word(wiba 3, 1) * cuLe /* room to go back */
m.m.posLim = m.m.posMin + wiLe
m.m.winTot = m.m.posLim + wiLe
return m
endProcedure scanWinReset
/*--- open reader and start scanning --------------------------------*/
scanWinOpen: procedure expose m.
parse arg m, line0
call jOpen m.m.rdr, '<'
if line0 == '' then
return scanSetPos0(m, 1 1)
if length(line0) // m.m.cutLen \== 0 then
line0 = line0||left('', m.m.cutLen - length(line0)//m.m.cutLen)
return scanSetPos0(m, (1 - length(line0) % m.m.cutLen) 1, line0)
endProcedure scanWinOpen
/*--- move the source window: cut left side and append at right side
return number of characters cut at left ------------------------*/
scanWinRead: procedure expose m.
parse arg m
dlt = 0
if m.m.atEnd then
return 0
if m.m.pos >= m.m.posLim then do /* cut left side */
dlt = m.m.pos - ((m.m.pos-1) // m.m.cutLen + 1 + m.m.posMin)
call assert 'dlt >= 0 & dlt // m.m.cutLen = 0', 'dlt m.m.cutLen'
m.m.src = substr(m.m.src, dlt+1)
m.m.pos = m.m.pos - dlt
m.m.lineX = m.m.lineX + dlt % m.m.cutLen
end
r = m.m.rdr
do while length(m.m.src) < m.m.winTot /* read and fill to len */
if \ jRead(r) then do
m.m.atEnd = 1
return dlt
end
m.m.src = m.m.src || substr(m.r, m.m.cutPos, m.m.cutLen)
end
call assert 'length(m.m.src) = m.m.winTot',
, 'm.m.winTot length(m.m.src) m.m.src'
return dlt
endProcedure scanWinRead
/*--- return position of next line start -----------------------------*/
scanWinNLPos: procedure expose m.
parse arg m
return m.m.pos + m.m.cutLen - ((m.m.pos - 1) // m.m.cutLen)
/*--- scan comment ---------------------------------------------------*/
scanWinCom: procedure expose m.
parse arg m
call scanWinRead m
if m.m.scanComment \== '' then do
cl = length(m.m.scanComment)
if scanLook(m, cl) == m.m.scanComment then do
np = scanWinNlPos(m)
if np = m.m.pos then
np = np + m.m.cutLen
if np >= m.m.pos + cl then do
m.m.tok = substr(m.m.src, m.m.pos, np - m.m.pos)
m.m.pos = np
return 1
end
end
end
if m.m.scanNestCom then
if scanLit(m, '/*') then do
tk = substr(m.m.src, m.m.pos, m.m.cutLen + 2)
call scanTextCom m, , '*/'
if \ scanLit(m, '*/') then
call scanErr m, 'nested comment after /* not finished'
if pos('*/', tk) < 1 then
m.m.tok = left(tk, m.m.cutLen - 5)'...*/'
else
m.m.tok = left(tk, pos('*/', tk) + 1)
return 1
end
m.m.tok = ''
return 0
endProcedure scanWinCom
/*--- scan nl --------------------------------------------------------*/
scanWinNL: procedure expose m.
parse arg m, unCond
call scanWinRead m
m.m.tok = ''
if unCond \== 1 then
return 0
np = scanWinNLPos(m)
if np = m.m.pos then
return 0
m.m.tok = substr(m.m.pos, np-m.m.pos)
m.m.pos = np
return 1
endProcedure scanWinNl
/*--- return current position in input ------------------------------*/
scanWinPos: procedure expose m.
parse arg m
ps = m.m.pos - 1
return (m.m.lineX + (ps % m.m.cutLen)) (ps // m.m.cutLen + 1)
endProcedure scanWinPos
/*--- return a description of the current scan position --------------*/
scanWinInfo: procedure expose m.
parse arg m
p = scanWinPos(m)
if scanEnd(m) then do
res = 'atEnd after'
p = m.m.lineX - 1 + length(m.m.src) % m.m.cutLen
p = word(p, 1)
end
else do
res = 'pos' word(p, 2) 'in'
p = word(p, 1)
end
return 'last token' m.m.tok 'scanPosition' ,
strip(left(substr(m.m.src, m.m.pos), 40), 't') ,
|| '\n'res 'line' p':' strip(substr(m.m.src,
, 1 + (p - m.m.lineX) * m.m.cutLen, m.m.cutLen), 't')
endProcedure scanWinInfo
/* copy scanWin end *************************************************/
/* copy scanSql begin *************************************************/
/*--- initialize with reader inRdr ----------------------------------*/
scanSqlReset: procedure expose m.
parse arg m, r, scanWin, stmtOpt
call scanSqlStmtOpt scanSqlOpt(m), strip(stmtOpt)
if scanWin \== 0 then
return scanWinReset(m, r, scanWin)
else if r \== '' then
return scanReadReset(m, r)
else
return scanSrc(m, m.m.src)
endProcedure scanSqlReset
scanSqlOpt: procedure expose m.
parse arg m
return scanOpt(m, m.ut_alfa'$#@', '0123456789_' , '--', 1)
endProcedure scanSqlOpt
/*--- scan a sql token put class in m.sqlclass:
'i': ordinary identifier e.g. Name
'd': delimited identifier e.g. "Delimited"
'q': qualified identifier e.g. abc."efg"
'u': integer units e.g. 8G
'n': number e.g. -234 or .2e3
's': string e.g. 'abc''ef'
'' : at end
: any other character e.g. ;
----------------------------------------------------------------*/
scanSqlClass: procedure expose m.
parse arg m, retSpace
m.m.val = ''
if scanSpNlCo(m) & retSpace = 1 then do
m.m.sqlClass = 'b'
return 1
end
c2 = scanLook(m ,2)
if scanLit(m, "'", "x'", "X'") then do
if \ scanStrEnd(m, "'") then
call scanErr m, 'ending apostroph missing'
m.m.sqlClass = 's'
if \abbrev(m.m.tok, "'") then
m.m.val = x2c(m.m.val)
end
else if scanSqlQuId(m, 1) then do
if m.m.val.0 > 1 then
m.m.sqlClass = 'q'
else if abbrev(m.m.tok, '"') then
m.m.sqlClass = 'd'
else
m.m.sqlClass = 'i'
end
else if scanSqlNumPM(m) then do
if m.m.tok == '-' | m.m.tok == '+' then
m.m.sqlClass = m.m.tok
else
m.m.sqlClass = 'n'
end
else if scanChar(m, 1) then
m.m.sqlClass = m.m.tok
else if scanEnd(m) then do
m.m.sqlClass = ''
return 0
end
else
call scanErr m, 'cannot scan sql'
return 1
endProcedure scanSqlClass
scanSqlSkipBrackets: procedure expose m.
parse arg m, br
if br \== '' then
nop
else if scanLit(m, '(') then
br = 1
else
return 0
do while scanSqlClass(m) & m.m.sqlClass \== ';'
if m.m.sqlClass = '(' then br = br + 1
else if m.m.sqlClass \== ')' then iterate
else if br > 1 then br = br - 1
else return 1
end
call scanErr m, '; or eof, but' br 'closing ) expected'
endProcedure skipBrackets
/*--- scan an ordinary sql identifier e.g. abc, ef_12 ----------------*/
scanSqlId: procedure expose m.
parse arg m
if \ scanName(m) then
return 0
m.m.val = translate(m.m.tok)
return 1
endProcedure scanSqlId
/*--- scan a delimited or ordinay sql identifier ---------------------*/
scanSqlDeId: procedure expose m.
parse arg m
if scanSqlId(m) then
return 1
if \ scanString(m, '"') then
return 0
m.m.val = strip(m.m.val, 't')
return 1
endProcedure scanSqlDeId
/*--- scan a qualified sql identifier -------------------------------*/
scanSqlQuId: procedure expose m.
parse arg m, starOk
res = ''
rto = ''
do qx=1
if \ scanSqlDeId(m) then do
if qx == 1 then
return 0 /* sometimes last qual may be '*' */
if starOk \== 1 | \ scanLit(m, '*') then
call scanErr m, 'id expected after .'
else if scanLit(scanSkip(m), '.') then
call scanErr m, 'dot after id...*'
else
leave
end
m.m.val.qx = m.m.val
res = res'.'m.m.val
rto = rto'.'m.m.tok
if \ scanLit(scanSkip(m), '.') then
leave
call scanSpace m
end
m.m.val.0 = qx
m.m.val = substr(res, 2)
m.m.tok = substr(rto, 2)
return 1
endProcedure scanSqlQuId
/*--- scan a sql number, Ignore After -------------------------------*/
scanSqlNumIA: procedure expose m.
parse arg m
if \ scanSqlNumPM(m) then
return 0
else if m.m.tok == '+' | m.m.tok == '-' then
call scanErr m, 'no sqlNum after +-'
return 1
endProcedure scanSqlNumIA
/*--- scan a sql number, + or -, ignore after -----------------------*/
scanSqlNumPM: procedure expose m.
parse arg m
if scanLit(m, '+', '-') then do
si = m.m.tok
call scanSkip m
end
else
si = ''
cx = scanNumUSPos(m)
if cx == 0 then do
m.m.val = si
m.m.tok = si
return si \== ''
end
m.m.tok = si || substr(m.m.src, m.m.pos, cx-m.m.pos)
m.m.val = translate(m.m.tok)
m.m.pos = cx
return 1
endProcedure scanSqlNumIA
/*--- scan a sql number, check After --------------------------------*/
scanSqlNum: procedure expose m.
parse arg m
if arg() \== 1 then
return err('old interface scanSqlNum') / 0
return scanCheckNumAfter(m, scanSqlNumIA(m))
endProcedure ScanSqlNum
/*--- scan a sql number with a unit which may follow without space ---*/
scanSqlNumUnit: procedure expose m.
parse arg m, both, units
if \ scanSqlNumIA(m) then
return 0
nu = m.m.val
sp = scanSpace(m)
if scanSqlId(m) then do
if units == '' | wordpos(m.m.val, units) > 0 then
nu = nu m.m.val
else if both | \ sp then
call scanErr m, 'bad unit' m.m.val 'after' nu
else
call scanBack m, m.m.tok
end
else if both then
call scanErr m, 'no unit after' nu
else if \sp & pos(scanLook(m, 1), m.m.scanNameR) > 0 then
call scanErr m, 'bad unit after number' nu
m.m.val = nu
return 1
endProcedure scanSqlNumUnit
/*--- find next statement, after scanSqlStmtOpt -----------------------
m.m.stop contains delimiter, will be changed by
terminator?; or --#terminator */
scanSqlStmtOpt: procedure expose m.
parse arg m, m.m.stop
if m.m.stop == '' then
m.m.stop = ';'
return m
endProcedure scanSqlStmtOpt
scanSqlStop: procedure expose m.
parse arg m
res = ''
fuCo = copies(m.m.scanComment'#SET', m.m.scanComment \== '')
u1 = '''"'left(m.m.scanComment, m.m.scanComment \== '')
do lx=1
if lx > 100 then
say '????iterating' scanLook(m)
if m.m.stop == '' then
scTx = scanTextCom(m, u1 ,fuCo)
else
scTx = scanTextCom(m, u1||left(m.m.stop,1), m.m.stop fuCo)
if scTx then
res = res || m.m.tok
if fuCo \== '' then
if scanLook(m, length(fuCo)) == fuCo then do
tx = scanLook(m)
ok = word(tx, 2) == 'TERMINATOR' ,
& length(word(tx, 3)) == 1
if ok then
ok = scanCom(m)
if ok then do
m.m.stop = word(tx, 3)
if \ (right(res, 1) == ' ' ,
| scanLook(m, 1) == ' ') then
res = res' '
end
else if scanChar(m, 1) then
res = res || m.m.tok
else
call scanErr m, 'no char, now what?'
iterate
end
if m.m.stop \== '' then
call scanLit m, m.m.stop
res = strip(res)
if length(res)=11 ,
& abbrev(translate(res), 'TERMINATOR') then do
m.m.stop = substr(res, 11, 1)
res = ''
end
return res
end
endProcedure scanSqlStop
scanSqlStmt: procedure expose m.
parse arg m
do forever
res = scanSqlStop(m)
if res <> '' then
return res
if scanEnd(m) then
return ''
end
endProcedure scanSqlStmt
/*-- return next sqlStmt from rdr ( or string or '' = j.in) ---------*/
scanSqlIn2Stmt: procedure expose m.
parse arg rdr, wOpt
s = scanSqlIn2Scan(rdr, m'.SCAN_SqlIn2Stmt', wOpt)
res = scanSqlStmt(scanOpen(s))
call scanReadClose s
return res
endProcedure scanSqlIn2Stmt
/*-- reset s as scanSql from rdr ( or string or '' = j.in) ----------*/
scanSqlIn2Scan: procedure expose m.
parse arg m, s, wOpt, sOpt
interpret objMet(m, 'scanSqlIn2Scan')
endProcedure scanSqlIn2Scan
/*-- create a new scanSqlStmtRdr ------------------------------------*/
scanSqlStmtRdr: procedure expose m.
parse arg rdr, wOpt, sOpt
return oNew('ScanSqlStmtRdr', rdr, wOpt, sOpt)
/*-- reset a new scanSqlStmtRdr
must be called from jReset to allow jRead ------------------*/
scanSqlStmtRdrReset: procedure expose m.
parse arg m, rdr, wOpt, sOpt
call scanSqlIn2Scan rdr, m'.SCAN', wOpt, sOpt
return oMutate(m, m.class_ScanSqlStmtRdr)
endProcedure scanSqlStmtRdrReset
/* copy scanSql end *************************************************/
/* copy scanUtil begin *************************************************
scan db2 utility input statements using scan and a reader
**********************************************************************/
/*--- initialize with reader inRdr ----------------------------------*/
scanUtilOpt: procedure expose m.
parse arg m
call scanSqlOpt m
m.m.scanNestCom = 0
m.m.utilBrackets = 0
m.scanUtil = 'BACKUP CATENFM CATMAINT CHECK' ,
'COPY COPYTOCOPY DIAGNOSE EXEC LISTDEF LOAD' ,
'MERGECOPY MODIFY OPTIONS QUIESCE REBUILD' ,
'RECOVER REORG REPAIR REPORT RESTORE' ,
'RUNSTATS STOSPACE TEMPLATE UNLOAD'
return m
endProcedure scanUtilOpt
/*--- scan next token and put its class in m.sc.utilClass:
'u' a utility name
'n' a name
'"' a quoted name
"'" an apostroph'd string
'.' a .
',' a ,
'v' a value
'' at end
---------------------------------------------------------------*/
scanUtil: procedure expose m.
parse arg sc
m.sc.utilSpace = scanSpace(sc)
ty = '?'
if scanLit(sc, '(') then do
m.sc.utilBrackets = m.sc.utilBrackets + 1
end
else if scanLIT(sc, ')') then do
m.sc.utilBrackets = m.sc.utilBrackets - 1
if m.sc.utilBrackets < 0 then
call scanErr sc, 'unmatched closing bracket )'
end
else if scanLit(sc, ',') then do
end
else if scanLit(sc, '.') then do
end
else if scanString(sc, "'") then do
end
else if scanString(sc, '"') then do
end
else if scanName(sc) then do
m.sc.val = translate(m.sc.tok)
if m.sc.utilBrackets > 0 then
ty = 'n'
else if 0 < wordPos(m.sc.val, m.scanUtil) then
ty = 'u'
else
ty = 'n'
end
else if scanVerify(sc, ' (),''"', 'm') then do
ty = 'v'
m.sc.val = translate(m.sc.tok)
end
else if \scanEnd(sc) then do
call scanErr sc, 'scanUtil stopped before end'
end
else do
ty = ''
m.sc.val = ''
end
if ty == '?' then
m.sc.utilClass = left(m.sc.tok, 1)
else
m.sc.utilClass = ty
return m.sc.utilClass
endProcedure scanUtil
/*--- scan a value or a bracketed list of values ---------------------*/
scanUtilValue: procedure expose m.
parse arg sc, remApo, nl
if remApo = '' | rempApo = 0 then
remApo = "nv"
else if rempApo = 1 then
remApo = "nv'"
if '(' \== scanUtil(sc) then
return scanUtilValueOne(sc, remApo)
v = ''
brx = m.sc.utilBrackets
oLine = word(scanPos(sc), 1)
do forever
call scanUtil sc
one = scanUtilValueOne(sc, remApo)
if one == '' then
call scanErr sc, 'eof in brackets'
else if brx > m.sc.utilBrackets then
return v
nLine = word(scanPos(sc), 1)
if \ m.sc.utilSpace then
v = v || one
else if nl \== '' & oLine <> nLine then
v = v || nl || one
else
v = v' 'one
oLine = nLine
end
endProcedure scanUtilValue
scanUtilValueOne: procedure expose m.
parse arg sc, valTy
if m.sc.utilClass == '' then
return ''
else if m.sc.utilClass == 'u' then
call scanErr sc, 'util in scanUtilValueOne'
if pos(m.sc.utilClass, valTy) > 0 then
return m.sc.val
else
return m.sc.tok
endProcedure scanUtilValueOne
/*--- skip over nested brackets --------------------------------------*/
scanUtilSkipBrackets: procedure expose m.
parse arg m, br, doCat
if br \== '' then
lim = m.m.utilBrackets - br
else if scanLit(m, '(') then do
lim = m.m.utilBrackets
m.m.utilBrackets = lim + 1
end
else
return 0
doCat = doCat == 1
res = ''
do while scanUtil(m) \== ''
if m.m.utilBrackets <= lim then do
if doCat then
m.m.val = res
return 1
end
if doCat then
res = res m.m.tok
end
return scanErr(m, 'eof with' m.m.utilBrackets 'open (')
endProcedure skipBrackets
/*--- analyze a punch file write intoField to stdOut -----------------*/
scanUtilInto: procedure expose m.
parse arg m
if m.m.utilBrackets \== 0 then
call scanErr m, 'scanUtilInto with brackets' m.m.utilBrackets
/*sc = scanUtilReader(m.j.in)
call jOpen sc, 'r'
*/ do forever
cl = scanUtil(m)
if cl == '' then
return 0
if cl = 'n' & m.m.tok == 'INTO' then
leave
end
if scanUtil(m) \== 'n' | m.m.tok \== 'TABLE' then
call scanErr m, 'bad into table '
if \ scanSqlQuId(scanSkip(m)) then
call scanErr m, 'table name expected'
if m.m.utilBrackets \== 0 then
call scanErr m, 'into table in brackets' m.m.utilBrackets
m.m.tb = m.m.val
m.m.part = ''
m.m.when = ''
do forever
cl = scanUtil(m)
if cl == '' then
call scanErr m, 'eof after into'
if cl == 'n' & m.m.tok == 'PART' then do
if scanUtil(m) == 'v' then
m.m.part = m.m.val
else
call scanErr m, 'bad part'
end
else if cl == 'n' & wordPos(m.m.val, 'WHEN WORKDDN') > 0 then do
call scanUtilSkipBrackets m
end
else if cl == '(' then do
leave
end
end
oX = m.m.lineX
oL = overlay('', m.m.src, 1, m.m.pos-2)
do while m.m.utilBrackets > 0
call scanUtil m
if oX \== m.m.lineX then do
call out strip(oL, 't')
oX = m.m.lineX
oL = m.m.src
end
end
call out left(oL, m.m.pos)
/* call jClose sc
*/ return 1
endProcedure scanUtilInto
/* copy scanUtil end **************************************************/
/* copy pipe begin *****************************************************
***********************************************************************/
pipeIni: procedure expose m.
if m.pipe.ini == 1 then
return
m.pipe.ini = 1
call catIni
call mapReset v
m.v_with.0 = 0
m.v_withMap = ''
m.v_with.0.map = ''
m.pipe.0 = 1
m.pipe.1.in = m.j.in
m.pipe.1.out = m.j.out
call pipe '+'
return
endProcedure pipeIni
/*-------------------------------
+- push pop frame
PYNFA ouput: Parent saY Newcat File, Appendtofile
psf| input: parent string file oldOut
old --> new
pipeBegin --> pipe '+N'
pipeBeLa f --> pipe '+F'
pipeLast --> pipe 'P|'
pipeLast f --> pipe 'F|', f
pipeEnd --> pipe '-'
--------------------------------*/
pipe: procedure expose m.
parse arg opts, aO
ox = 1; oc = substr(opts, ox, 1)
ax = m.pipe.0
px = ax -1
if oc == '-' then do
if px < 2 then
call err 'pipe pop empty'
call jClose m.pipe.ax.out
call jClose m.pipe.ax.in
ax = px
m.pipe.0 = ax
px = ax-1
ox = ox+1; oc = substr(opts, ox, 1)
end
if oc == '+' then do
px = ax
ax = ax+ 1
m.pipe.0 = ax
m.pipe.ax.in = jOpen(m.pipe.px.in, '<')
m.pipe.ax.out = jOpen(m.pipe.px.out, '>')
ox = ox+1; oc = substr(opts, ox, 1)
end
oOut = m.pipe.ax.out
if pos(oc, 'NYPFA') > 0 then do
call jClose oOut
if oc == 'Y' then
m.pipe.ax.out = jOpen(m.pipe.1.out, '>')
else if oc == 'P' then
m.pipe.ax.out = jOpen(m.pipe.px.out, '>')
else if oc == 'N' then
m.pipe.ax.out = jOpen(Cat(), '>')
else if oc == 'F' then
m.pipe.ax.out = jOpen(o2file(aO), '>')
else if oc == 'A' then
m.pipe.ax.out = jOpen(o2file(aO), '>>')
ox = ox+1; oc = substr(opts, ox, 1)
end
if oc \== ' ' then do
call jClose m.pipe.ax.in
if substr(opts, ox+1) = '' & oc \== 's' then
ct = ''
else
ct = jOpen(Cat(), '>')
lx = 3
do forever
if oc == 's' then do
call jWrite ct, arg(lx)
lx = lx + 1
end
else do
if oc == 'p' then
i1 = m.pipe.px.in
else if oc == '|' then
i1 = oOut
else if oc == 'f' then do
i1 = arg(lx)
lx = lx + 1
end
else
call err 'implement' oc 'in pipe' opts
if ct \== '' then
call jWriteAll ct, o2File(i1)
end
ox = ox + 1
if substr(opts, ox, 1) == ' ' then
leave
else if ct == '' then
call err 'pipe loop but ct empty'
else
oc = substr(opts, ox, 1)
end
if ct == '' then
m.pipe.ax.in = jOpen(o2file(i1), '<')
else
m.pipe.ax.in = jOpen(jClose(ct), '<')
if lx > 3 & lx <> arg() + 1 then
call err 'pipe opts' opts 'but' arg() 'args not' (lx-1)
end
m.j.in = m.pipe.ax.in
m.j.out = m.pipe.ax.out
return
endProcedure pipe
/*--- write all from rdr (rsp in) to out, not lazy ----------------*/
pipeWriteNow: procedure expose m.
parse arg rdr
call jWriteNow m.j.out, if(rdr == '', m.j.in, rdr)
return
endProcedure pipeWriteNow
/*--- write all from rdr (rsp in) to out, possibly lazy -----------*/
pipeWriteAll: procedure expose m.
parse arg rdr
call jWriteAll m.j.out, if(rdr == '', m.j.in, rdr)
return
endProcedure pipeWriteAll
pipePreSuf: procedure expose m.
parse arg le, ri
do while in()
call out le || m.in || ri
end
return
endProcedure pipePreSuf
vIsDefined: procedure expose m.
parse arg na
return '' \== vAdr(na, 'g')
endProcedure vIsDefined
vWith: procedure expose m.
parse arg fun, o
if fun == '-' then do
tBe = m.v_with.0
tos = tBe - 1
if tos < 0 then
call err 'pop empty withStack'
m.v_with.0 = tos
m.v_withMap = m.v_with.tos.map
return m.v_with.tBe.obj
end
else if fun \== '+' then
call err 'bad fun vWith('fun',' o')'
par = m.v_with.0
tos = par + 1
m.v_with.0 = tos
if symbol('m.v_with.tos.obj') == 'VAR' then
if objClass(o) == objClass(m.v_with.tos.obj) then do
m.v_with.tos.obj = o
m.v_withMap = m.v_with.tos.map
return
end
m.v_with.tos.obj = o
if par > 0 then
key = m.v_with.par.classes
else
key = ''
if o \== '' then
key = strip(key objClass(o))
m.v_with.tos.classes = key
if symbol('m.v_withManager.key') == 'VAR' then do
m.v_with.tos.map = m.v_withManager.key
m.v_withMap = m.v_withManager.key
return
end
m = mapNew()
m.v_with.tos.map = m
m.v_withMap = m
m.v_withManager.key = m
do kx=1 to words(key)
c1 = word(key, kx)
call vWithAdd m, kx, classMet(c1, 'oFlds')
call vWithAdd m, kx, classMet(c1, 'stms')
end
return
endProcedure vWith
vWithAdd: procedure expose m.
parse arg m, kx, ff
do fx=1 to m.ff.0
n1 = m.ff.fx
dx = pos('.', n1)
if dx > 1 then
n1 = left(n1, dx-1)
else if dx = 1 | n1 = '' then
iterate
call mPut m'.'n1, kx
end
return
endProcedure vWithAdd
vForWith: procedure expose m.
parse arg var
call vWith '-'
if \ vIn(var) then
return 0
call vWith '+', m.in
return 1
endProcedure vForWith
vGet: procedure expose m.
parse arg na
a = vAdr(na, 'g')
if a = '' then
call err 'undefined var' na
return m.a
endProcedure vGet
vPut: procedure expose m.
parse arg na, val
a = vAdr(na, 'p')
m.a = val
return val
endProcedure vPut
/*--- find the final address
return f || a with address a and
f = m -> mapGet(a), o -> obect m.a, s -> string m.a ---*/
vAdrXXX: procedure expose m.
parse arg na, f
cx = 1
do forever
cy = verify(na, '&>', 'm', cx)
if cy = 0 then do
if cy <= length(na) then
a = a'.'substr(na, cx)
leave
end
a = a'.'substr(na, cx, cy-cx-1)
if substr(na, cy, 1) == '>' then do
a = vAdrByM(a)
if fld \== '' then
a = a'.'fld
end
else do
if nxt then
a = vAdrByM(a)
mp = m.v_withMap
aL = a
if pos('.', a) > 0 then
aL = left(a, pos('.', a)-1)
if mp \== '' & symbol('m.mp.aL') == 'VAR' then do
wx = m.mp.aL
a = m.v_with.wx.obj'.'a
end
else if cx >= length(na) then
return mapAdr(v, a, f)
else
a = mapAdr(v, a, 'g')
if fld \== '' then
a = vAdrByM(a)'.'fld
end
if cy < 1 then do
if f == 'g' then
if symbol('m.a') \== 'VAR' then
return ''
return a
end
cx = cy
nxt = 1
end
endProcedure vAdr
vAdr: procedure expose m.
parse arg na, f
cx = 0
cx = verify(na, '&>', 'm')
if cx > 0 then
a = left(na, cx-1)
else do
a = na
cx = length(na)+1
end
nxt = 0
do forever
cy = verify(na, '&>', 'm', cx+1)
if cy > 0 then
fld = substr(na, cx+1, cy-cx-1)
else
fld = substr(na, cx+1)
if substr(na, cx, 1) == '>' then do
if nxt then
a = vAdrByM(a)
if fld \== '' then
a = a'.'fld
end
else do
if nxt then
a = vAdrByM(a)
mp = m.v_withMap
aL = a
if pos('.', a) > 0 then
aL = left(a, pos('.', a)-1)
if mp \== '' & symbol('m.mp.aL') == 'VAR' then do
wx = m.mp.aL
a = m.v_with.wx.obj'.'a
end
else if cx >= length(na) then
return mapAdr(v, a, f)
else
a = mapAdr(v, a, 'g')
if fld \== '' then
a = vAdrByM(a)'.'fld
end
if cy < 1 then do
if f == 'g' then
if symbol('m.a') \== 'VAR' then
return ''
return a
end
cx = cy
nxt = 1
end
endProcedure vAdr
vAdrByM:
parse arg axx
if axx = '' then
return err('null address at' substr(na, cx) 'in' na)
if symbol('m.axx') \== 'VAR' then
return err('undef address' axx 'at' substr(na, cx) 'in' na)
ayy = m.axx
if ayy == '' then
return err('null address at' substr(na, cx) 'in' na)
return ayy
endProcedure vAdrByM
vIn: procedure expose m.
parse arg na
if \ in() then
return 0
if na \== '' then
call vPut na, m.in
return 1
endProcedure vIn
vRead: procedure expose m. /* old name ????????????? */
parse arg na
return vIn(na)
vHasKey: procedure expose m.
parse arg na
return mapHasKey(v, na)
vRemove: procedure expose m.
parse arg na
return mapRemove(v, na)
/* copy pipe end ******************************************************/
/* copy cat begin ****************************************************
***********************************************************************/
/*--- create a new cat -----------------------------------------------*/
cat: procedure expose m.
m = oNew('Cat') /* calls catReset */
do ax=1 to arg()
call catWriteAll m, arg(ax)
end
return m
endProcedure cat
catReset: procedure expose m.
parse arg m
m.m.RWs.0 = 0
m.m.catWr = ''
m.m.catRd = ''
m.m.catIx = -9e9
m.m.catKeepOpen = ''
return m
endProcedure catReset
catClose: procedure expose m.
parse arg m
if m.m.catWr \== '' then do
call jClose m.m.catWr
call mAdd m'.RWS', m.m.catWr
m.m.catWr = ''
end
if m.m.catRd \== '' then do
call jClose m.m.catRd
m.m.catRd = ''
end
m.m.catIx = -9e9
return m
endProcedure catClose
catOpen: procedure expose m.
parse arg m, oo
if oo == m.j.cRead then do
m.m.catIx = 0
call catNextRdr m
m.m.jReading = 1
end
else if oo == m.j.cWri | oo == m.j.cApp then do
if oo == m.j.cWri then
m.m.RWs.0 = 0
m.m.catIx = -9e9
m.m.jWriting = 1
end
else do
call err 'catOpen('m',' oo') bad opt'
end
return m
endProcedure catOpen
/*--- return and open next reader ------------------------------------*/
catNextRdr: procedure expose m.
parse arg m
if m.m.catRd \== '' then
call jClose m.m.catRd
cx = m.m.catIx + 1
m.m.catIx = cx
if cx > m.m.RWs.0 then do
m.m.catRd = ''
return 0
end
m.m.catRd = m.m.RWs.cx
if cx = word(m.m.catKeepOpen, 1) then
m.m.catKeepOpen = subWord(m.catKeepOpen, 2)
else
call jOpen m.m.catRd , m.j.cRead
return 1
endProcedure catNextRdr
catRead: procedure expose m.
parse arg m
do while m.m.catRd \== ''
cr = m.m.catRd
if jRead(cr) then do
m.m = m.cr
return 1
end
call catNextRdr m
end
return 0
endProcedure catRead
catWrite: procedure expose m.
parse arg m, line
if m.m.catWr == '' then
m.m.catWr = jOpen(jBuf(), m.j.cWri)
call jWrite m.m.catWr, line
return
endProcedure catWrite
/*--- write contents of a reader to cat
or keep it for later reading -------------------------------*/
catWriteAll: procedure expose m.
parse arg m
if m.m.catWr \== '' then do
call mAdd m'.RWS', jClose(m.m.catWr)
m.m.catWr = ''
end
do ax=2 by 1 to arg()
r = o2File(arg(ax))
call mAdd m'.RWS', r
if m.r.jReading then do
m.m.catKeepOpen = m.m.rws.0 m.m.catKeepOpen
call jOpen r, m.j.cRead
end
end
return
endProcedure catWriteAll
/*--- create a reader/WriteO for an external file --------------------*/
file: procedure expose m.
parse arg str
return oNew('File', str)
endProcedure file
fileChild: procedure expose m.
parse arg m, name, opt
interpret objMet(m, 'fileChild')
endProcedure fileChild
fileRm: procedure expose m.
parse arg m
interpret objMet(m, 'fileRm')
return
endProcedure fileRm
filePath: procedure expose m.
parse arg m
interpret objMet(m, 'filePath')
endProcedure filePath
fileIsFile: procedure expose m.
parse arg m
interpret objMet(m, 'fileIsFile')
endProcedure fileIsFile
fileIsDir: procedure expose m.
parse arg m
interpret objMet(m, 'fileIsDir')
endProcedure fileIsDir
fileMkDir: procedure expose m.
parse arg m, opt
interpret objMet(m, 'fileMkDir')
return
endProcedure fileRm
fileRmDir: procedure expose m.
parse arg m, opt
interpret objMet(m, 'fileRmDir')
return
endProcedure fileRm
/*--- create a reader/WriteO for the filelist of a directory----------*/
fileList: procedure expose m.
parse arg m, opt
str = oIfStr(m, '')
if str == '' then
return oNew('FileList', filePath(m), opt)
else
return oNew('FileList', dsn2Jcl(str), opt)
endProcedure fileList
catIni: procedure expose m.
if m.cat.ini == 1 then
return
m.cat.ini = 1
call errIni
call jIni
call classNew "n Cat u JRW", "m",
, "jOpen call catOpen m, opt",
, "jReset call catReset m, arg",
, "jClose call catClose m",
, "jRead return catRead(m)",
, jWrite1Met("call catWrite m, m.var"),
, "jWriteAll call catWriteAll m, rdr; return"
if m.err.os == 'TSO' then
call fileTsoIni
else if m.err.os == 'LINUX' then
call fileLinuxIni
else
call err 'file not implemented for os' m.err.os
return
endProcedure catIni
/* copy cat end ****************************************************/
/* copy mail begin ***************************************************/
mailHead: procedure expose m.
parse arg m, subj, rec, snd
m.m.1 = 'sender='if(snd=='', userid(), snd)
m.m.2 = 'type=TEXT/HTML'
m.m.3 = 'to='rec
m.m.4 = 'subject='subj
m.m.5 = 'SEND=Y'
m.m.6 = 'TEXT=<HTML>'
m.m.7 = 'TEXT=<HEAD>'
m.m.8 = 'TEXT=</HEAD>'
m.m.9 = 'TEXT=<BODY>'
m.m.10 = 'TESTINFO=Y'
m.m.0 = 10
return m
endProce4 re mailHead
/*--- add one or several arguments to stem m.a -----------------------*/
mailText: procedure expose m.
parse arg a
ix = m.a.0
do ax = 2 to arg()
ix = ix + 1
m.a.ix = 'text='arg(ax)
end
m.a.0 = ix
return a'.'ix
endProcedure mailText
mailSend: procedure expose m.
parse arg m, dsn
call mAdd m,'INFO=Y' ,
,'TEXT=</BODY>' ,
,'TEXT=</HTML>'
call dsnAlloc 'dd(mailIn)' if(dsn<> '', dsn, 'new') '::v4092'
call writeDD mailIn, 'M.'m'.'
call tsoClose mailIn
if m.mail_libAdd \== 0 then do
dsnOs3560 = 'PCL.U0000.P0.'iirz2dsn(sysVar(sysNode)) ,
|| 'AKT.PERM.@008.LLB'
call adrTSO "TLIB ADD DATASET('"dsnOs3560"') STEPLIB"
end
address LINKMVS 'OS3560'
if rc <> 0 then
call err 'call OS3560 failed Rc('rc')'
if m.mail_libAdd \== 0 then
call adrTSO "TLIB delete DATASET('"dsnOs3560"') STEPLIB"
call tsoFree mailIn
return 0
endProcedure mailSend
/* copy mail end *****************************************************/
/* copy fiLinux begin *************************************************/
/*--- send ggShCmd to shell bash,
fail if rc <> 0 or not listed in ggRet -----------------------*/
adrSh: procedure expose m. /* really no need for variables???? */
parse arg ggShCmd, ggRet
address 'bash' ggShCmd
if rc == 0 then return 0
else if ggRet == '*' then return rc
else if wordPos(rc, ggRet) > 0 then return rc
else
call err 'adrSh rc' rc 'for' ggShCmd
endProcedure adrSh
fileLinuxReset: procedure expose m.
parse arg m, nm
m.m.spec = nm
if abbrev(nm, '&') then do
if nm == '&in' then do
m.m.stream = .input
m.m.jReading = 1
end
else if nm == '&out' then do
m.m.stream = .output
m.m.jWriting = 1
end
else do
call err 'bad spec' nm
end
end
else do
m.m.stream = .Stream%%new(nm)
m.m.stream%%init(m.m.stream%%qualify)
end
return m
endProcedure fileLinuxReset
fileLinuxOpen: procedure expose m.
parse arg m, opt
if opt == m.j.cRead then do
res = m.m.stream%%open(read shareread)
m.m.jReading = 1
end
else do
if opt == m.j.cApp then
res = m.m.stream%%open(write append)
else if opt == m.j.cWri then
res = m.m.stream%%open(write replace)
else
call err 'fileLinuxOpen('m',' opt') with bad opt'
m.m.jWriting = 1
end
if res \== 'READY:' then
call err 'fileLinuxOpen fails' res':' opt ,
"'"m.m.stream%%qualify"'"
return m
endProcedure fileLinuxOpen
fileLinuxClose:
parse arg m
res = m.m.stream%%close
if res \== 'READY:' then
call err 'fileLinuxClose' res':' m.m.stream%%qualify
return m
endProcedure fileLinuxClose
fileLinuxRead: procedure expose m.
parse arg m, var
res = m.m.stream%%lineIn
if res == '' then
if m.m.stream%%state \== 'READY' then
return 0
m.var = res
m.o.o2c.var = m.class_V
return 1
endProcedure fileLinuxRead
fileLinuxWrite: procedure expose m.
parse arg m, line
if m.m.stream%%lineOut(line) then
call err 'fileLinuxWrite'
return
endProcedure fileLinuxWrite
fileLinuxRmDir: procedure expose m.
parse arg m, opt
if opt == '' then
return adrSh('rmdir' m.m.spec)
else if opt == '-r' then
return adrSh('rm -r' m.m.spec)
else
call err 'bad opt' opt 'in fileLinuxRmDir'
endProcedure fileLInuxRmDir
fileLinuxListReset: procedure expose m.
parse arg m, m.m.spec, o
if o == 'r' then
m.m.opt = 'S'
else if o == '' then
m.m.opt = ''
else
call err 'bad opt' o 'in fileLinuxListReset'
m.m.rx = 'closed'
return m
endProcedure fileLinuxListReset
fileLinuxListOpen: procedure expose m.
parse arg m
if m \== translate(m) then
call err 'bad m for fileLinuxList:' m
if m.m.opt == '' then
rc = sysFileTree(m.m.spec'/*', 'm.'m'.LIST')
else
rc = sysFileTree(m.m.spec'/*', 'm.'m'.LIST', m.m.opt)
if rc \== 0 then
call err 'rc' rc 'in sysFileTree('m.m.spec', m.'m'.LIST)'
m.m.rx = 0
m.m.jReading = 1
return m
endProcedure fileLinuxListOpen
fileLinuxListRead: procedure expose m.
parse arg m, var
x = m.m.rx + 1
if x > m.m.list.0 then
return 0
m.var = substr(m.m.list.x, 43)
m.m.rx = x
call oMutate var, m.class_V
return 1
endProcedure fileLinuxListRead
fileLinuxIni: procedure expose m.
if m.fileLinux.ini == 1 then
return
m.fileLinux.ini = 1
m.file.sep = '/'
call jIni
call classNew "n File u JRW", "m",
, "jReset call fileLinuxReset m, arg",
, "jOpen call fileLinuxOpen m, opt",
, "jClose call fileLinuxClose m",
, "jRead return fileLinuxRead(m, var)",
, "jWrite call fileLinuxWrite m, line",
, "filePath return m.m.stream%%qualify",
, "fileIsFile return sysIsFile(m.m.stream%%qualify)" ,
, "fileIsDir return sysIsFileDirectory(m.m.stream%%qualify)" ,
, "fileChild return file(m.m.stream%%qualify'/'name)",
, "fileRm return adrSh(m.m.spec)",
, "fileMkDir return adrSh('mkdir' m.m.stream%%qualify)" ,
, "fileRmDir return fileLinuxRmDir(m, opt)"
call classNew "n FileList u JRW", "m",
, "jReset call fileLinuxListReset m, arg, arg2",
, "jOpen call fileLinuxListOpen m, opt",
, "jClose m.m.rx = 'closed'",
, "jRead return fileLinuxListRead(m, var)"
return
endProcedure fileLinuxIni
/* copy fiLinux end *************************************************/
/* copy fileTso begin *************************************************/
fileTsoReset: procedure expose m.
parse arg m, sp
m.m.readIx = 'c'
m.m.bufMax = 200
if symbol('m.m.defDD') \== 'VAR' then
m.m.defDD = 'CAT*'
m.m.spec = sp
return m
endProcedure fileTsoReset
fileTsoOpen: procedure expose m.
parse arg m, opt
call dsnSpec m, m.m.spec
if m.m.dsn ='INTRDR' | wordPos('WRITER(INTRDR)', m.m.attr) > 0 then
m.m.stripT = 80
else
m.m.stripT = copies('t',
, pos(':V', m.m.attr) < 1 | pos('RECFM(V', m.m.attr) > 0)
if opt == m.j.cRead then do
aa = dsnAllo2(m, 'SHR', m.m.defDD)
if pos('(', m.m.dsn) > 0 & m.m.sys == '' then
if sysDsn("'"m.m.dsn"'") <> 'OK' then
call err 'cannot read' m.m.dsn':' sysDsn("'"m.m.dsn"'")
call tsoOpen word(aa, 1), 'R'
end
else do
if opt == m.j.cApp then
aa = dsnAllo2(m, 'MOD', m.m.defDD)
else if opt == m.j.cWri then
aa = dsnAllo2(m, 'OLD', m.m.defDD)
else
call err 'fileTsoOpen('m',' opt') with bad opt'
call tsoOpen word(aa, 1), 'W'
end
m.m.buf.0 = 0
parse var aa m.m.dd m.m.free
return m
endProcedure fileTsoOpen
fileTsoClose: procedure expose m.
parse arg m
if m.m.jWriting then
if m.m.buf.0 > 0 then
call fileTsoWrite m
call tsoClose m.m.dd
call tsoFree m.m.free
m.m.free = ''
m.m.dd = ''
return m
endProcedure fileTsoClose
fileTsoWrite: procedure expose m.
parse arg m
if m.m.stripT == 't' then do bx=1 to m.m.buf.0
m.m.buf.bx = strip(m.m.buf.bx, 't')
end
else if m.m.stripT \== '' then do bx=1 to m.m.buf.0
m.m.buf.bx = left(m.m.buf.bx, m.m.stripT)
end
call writeDD m.m.dd, 'M.'m'.BUF.', , m.m.tso_truncOk == 1
m.m.buf.0 = 0
return
endProcedure fileTsoWrite
fSub: procedure expose m.
return file('sysout(T) writer(intRdr)')
endProcedure fSub
fEdit: procedure expose m.
parse arg spec, vw
if spec == '' then
spec = 'new ::f'
else if abbrev(spec, '::') then
spec = 'new' spec
else if abbrev(spec, ':') then
spec = 'new' ':'spec
f = oNew('FileEdit', spec)
m.f.editArgs = vw
return f
endProcedure fEdit
fileTsoEditOpen: procedure expose m.
parse arg m, opt
call fileTsoOpen m, opt
m.m.maxL = tsoDSIMaxl(m.m.dd)
return m
endProcedure fileTsoEditOpen
fileTsoEditClose: procedure expose m.
parse arg m
dsn = m.m.dsn
parse var m.m.editArgs eTy eAr
upper eTy
if abbrev('VIEW', eTy) then
eTy = 'view'
else do
if \ abbrev('EDIT', eTy) then
eAr = m.m.editArgs
eTy = 'edit'
end
/* parm uses a variable not text ||||*/
cx = pos('PARM(', translate(eAr))
cy = pos(')', eAr, cx+5)
if cx > 0 & cy > cx then do
macrParm = substr(eAr, cx+5, cy-cx-5)
eAr = left(eAr, cx+4)'macrParm'substr(eAr, cy)
end
if dsn \== '' then do
call fileTsoClose m
call adrIsp eTy "dataset('"dsn"')" eAr, 4
return
end
fr = m.m.free
dd = m.m.dd
m.m.free = ''
call fileTsoClose m
call adrIsp "LMINIT DATAID(lmmId) ddName("dd") ENQ(SHRW)"
eRc = adrIsp(eTy "dataid("lmmId")" eAr, '*')
lRc = adrIsp("LMFree DATAID("lmmId")", '*')
call tsoFree fr
if (eRc \== 0 & eRc \== 4) | lRc \== 0 then
call err eTy eAr 'rc' eRc', lmFree rc' lRc
return
endProcedure fileTsoEditClose
fileTsoIni: procedure expose m.
if m.fileTso.ini == 1 then
return
m.fileTso.ini = 1
m.file.sep = '.'
m.fileTso.buf = 0
call jIni
um = "call err 'for tso undefined method'"
call classNew "n File u JRW", "m",
, "jOpen call fileTsoOpen m, opt",
, "jReset call fileTsoReset m, arg",
, "jClose call fileTsoClose m",
, "jRead if \ readDD(m.m.dd, 'M.'m'.BUF.') then return 0",
, "jWrite call fileTsoWrite m, line",
, "filePath call dsnSpec m, m.m.spec; return m.m.dsn" ,
, "fileIsFile" um "'fileIsFile'" ,
, "fileIsDir return 1" ,
, "fileChild return file(word(m.m.spec, 1)'.'name opt)",
, "fileRm" um "'fileRm'" ,
, "fileMkDir" ,
, "fileRmDir" um "'fileRmDir'"
/* , "filePath return m.m.stream%%qualify",
, "fileIsFile return sysIsFile(m.m.stream%%qualify)" ,
, "fileIsDir return sysIsFileDirectory(m.m.stream%%qualify)" ,
, "fileChild return file(m.m.stream%%qualify'/'name)",
, "fileRm return adrSh(m.m.spec)",
, "fileMkDir return adrSh('mkdir' m.m.stream%%qualify)" ,
, "fileRmDir return fileLinuxRmDir(m, opt)" */
call classNew "n FileList u JRW", "m",
, "jReset if arg2 == 'r' then m.m.dsnMask=arg'.**';",
"else m.m.dsnMask=arg'.*';",
, "jOpen call csiOpen m, m.m.dsnMask",
, "jClose" ,
, "jRead return csiNext(m, m)"
call classNew "n FileEdit u File, f MAXL v", "m",
, "jOpen call fileTsoEditOpen m, opt",
, "jWrite call fileTsoWrite m, o2Text(line, m.m.maxL)",
, "jClose call fileTsoEditClose m"
return
endProcedure fileTsoIni
/* copy fileTso end *************************************************/
/* copy mat begin *****************************************************/
sqrt: procedure expose m.
parse arg n
if n < 2 then
return n
k = 1
g = n
do while k+1 < g
m = (g + k) % 2
if m * m <= n then
k = m
else
g = m
end
return k
endProcedure sqrt
isPrime: procedure expose m.
parse arg n
if n < 2 then
return 0
if n // 2 = 0 then
return n = 2
do q=3 by 2 to sqrt(n)
if n // q = 0 then
return 0
end
return 1
endProcedure isPrime
nxPrime: procedure expose m.
parse arg n
do i = n + (\ (n // 2)) by 2
if isPrime(i) then
return i
end
endProcedure nxPrime
permut: procedure expose m.
parse arg m, p
m.m.1 = 1
do i=2 while p > 0
j = i - (p // i)
m.m.i = m.m.j
m.m.j = i
p = p % i
end
m.m.0 = i-1
return i-1
endProcedure permut
/* copy mat end *****************************************************/
/* copy sqlDiv begin **************************************************/
/*--- generate the format m for a sql cx as specified in sp
use the information from the sqlDa -------------------------*/
sqlFTabReset: procedure expose m.
parse arg ff, c, maxCh, maxBlo, maxDe
return sqlFTabOpts(fTabReset(ff, , , '-'), c, maxCh, maxBlo, maxDe)
sqlFTabOpts: procedure expose m.
parse arg ff, cx, m.ff.maxChar, m.ff.blobMax, m.ff.maxDec
if m.ff.maxChar == '' then
m.ff.maxChar = 32
if m.ff.blobMax == '' then
m.ff.blobMax = 200
bf = '%-'max(m.ff.blobMax, 4)'C'
m.ff.flds = ''
m.ff.sqlX = cx
m.ff.sqlOthers = 0
m.ff.sql2fmt.384 = '%-10C' /* date */
m.ff.sql2fmt.388 = '%-8C' /* time */
m.ff.sql2fmt.392 = '%-26C' /* timestamp */
m.ff.sql2fmt.400 = 'c' /* graphic string */
m.ff.sql2fmt.404 = bf /* BLOB */
m.ff.sql2fmt.408 = bf /* CLOB */
m.ff.sql2fmt.412 = bf /* DBCLOB */
m.ff.sql2fmt.448 = 'c' /* varchar */
m.ff.sql2fmt.452 = 'c' /* char */
m.ff.sql2fmt.452 = 'c' /* long varchar */
m.ff.sql2fmt.460 = 'c' /* null term. string */
m.ff.sql2fmt.464 = 'c' /* graphic varchar */
m.ff.sql2fmt.468 = 'c' /* graphic char */
m.ff.sql2fmt.472 = 'c' /* long graphic varchar */
m.ff.sql2fmt.480 = '%-7e' /* float */
m.ff.sql2fmt.484 = 'd' /* packed decimal */
m.ff.sql2fmt.492 = '%20i' /* bigInt */
m.ff.sql2fmt.496 = '%11i' /* int */
m.ff.sql2fmt.500 = '%6i' /* smallInt */
m.ff.sql2fmt.904 = '%-34H' /* rowID 17 Byte Binary */
return ff
endProcedure sqlFTabOpts
/*--- set a defaultFormat for type tx in fTab ff ---------------------*/
sqlFTabDef: procedure expose m.
parse arg ff, tx, m.ff.sql2fmt.tx
return ff
sqlFTabAdd: procedure expose m.
parse arg m, c1 aDone, f1, l1
if symbol('m.m.set.c1') == 'VAR' then do
sx = m.m.set.c1
if word(m.m.set.sx, 1) == c1 & sx <= m.m.set.0 then do
parse var m.m.set.sx c1 aDone
f1 = m.m.set.sx.fmt
l1 = m.m.set.sx.labelTi
end
end
cx = m.m.sqlX
f2x = classMet(sqlFetchClass(cx), 'f2x')
if symbol('m.f2x.c1') \== 'VAR' then
call err 'colName not found' c1
kx = m.f2x.c1
t1 = m.sql.cx.d.kx.sqlName
if l1 == '' then
l1 = t1
if f1 == '' then do
ty = m.sql.cx.d.kx.sqlType
le = m.sql.cx.d.kx.sqlLen
withNulls = ty // 2
ty = ty - withNulls
if symbol('m.m.sql2fmt.ty') <> 'VAR' then
call err 'sqlType' ty 'col' c1 'not supported'
f1 = m.m.sql2fmt.ty
if f1 == 'c' then
f1 = '%-'min(le, m.m.maxChar)'C'
else if f1 == 'd' then do
trace ?r
pr = le % 256
de = le // 256
f1 = '%'pr'.'de'i'
end
if \ abbrev(f1, '%') then
call err 'sqlType' ty 'col' c1 'bad format' f1
end
call fTabAddRCT m, c1 aDone, f1, t1, l1
ox = m.m.0
m.m.ox.tit.0 = max(arg()-3, 1)
do tx=2 to m.m.ox.tit.0
m.m.ox.tit.tx = arg(tx+3)
end
return m
endProcedure sqlFTabAdd
sqlFTabOthers: procedure expose m.
parse arg m, doNot
cx = m.m.sqlX
ff = m.sql.cx.fetchFlds
m.m.sqlOthers = 1
do kx=1 to m.sql.cx.d.sqlD
c1 = word(ff, kx)
wx = wordPos(c1, m.m.cols)
if (wx < 1 | m.m.wx.done \== 1) & wordPos(c1, doNot) < 1 then
call sqlFTabAdd m, c1
end
return m
endProcedure sqlFTabOthers
sqlFTab: procedure expose m.
parse arg m
call fTabBegin m
do while sqlRxFetch(m.m.sqlX, 'sqlFTab')
call out f(m.m.fmt, 'sqlFTab')
end
return fTabEnd(m)
endProcedure sqlFTab
sqlFTabCol: procedure expose m.
parse arg m
if pos('c', m.m.generated) < 1 then
call fTabColGen m
do rx=1 while sqlRxFetch(m.m.sqlX, 'sqlFTab')
call out left('--- row' rx '', 80, '-')
call fTabCol m, 'sqlFTab'
end
call out left('--- end of' (rx-1) 'rows ', 80, '-')
return
endProcedure sqlFTabCol
sqlCatTb: procedure expose m.
parse arg ty gOnly, wh, ord, fTab, paPlus
tb = tkrTable(, ty)
if gOnly == 1 then
edFun = ''
else
edFun = tkrTable(, ty, 'e')
cx = 1
ft = 'ft'm.tb.alias
call sqlFTabOpts FTabReset(ft, 'c 1', '1 c', '-'),
,cx , 12, if(fTab, , 2000)
call sqlFTabDef ft, 492, '%7e'
call FTabSet ft, 'CONTOKEN' , '%-16H'
call FTabSet ft, 'DCONTOKEN' , '%-16H'
call FTabSet ft, 'DBNAME' , '%-8C', 'db'
call FTabSet ft, 'DSNAME' , '%-44C'
call FTabSet ft, 'DSNUM' , '%5i'
call FTabSet ft, 'PARTITION' ,'%5i' , 'part'
call FTabSet ft, 'PIT_RBA' , '%-12H'
call FTabSet ft, 'RBA1' , '%-12H'
call FTabSet ft, 'RBA2' , '%-12H'
call FTabSet ft, 'START_RBA' ,'%-12H'
call FTabSet ft, 'TSNAME' , '%-8C', 'ts'
call FTabSet ft, 'VERSION' , '%-28C'
if edFun \== '' then do
interpret 'sq =' edFun'(ft, tb, wh, ord)'
end
else do
cl = sqlColList(m.tb.table, m.ft.blobMax)
sq = 'select' cl tkrTable( , tb, 'f') wh ,
'order by' if(ord=='', m.tb.order, ord)
call sqlQuery cx, sq
call sqlFTabOthers ft
call sqlCatTbVl ft, tb
end
if fTab then
call sqlFTab ft
else
call sqlFTabCol ft
call sqlClose cx
call sqlCatTbTrailer space(m.TKR.path paPlus, 1), sq
return 0
endProcedure sqlCatTb
sqlCatTbVlsep:
return '+++'
sqlCatTbVl: procedure expose m.
parse arg ft, tb, sep
if sep == '' then
sep = sqlCatTbVLsep()
if m.tb.vlKey == '' then
return
ky = m.tb.vlKey
ff = ''
tt = ''
do kx=1 to m.ky.0
tt = tt || sep || m.ky.kx.col
ff = ff || sep'@'m.ky.kx.col'%S'
end
call fTabAddRCT ft, substr(tt,length(sep)+1) ,
, substr(ff,length(sep)+1)
return
endProcedure sqlCatTbVl
sqlCatTbTrailer: procedure expose m.
parse arg pa, sq
ox = lastPos(' order by ', sq)
if ox < 1 then
call err 'order by not found in' sq
ord = substr(sq, ox+10)
sq = left(sq, ox-1)
sqUp = translate(sq)
call out ''
call out 'dbSys:' m.sql_dbSys
call out 'path:' pa
int = ''
iNx = ' '
br = ''
cx = 1
stops = '(select from where'
do while cx < length(sq)
nx = -1
do sx=1 to words(stops)
n2 = pos(word(stops, sx), sq, cx+1)
if n2 > cx & (nx < 1 | n2 < nx) then
nx = n2
end
if nx < 0 then
leave
call out int || substr(sq, cx, nx-cx)
int = iNx
if substr(sq, nx, 3) = '(se' then do
iNx = iNx' '
br = left(br, length(int))')'
end
cx = nx
end
ll = strip(substr(sq, cx))
bq = strip(br)
do while bq <> ''
if right(bq, 1) \== ')' | right(ll, 1) \== ')' then
call err 'missing ) bq:' bq', ll:' ll
ll = strip(left(ll, length(ll) - 1))
bq = strip(left(bq, length(bq) - 1))
end
call out int || ll
if br <> '' then
call out br
if ord <> '' then
call out ' order by' ord
return
endProcedure sqlCatTbTrailer
sqlCatIxKeys: procedure expose m.
parse arg ft, tb, wh, ord
sq = 'select ikK.colSeq, ikK.colName, ikK.ordering, ikK.period' ,
', ik.creator, ik.name, ik.tbCreator, ik.tbName, ikC.*' ,
tkrTable(, tb ,'f') wh,
'order by' if(ord == '', m.tb.order, ord)
call sqlQuery m.ft.sqlX, sq
call sqlFTabAdd ft, CREATOR, '%-8C', 'creator'
call sqlFTabAdd ft, NAME , '%-16C','index'
call sqlFTabAdd ft, colSeq , '%5i', 'coSeq'
call sqlFTabAdd ft, colName, '%-16C', 'column'
call sqlFTabAdd ft, ordering
call sqlFTabAdd ft, period
call sqlFTabAdd ft, COLNO
call sqlFTabAdd ft, COLTYPE
call sqlFTabAdd ft, LENGTH
call sqlFTabAdd ft, SCALE
call sqlFTabAdd ft, NULLS
call sqlFTabOthers ft, 'COL9 COL10 COL11 COL47'
call sqlCatTbVl ft, tb
return sq
endProcedure sqlCatIxKeys
sqlCatIXStats: procedure expose m.
parse arg ft, tb, wh, ord
sq = 'select *' tkrTable( , tb, 'f') wh ,
'order by' if(ord == '', m.tb.order, ord)
call sqlQuery m.ft.sqlX, sq
call sqlFTabAdd ft, CREATOR, '%-8C', 'creator'
call sqlFTabAdd ft, NAME , , 'index'
call sqlFTabAdd ft, INSTANCE , '%1i' , 'i'
call sqlFTabAdd ft, PARTITION , , 'part'
call sqlFTabOthers ft
call sqlCatTbVl ft, tb
return sq
endProcedure sqlCatIXStats
sqlCatTables: procedure expose m.
parse arg ft, tb, wh, ord
al = m.tb.alias
sq = 'select' al'.*, tsX.type tsType, tsX.partitions',
', tsX.pgSize, tsX.dsSize' ,
', timestamp(rba1 || x''0000'') rba1Tst' ,
', timestamp(rba2 || x''0000'') rba2Tst' ,
'from' m.tb.table 'left join sysibm.sysTablespace tsX',
'on' al'.dbName = tsx.dbName and' al'.tsName = tsX.name',
'where' m.tb.cond wh ,
'order by' if(ord == '', m.tb.order, ord)
call sqlQuery m.ft.sqlX, sq
call sqlFTabAdd ft, creator , '%-8C', 'creator'
call sqlFTabAdd ft, NAME , '%-24C', 'table'
call sqlFTabAdd ft, type
call sqlFTabAdd ft, dbNAME , '%-8C', 'db'
call sqlFTabAdd ft, tsNAME , '%-8C', 'ts'
call sqlFTabAdd ft, tsType
call sqlFTabAdd ft, partitions, , 'parts'
call sqlFTabAdd ft, pgSize
call sqlFTabAdd ft, dsSize
call sqlFTabOthers ft, 'RBA1 RBA1TST RBA2 RBA2TST'
call sqlFTabAdd ft, rba1 , '%-12H'
call sqlFTabAdd ft, rba1Tst , , 'rba1Timestamp:GMT'
call sqlFTabAdd ft, rba2 , '%-12H'
call sqlFTabAdd ft, rba2Tst , , 'rba2Timestamp:GMT'
call sqlCatTbVl ft, tb
return sq
endProcedure sqlCatTables
sqlCatTSStats: procedure expose m.
parse arg ft, tb, wh, ord
sq = 'select' m.tb.alias'.*' ,
tkrTable( , tb, 'f') wh ,
'order by' if(ord == '', m.tb.order , ord)
call sqlQuery m.ft.sqlX, sq
call sqlFTabAdd ft, DBNAME, '%-8C', 'db'
call sqlFTabAdd ft, NAME , '%-8C', 'ts'
call sqlFTabAdd ft, INSTANCE , '%1i' , 'i'
call sqlFTabAdd ft, PARTITION , , 'part'
call sqlFTabAdd ft, NACTIVE , , 'nActive'
call sqlFTabAdd ft, NPAGES , , 'nPages'
call sqlFTabAdd ft, SPACE , , 'spaceKB'
call sqlFTabAdd ft, TOTALROWS , , 'totRows'
call sqlFTabAdd ft, DATASIZE , , 'dataSz'
call sqlFTabAdd ft, LOADRLASTTIME , , 'loadRLasttime'
call sqlFTabAdd ft, REORGLASTTIME , , 'reorgLasttime'
call sqlFTabAdd ft, REORGINSERTS , , 'inserts'
call sqlFTabAdd ft, REORGDELETES , , 'deletes'
call sqlFTabAdd ft, REORGUPDATES , , 'updates'
call sqlFTabAdd ft, REORGUNCLUSTINS , , 'unClIns'
call sqlFTabAdd ft, REORGDISORGLOB , , 'disorgL'
call sqlFTabAdd ft, REORGMASSDELETE , , 'massDel'
call sqlFTabAdd ft, REORGNEARINDREF , , 'nearInd'
call sqlFTabAdd ft, REORGFARINDREF , , 'farInd'
call sqlFTabAdd ft, REORGCLUSTERSENS , , 'cluSens'
call sqlFTabAdd ft, REORGSCANACCESS , , 'scanAcc'
call sqlFTabAdd ft, REORGHASHACCESS , , 'hashAcc'
call sqlFTabAdd ft, STATSLASTTIME , , 'statsLasttime'
call sqlFTabAdd ft, STATSINSERTS , , 'inserts'
call sqlFTabAdd ft, STATSDELETES , , 'deletes'
call sqlFTabAdd ft, STATSUPDATES , , 'updates'
call sqlFTabAdd ft, STATSMASSDELETE , , 'massDel'
call sqlFTabAdd ft, COPYLASTTIME , , 'copyLasttime'
call sqlFTabAdd ft, COPYUPDATETIME , , 'copyUpdatetime'
call sqlFTabAdd ft, COPYUPDATELRSN , '%-12H', 'updateLRSN'
call sqlFTabAdd ft, COPYUPDATEDPAGES , , 'updaPgs'
call sqlFTabAdd ft, COPYCHANGES , , 'changes'
call sqlFTabOthers ft
call sqlCatTbVl ft, tb
return sq
endProcedure sqlCatTSStats
sql4obj: procedure expose m.
parse arg m, tb
call out 'insert into' tb '--' className(objClass(m))
line = ''
ff = oFldD(m)
pr = ' ('
do fx=1 to m.ff.0
call sql4ObjOut substr(m.ff.fx, 2)
end
call sql4ObjOut , 1
call out ' ) values '
pr = ' ('
do fx=1 to m.ff.0
f1 = m || m.ff.fx
v = m.f1 /* no strip T, gives errors in RCM profile | */
if dataType(v, n) then
call sql4ObjOut v
else do qx=1 until v == ''
vx = verify(v, m.ut_alfPrint)
if vx = 0 then do
l1 = min(60, length(v))
w = quote(left(v, l1), "'")
end
else if vx > 29 then do
l1 = min(60, vx-1)
w = quote(left(v, l1), "'")
end
else do
l1 = min(29, length(v))
w = 'x'quote(c2x(left(v, l1)), "'")
end
if qx == 1 then
call sql4ObjOut w
else do
if qx = 2 then
call sql4ObjOut , 1
call out ' ||' w
end
v = substr(v, l1+1)
end
end
call sql4ObjOut , 1
call out ' ) ; '
return
endProcedure
sql4objOut:
parse arg t1, force
if (force == 1 & line \== '') | length(line t1) > 65 then do
call out pr substr(line, 3)
pr = ' ,'
line = ''
end
if force \== 1 then
line = line',' t1
return
endProcedure sql4objOut
/*--- -dis db interface ---------------------------------------------*/
/*--- do one -dis db... and insert it into stem --------------------*/
sqlDisDb: procedure expose m.
parse upper arg o, cc
do cx=1
mid = strip(left(m.cc.cx, 10))
if words(mid) > 1 then
call err 'bad msgId' mid 'line:' m.cc.cx
if mid == '' | wordPos(mid, 'DSNT360I DSNT361I DSNT365I') ,
> 0 then
iterate
if mid == 'DSN9022I' then
if cx = m.cc.0 then
return m.o.0
else
call err 'not at end' cx':' m.cc.cx
if mid \== 'DSNT362I' then
call err 'DSNT362I expected not line:' m.cc.cx
dx = pos('DATABASE =', m.cc.cx)
sx = pos('STATUS =' , m.cc.cx)
if dx < 1 | sx <= dx then
call err 'bad DSNT362I line' cx':' m.cc.cx
db = word(substr(m.cc.cx, dx+10), 1)
sta = strip(substr(m.cc.cx, sx+8))
call sqlDisDbAdd o, db, ,0, 0, 'DB', sta
do cx=cx+1 while abbrev(m.cc.cx, ' ')
end
if abbrev(m.cc.cx, 'DSNT397I ') then do
cx = cx + 1
if \ abbrev(space(m.cc.cx, 1),
, 'NAME TYPE PART STATUS ') then
call err 'NAME TYPE PART STATUS mismatch' cx m.cc.cx
txNa = pos('NAME', m.cc.cx)
txTy = pos('TYPE', m.cc.cx)
txPa = pos('PART', m.cc.cx)
txSt = pos('STAT', m.cc.cx)
txEn = verify(m.cc.cx, ' ', 'n', txSt+6)
if 0 then say 'title' txNa txTy txPa txSt txEn cx m.cc.cx
cx=cx+1
do forever
do while abbrev(m.cc.cx, '----')
cx = cx + 1
end
if abbrev(m.cc.cx, '*') then
leave
parse var m.cc.cx sp =(txTy) ty . =(txPa) paFr . ,
=(txSt) sta =(txEn)
sp = strip(sp)
if words(sp) \= 1 | wordPos(ty, 'TS IX') < 0 then
call err 'bad name or type' cx':'m.cc.cx
if paFr == '' | paFr == 'L*' then
paFr = 0
else if abbrev(paFr, 'D') | abbrev(paFr, 'L') then
paFr = substr(paFr, 2)
if \ datatype(paFr, 'n') then
call err 'part not numeric' cx':'m.cc.cx
paTo = paFr
cw = cx
cx = cx + 1
if abbrev(m.cc.cx, ' -THRU ') then do
parse var m.cc.cx =(txPa) paTo . =(txSt)
if \ datatype(paTo, 'n') then
call err '-thru part not numeric' cx':'m.cc.cx
cx = cx + 1
end
call sqlDisDbAdd o, db, sp, paFr, paTo, ty, sta
end
end
if m.cc.cx = '******** NO SPACES FOUND' then
cx = cx + 1
if abbrev(m.cc.cx, '******* DISPLAY OF DATABASE ') ,
& word(m.cc.cx,5) == db then
if word(m.cc.cx,6) == 'ENDED' then
iterate
else if word(m.cc.cx,6) == 'TERMINATED' then
call err 'db display overflow' cx':' m.cc.cx
call err 'database' db 'ENDED mismatch' cx':' m.cc.cx
end
endProcedure sqlDbDis
/*--- insert one tuple into tDbState ---------------------------------*/
sqlDisDbAdd: procedure expose m.
if arg(7) == '' | arg(7) == 'RW' then
return
parse arg o
m.o.0 = m.o.0 + 1
q = o'.'m.o.0
parse arg , m.q.db, m.q.sp, m.q.paFr, m.q.paTo, m.q.ty, m.q.sta
/* say added q m.q.db'.'m.q.sp':'m.q.paFr'-'m.q.paTo m.q.ty':'m.q.sta*/
ky = m.q.db'.'m.q.sp
if symbol('m.o.ky') \== 'VAR' then
m.o.ky = m.o.0
return
endProceedure sqlDisDbAdd
/*--- get index in o for db sp part ----------------------------------*/
sqlDisDbIndex: procedure expose m.
parse arg st, d, s, pa
if symbol('m.st.d.s') \== 'VAR' then
return 0
ix = m.st.d.s
if ix > m.st.0 | d \== m.st.ix.db | s \== m.st.ix.sp then
return 0
if pa == '' then
return ix
do ix=ix to m.st.0 while d == m.st.ix.db & s == m.st.ix.sp
if pa < m.st.ix.paFr then
return 0
else if pa <= m.st.ix.paTo then
return ix
end
return 0
endProcedure sqlDisDbIndex
/*--- dsn Command, return true if continuation needed ----------------*/
sqlDsnCont: procedure expose m.
parse arg cc, ssid, cmd
say '???dsnCont' cmd
cont = sqlDsn(cc, ssid, cmd, 12) <> 0
if cont then do
cz = m.cc.0
cy = cz - 1
if \ abbrev(m.cc.cy, DSNT311I) ,
| \ abbrev(m.cc.cz, 'DSN9023I') then
call err 'sqlDsn rc=12 for' cmd 'out='cz ,
'\n'cy'='m.cc.cy'\n'cz'='m.cc.cz
m.cc.0 = cz-2
end
return cont
endProcedure sqlDsnCont
/* copy sqlDiv end **************************************************/
/* copy db2Cat begin **************************************************/
catTbLastCol: procedure expose m.
parse upper arg cr, tb
return sql2one( ,
"select strip(char(colcount)) || ' ' || strip(c.name) one" ,
"from sysibm.sysTables t left join sysibm.sysColumns c" ,
"on c.tbCreator = t.creator and c.tbName = t.name" ,
"and c.colNo = t.colCount" ,
"where t.creator = '"cr"' and t.name = '"tb"'",,,, 'r')
endProcedure catTbLastCol
catTbCols: procedure expose m.
parse upper arg cr, tb
if sql2St("select strip(name) name " ,
"from sysibm.sysColumns " ,
"where tbcreator = '"cr"' and tbname='"tb"'",
"order by colNo", ggSt) < 1 then
return ''
res = m.ggst.1.name
do cx=2 to m.ggst.0
res = res m.ggst.cx.name
end
return res
endProcedure catTbCols
catTbColsTrunc: procedure expose m.
parse upper arg cr, tb, maxL
if sql2St("select strip(name) name, colType, length, length2" ,
"from sysibm.sysColumns " ,
"where tbcreator = '"cr"' and tbname='"tb"'",
"order by colNo", ggSt) < 1 then
return ''
res = ''
do cx=1 to m.ggst.0
ty = m.ggSt.cx.colType
if pos('LOB', ty) > 0 then
res = res', substr('m.ggSt.cx.name', 1,' ,
min(maxL, m.ggSt.cx.length2)') 'm.ggSt.cx.name
else if pos('CHAR', ty) > 0 & m.ggSt.cx.length > maxL then
res = res', substr('m.ggSt.cx.name', 1,' maxL')',
m.ggSt.cx.name
else
res = res',' m.ggSt.cx.name
end
return substr(res, 3)
endProcedure catTbColsTrunc
catIxKeys: procedure expose m.
parse upper arg cr, ix
sql = "select colSeq sq, colName col, ordering ord" ,
"from sysibm.sysKeys" ,
"where ixCreator = '"cr"' and ixName = '"ix"'" ,
"order by colSeq"
call sqlQuery 1, sql
res = ''
drop d
do kx=1 while sqlFetch(1, d)
if m.d.sq \= kx then
call err 'expected' kx 'but got colSeq' m.d.sq ,
'in index' cr'.'ix'.'m.d.col
res = res || strip(m.d.col) || translate(m.d.ord, '<>?', 'ADR')
end
call sqlClose 1
return res
endProcedure catIxKeys
catColCom: procedure expose m.
parse upper arg fCr, fTb, tCr, tTb
sql = "select t.name, t.colType, t.nulls, t.""DEFAULT""" ,
", coalesce(f.nulls, 'new')" ,
"from sysibm.sysColumns t" ,
"left join sysibm.sysColumns f" ,
"on f.tbCreator = '"fCr"' and f.tbName = '"fTb"'" ,
"and f.name = t.name" ,
"where t.tbCreator = '"tCr"' and t.tbName = '"tTb"'" ,
"order by t.colNo"
call sqlQuery 1, sql, 'na ty nu de nn'
pr = ' '
do kx=1 while sqlFetch(1)
/* say kx m..na m..ty m..nu m..de 'nn' m..nn */
if pos('CHAR', m..ty) > 0 then
dv = "''"
else if pos('INT' ,m..ty) > 0 ,
| wordPos(m..ty, 'REAL FLOAT') > 0 then
dv = 0
else if m..ty == 'TIMESTMP' then
dv = '0001-01-01-00.00.00'
else if pos('LOB', m..ty) > 0 then
dv = m..ty"('')"
else
dv = '???'
if m..nu = 'Y' then
dv = 'case when 1=0 then' dv 'else null end'
r = '???'
if m..ty = 'ROWID' then do
r = '--'
end
else if m..nn == 'new' then do
if m..de = 'Y' then
r = '--'
else if m..nu == 'N' then
r = dv
else
r = 'case when 1=0 then' dv 'else null end'
end
else do
if m..nu = 'Y' | (m..nu = m..nn) then
r = ''
else
r = 'coalesce('m..na',' dv')'
end
if abbrev(r, '--') then do
r = ' ' r
end
else do
r = pr r
pr = ','
end
if pos('???', r) > 0 then
call err 'no default for type' m..ty 'in' tCr'.'tTb'.'m..na
call out r m..na
end
call sqlClose 1
return
endProcedure catColCom
/* copy db2Cat end **************************************************/
/* copy sqlO begin ***************************************************
sql interface mit o und j Anbindung
***********************************************************************/
sqlIni: procedure expose m.
if m.sql_ini == 1 then
return
m.sql_ini = 1
call sqlRxIni
call jIni
call scanReadIni
m.sqlO.cursors = left('', 200)
m.sql_rdrClass = classNew('n SqlRdr u JRW', 'm',
, "jReset m.m.src = arg; m.m.type = arg2;",
, "jOpen call sqlRdrOpen m, opt",
, "jClose call sqlRdrClose m",
, "jRead return sqlRdrRead(m)")
call classNew 'n SqlResRdr u JRW', 'm',
, "jReset m.m.cursor = arg; m.m.type = arg2;",
, "jOpen call sqlRdrO2 m" ,
, "jClose call sqlClose m.m.cursor" ,
, "jRead return sqlRdrRead(m)"
call classNew 'n SqlRxConnection u', 'm',
, "sqlQuery return sqlRxQuery(cx, src, feVa, retOK)",
, "sqlFetch return sqlRxFetch(cx, dst, retOk)",
, "sqlClose return sqlRxClose(cx, retOk)",
, "sqlUpdate return sqlRxUpdate(cx, src, retOk)",
, "sqlCall call err 'implement sqlRxCall"
call classNew 'n SqlRxStatement u', 'm',
, "sqlQuery return sqlRxQuery(m.cx.cursor, src, feVa, retOK)",
, "sqlFetch return sqlRxFetch(m.cx.cursor, dst, retOk)",
, "sqlClose return sqlRxClose(m.cx.cursor, retOk)",
, "sqlUpdate return sqlRxUpdate(m.cx.cursor, src, retOk)",
, "sqlCall call err 'implement sqlRxCall"
call classNew 'n SqlCsmConnection u', 'm',
, "sqlQuery return sqlCsmQuery(cx, src, feVa, retOK)",
, "sqlFetch return sqlCsmFetch(cx, dst, retOk)",
, "sqlClose return 0",
, "sqlUpdate call err 'implement sqlCsmUpdate'" ,
, "sqlCall call err 'implement sqlCsmCall'"
call classNew 'n SqlCsmStatement u', 'm',
, "sqlQuery return sqlCsmQuery(m.cx.cursor, src, feVa, retOk)",
, "sqlFetch return sqlCsmFetch(m.cx.cursor, dst, retOk)",
, "sqlClose return 0",
, "sqlUpdate call err 'implement sqlCsmUpdate'" ,
, "sqlCall call err 'implement sqlCsmCall'"
/* call classNew 'n SqlExecuteRdr u JRW', 'm',
, "jReset call sqlExecuteRdrReset(m, arg, arg2)" ,
, "jOpen call sqlExecuteRdrOpen(m)" ,
, "jClose call sqlExecuteRdrClose(m)" ,
, "jRead call sqlExecuteRdrRead(m)" ???????? */
return 0
endProcedure sqlIni
/*--- connect to DB2 dsnRexx or csm ----------------------------------*/
sqlConnect: procedure expose m.
parse upper arg sys, retOk
call sqlIni
if sys == '' then
sys = sqlDefaultSys()
if pos('/', sys) <= 0 then do
call sqlRxConnect sys
m.sql_connClass = class4Name('SqlRxConnection')
end
else do
parse var sys m.sql_csmHost '/' m.sql_dbSys
m.sql_connClass = class4Name('SqlCsmConnection')
end
return 0
endProcedure sqlConnect
/*--- disconnect from db2 --------------------------------------------*/
sqlDisconnect: procedure expose m.
parse arg retOk
if m.sql_csmHost == '' then
call sqlRxDisconnect
else
m.sql_csmHost = ''
m.sql_dbSys = ''
m.sql_connClass = 'sql not connected'
return 0
endProcedure sqlDisonnect
/*--- execute a query from sql, with one resultset -------------------*/
sqlQuery: procedure expose m.
parse arg cx, src, feVa, retOk
interpret classMet(m.sql_connClass, 'sqlQuery')
endProcedue sqlQuery
/*--- fetch next row to m.dst.* at end return false ------------------*/
sqlFetch: procedure expose m.
parse arg cx, dst, retOk
interpret classMet(m.sql_connClass, 'sqlFetch')
endProcedue sqlFetch
/*--- close cursor 'c'cx ---------------------------------------------*/
sqlClose: procedure expose m.
parse arg cx, retOk
interpret classMet(m.sql_connClass, 'sqlClose')
endProcedue sqlClose
/*-- execute an sql with no resultset, but possibly outParms ---------*/
sqlUpdate: procedure expose m.
parse arg cx, src, retOk
interpret classMet(m.sql_connClass, 'sqlUpdate')
endProcedue sqlUpdate
/*-- execute an sql call with outParms and multiple resultSets -------*/
sqlCall: procedure expose m.
parse arg cx, src, retOk
interpret classMet(m.sql_connClass, 'sqlCall')
endProcedure sqlCall
/*--- return a free cursor -------------------------------------------*/
sqlGetCursor: procedure expose m.
parse arg rng
if rng == '' then
return sqlGetCursorRng(rng, 10, 48)
else if rng == 'h' then
return sqlGetCursorRng(rng, 60, 99)
else if rng == 'a' then
return sqlGetCursorRng(rng, 110, 199)
else
call err 'bad cursor range' rng
endProcedure sqlGetCursor
sqlGetCursorRng: procedure expose m.
parse arg rng, fr, to
cx = pos(' ', m.sqlO.cursors, fr)
if cx < fr & cx > to then
call err "no more '"rng"' cursors between" fr "and" to,
":"m.sqlO.cursors
m.sqlO.cursors = overlay('u', m.sqlO.cursors, cx)
return cx
endProcedure sqlGetCursorRNG
/*--- mark a cursor as closed ----------------------------------------*/
sqlFreeCursor: procedure expose m.
parse arg cx
if substr(m.sqlO.cursors, cx, 1) \== 'u' then
call err 'sqlFreeCursor('cx') not in use :'m.sqlO.cursors
m.sqlO.cursors = overlay(' ', m.sqlO.cursors, cx)
return
endProcedure sqlFreeCursor
/*** execute sql's in a stream (separated by ;) and output as tab */
sqlStmts: procedure expose m.
parse arg sqlSrc, retOk, wOpt, sOpt
return sqlsOut(scanSqlStmtRdr(sqlSrc, wOpt, sOpt), retOk, 'a')
endProcedure sqlStmts
/*--- execute the given sql plus a commit
until no more rows are updated -----------------------------*/
sqlUpdComLoop: procedure expose m.
parse arg src, retOk
crs = sqlGetCursor()
upds = 0
if retOk == '' then
retOk = 100
do coms=0
cd = sqlExecute(crs, src, retOk)
if m.sql.crs.updateCount < 1 then do
call sqlFreeCursor(crs)
return sqlMsgLine( , upds, src, coms 'commits')
end
upds = upds + m.sql.crs.updateCount
call sqlCommit
if coms // 20 = 19 then
say sqlMsgLine(time(), upds, src, (coms+1) 'commits')
end
endProcedure sqlUpdComLoop
/*--- sql call statement ---------------------------------------------*/
sqlStmtCall: procedure expose m.
parse arg src, retOk, opt
s = scanSqlReset(scanSrc(sqlstmtcall, src))
if \ scanSqlId(scanSkip(s)) | m.s.val \== 'CALL' then
call scanErr s, 'not a call'
if \ scanSqlQuId(scanSkip(s)) then
call scanErr s, 'qualified id missing after call'
loc = ''
if m.s.val.0 = 1 then
wh = 'name =' quote(m.s.val.1, "'")
else if m.s.val.0 = 2 then
wh = "schema = '"strip(m.s.val.1)"'" ,
"and name = '"strip(m.s.val.2)"'"
else if m.s.val.0 = 3 then do
loc = m.s.val.1
wh = "schema = '"strip(m.s.val.2)"'" ,
"and name = '"strip(m.s.val.3)"'"
end
else
call scanErr s, 'storedProcedureName' m.s.val ,
'has' m.s.val.0 'parts, should have 1, 2 or 3'
pn = m.s.val
da = sqlStmtCallDa(sqlStmtCall, loc, wh)
if \ scanLit(scanSkip(s), '(') then
call scanErr s, '( expected after call' pn
varChars = f
do ax=1
m.da.ax.varName = ''
isEmpty = 0
if scanLit(scanSkip(s), ':') then do
if \ scanVerify(scanSkip(s), m.ut_alfDot) then
call scanErr s, 'variable expected after : in call' pn
m.da.ax.varName = m.s.tok
if m.da.ax.io == 'i' | m.da.ax.io == 'b' then
m.da.ax.sqlData = envGet(m.da.ax.varName)
end
else if scanString(s) then
m.da.ax.sqlData = m.s.val
else if scanVerify(s, ',):;', 'm') then
m.da.ax.sqlData = strip(m.s.tok)
else
isEmpty = 1
if scanLit(scanSkip(s), ')') then
leave
if \ scanLit(s, ',') then
call scanErr s, if(isEmpty, 'value, var, ') ,
|| "',' or ')' expected"
end
if ax \= m.da.sqlD then
if \ (ax=1 & m.da.sqlD = 0 & isEmpty) then
call scanErr s, 'call with' ax 'parms but' ,
pn 'needs' m.da.sqld
caCo = sqlExec('call' pn 'using descriptor :M.'da, 466)
call out '--- called' pn', sqlCode' caCo
do ax=1 to m.da.sqlD
call Out ' parm' ax m.da.ax.io m.da.ax.parmName,
|| if(m.da.ax.varName \== '',' $'m.da.ax.varName),
'=' m.da.ax.sqlData
if m.da.ax.varName \== '' then
call envPut m.da.ax.varName, m.da.ax.sqlData
end
if caCo = 466 then do
drop sqlDP
call sqlExec 'describe procedure :pn into :m.sqlDp'
if m.sqldp.sqlD < 1 then
call err 'bad sqldp sqlD='m.sqldp.sqlD 'for sqlCode' caCo
do dx=1 to m.sqldp.sqlD
call out ' dynamic result set' dx m.sqldp.dx.sqlName ,
'locator='m.sqldp.dx.sqlLocator
end
do dx=1 to m.sqldp.sqlD
drs = 'dynamic result set' dx'='m.sqldp.dx.sqlName 'of' pn
call out '--- begin of' drs
rdr = sqlDRS(m.sqldp.dx.sqlLocator)
if pos('o', opt) > 0 then
call pipeWriteAll rdr
else
call fTabAuto sqlStmtFmt, rdr
call out '---' m.rdr.rowCount 'rows fetched from' drs
end
end
return 'sqlCode' caCo
endProcedure sqlStmtCall
sqlStmtCallDa: procedure expose m.
parse arg da, loc, wh
cr = if(loc=='',,loc'.')'sysIbm'
sql = "select 'SCHEMA=''' || strip(schema) || ''''",
"|| ' and name=''' || strip(name ) || ''''",
"|| ' and specificName=''' || strip(specificName) || ''''",
"|| ' and routineType =''' || strip(routineType ) || ''''",
"|| ' and VERSION =''' || strip(VERSION ) || ''''",
"from" cr".SysRoutines ",
"where" wh "and active = 'Y'"
if sqlpreAllCl(49, sql, rou, ':m.rou') <> 1 then
call err m.rou.0 'routines found for' wh
rdr = jOpen(sqlRdr('select * from' cr'.sysParms where' m.rou,
'order by ordinal'), '<')
do ix=1 while jRead(rdr)
a = m.rdr
if m.a.ordinal <> ix then
call err 'ix' ix 'mismatch ordinal' m.a.ordinal
ty = m.a.dataTypeId
m.da.ix.sqlType = ty
m.da.ix.sqlLen = m.a.length
m.da.ix.sqlLen.sqlPrecision = m.a.length
m.da.ix.sqlLen.sqlScale = m.a.scale
if wordPos(ty, 384 385) > 0 then /* date */
m.da.ix.sqlLen = 10
else if wordPos(ty, 388 389) > 0 then /* time */
m.da.ix.sqlLen = 8
else if wordPos(ty, 392 393) > 0 then /* timestamp */
m.da.ix.sqlLen = 26
m.da.ix.sqlData = ''
m.da.ix.parmName= m.a.parmName
m.da.ix.io = translate(m.a.rowType, 'iob', 'POB')
m.da.ix.sqlInd = 1
end
m.da.sqlD = ix - 1
return da
endProcedure sqlStmtCallDa
/*--- prepare and open cursor
generate type and fetchList ------------------------------------*/
sqlRdr: procedure expose m.
parse arg src, type
return oNew('SqlRdr', scanSqlIn2Stmt(src), type)
endProcedure sqlRdr
sqlRdrOpen: procedure expose m.
parse arg m, opt
if opt\== m.j.cRead then
call err 'opt not' m.j.cRead 'sqlRdrOpen('m',' opt')'
cx = sqlGetCursor()
m.m.cursor = cx
if words(m.m.type) <> 1 | abbrev(m.m.type, ' ') then do
m.sql.cx.fetchClass = ''
call sqlQuery m.m.cursor, m.m.src, m.m.type
m.m.type = sqlFetchClass(cx)
end
else do
m.m.type = class4name(m.m.type)
call sqlQuery m.m.cursor, m.m.src, mCat(classFlds(m.m.type),' ')
m.sql.cx.fetchClass = m.m.type
end
call sqlRdrO2 m
return
endProcedure sqlRdrOpen
sqlQuery2Rdr: procedure expose m.
parse arg cx
r = jReset(oMutate('SQL_RDR.'cx, 'SqlResRdr'), cx)
m.r.type = sqlFetchClass(cx)
return r
endProcedure sqlQuery2Rdr
sqlFetchClass: procedure expose m.
parse arg cx, force
if m.sql.cx.fetchClass == '' | force == 1 then
m.sql.cx.fetchClass = classNew('n* Sql u f%v' ,
m.sql.cx.fetchFlds)
return m.sql.cx.fetchClass
endProcedure sqlFetchClass
sqlRdrO2: procedure expose m.
parse arg m
cx = m.m.cursor
if m.m.type \== m.sql.cx.fetchClass | m.m.Type == '' then
call err 'type' m.m.type '\==' m.sql.cx.fetchClass 'fetchClass'
m.m.rowCount = 0
m.sql_lastRdr = m
return
endProcedure sqlRdrO2
/*--- close sql Cursor -----------------------------------------------*/
sqlRdrClose: procedure expose m.
parse arg m, v
call sqlClose m.m.cursor
call sqlFreeCursor m.m.cursor
m.m.cursor = ''
return m
endProcedure sqlRdrClose
/*--- read next from cursor, return as object ------------------------*/
sqlRdrRead: procedure expose m.
parse arg m
v = oNew(m.m.type)
if \ sqlFetch(m.m.cursor, v) then do
call mFree v
return 0
end
m.m.rowCount = m.m.rowCount + 1
m.m = v
return 1
endProcedure sqlRdrRead
/*--- return sqlFTab for this (open) rdr -----------------------------*/
sqlRdrFtabReset: procedure expose m.
parse arg m, q, maxChar, blobMax, maxDec
if m == '' then
m = m.sql_lastRdr
if \ dataType(m.m.cursor, 'n') then
call err 'sqlRdrFTabReset('m') but cursor empty'
return sqlFTabReset(q, m.m.cursor, maxChar, blobMax, maxDec)
endProcedure sqlRdrFTabReset
/*--- output sql as table --------------------------------------------*/
sql2tab: procedure expose m.
parse arg tBef, tAft, maxChar, blobMax, maxDec
cx = sqlGetCursor()
call sqlQuery cx, in2str(,' ')
t = sqlFTabReset('SQL.'cx'.fTab', cx,
, tBef, tAft, maxChar, blobMax, maxDec)
call sqlFTab sqlFTabOthers(t)
call sqlClose cx
call sqlFreeCursor cx
return
endProcedure sql2tab
/*--- select and write all to stdOut ---------------------------------*/
sqlSel: procedure expose m.
parse arg src, type
s = sqlRdr(src, type)
call pipeWriteAll s
return m.s.rowCount
endProcedure sqlSel
/*--- result of each sql read from rdr to out
oo='a' autoTab, 't'=sqlTab, 'o'=object, 'c'=csv ----------*/
sqlsOut: procedure expose m.
parse arg rdr, retOk, oo
m.sql_errRet = 0
if oo == '' then
oo = 'a'
cx = sqlGetCursor()
r = jOpen(in2file(rdr), '<')
do while jRead(r)
sqlC = sqlExecute(cx, m.r, retOk)
if m.sql_errRet then
leave
if m.sql.cx.resultSet == '' then do
call outNl(m.sql_HaHi ,
|| sqlMsgLine(sqlC, m.sql.cx.updateCount, m.r))
end
else if oo == 'o' then do
call pipeWriteAll sqlQuery2Rdr(cx)
end
else if oo == 'a' | oo == 't' then do
sqR = sqlQuery2Rdr(cx)
ft = sqlfTabOpts(fTabReset('sqls2AutoFT', 'c 1'), cx)
if oo == 't' then do
call sqlFTabOthers(ft)
end
else do
bf = in2Buf(sqR)
if m.sql_errRet then
leave
call sqlFTabDetect ft, bf'.BUF'
call fTab ft, bf
call out sqlMsgLine(m.sqR.rowCount 'rows fetched',
, , m.r)
end
end
else
call err 'bad outputOption' oo
end
call jClose r
if m.sql_errRet then do
/* call out 'sqlsOut terminating because of sql error' */
call sqlClose cx, '*'
say 'sqlsOut terminating because of sql error'
end
call sqlFreeCursor cx
return \ m.sql_errRet
endProcedure sqlsOut
/*-- execute and put result to m -------------------------------------*/
sqlExecuteRes: procedure expose m.
parse arg m, cx, m.m.sql, retOk ?????
m.m.sqlCode = sqlExecute(cx, m.m.sql, retOk) + deimplement
m.m.sqlMsg = m.sql_HaHi || sqlMsgLine(m.m.sqlCode,
, m.sql.cx.updateCount, m.m.sql)
endProcedure sqlExecuteRes
/*--- execute stmts with options -------------------------------------*/
sqlExecuteRdrReset: procedure expose m.
parse arg rdr, wOpt, m.m.retOk
if abbrev(wOpt, '-sql') then + deimplement ??????????????????
wOpt = substr(wOpt, 5)
call scanSqlReset m'.SCAN', rdr, wOpt, ';'
return m
endProcedure sqlExecuteRdrReset
sqlExecuteRdrOpen: procedure expose m.
parse arg m
call scanOpt m'.SCAN' + deimplement ??????????????????
m.m.cursor = sqlGetCursor()
return m
endProcedure sqlExecuteRdrOpen
sqlExecuteRdrClose: procedure expose m.
parse arg m
call scanOpt m'.SCAN' + deimplement ??????????????????
call sqlFreeCursor m.m.cursor
drop m.m.cursor
return m
endProcedure sqlExecuteRdrClose
sqlExecuteRdrRead: procedure expose m.
parse arg m, var
src = scanSqlStmt(m'.SCAN') + deimplement ??????????????????
if src == '' then
return 0
call sqlExecuteRes m, m.m.cursor, src, m.m.retOk
m.var = m.m.cursor
return 1
endProcedure sqlExecuteRdrRead
/* copy sqlO end **************************************************/
/* copy sqlCsm begin **************************************************/
/*--- send an sql to csm and handle sqlCode --------------------------*/
sqlCsmExe:
parse arg ggSqlStmt, ggRetOk
sql_HOST = m.sql_csmhost
SQL_DB2SSID = m.sql_dbSys
sql_query = ggSqlStmt
address tso "CSMAPPC START PGM(CSMASQL)"
if \ (rc = 0 | rc = 4) then
return err('csmappc rc' rc)
if sqlCode = 0 then
return 0
else if pos('*', ggRetOk) > 0 | wordPos(sqlCode, ggRetOk) > 0 ,
then do
if sqlCode < 0 & pos('say', ggRetOk) > 0 then
call errSay ' }'sqlmsg(sqlCA2Rx(sqlCa))
return sqlCode
end
else if sqlCode < 0 then
call err sqlmsg(sqlCA2rx(sqlCa))
else if pos('w', ggRetOk) < 1 then
if sqlCode = 100 then
call errSay ' }sqlCode +100 row not found\nsql =' ggSqlStmt
else
call errSay 'w}'sqlMsg(sqlCA2rx(sqlCa))
return sqlCode
endProcedure sqlCsmExe
/*--- execute a query from sql, with one resultset -------------------*/
sqlCsmQuery: procedure expose m.
parse arg cx, sqlSrc, feVa, retOk, dst
res = sqlCsmExe(sqlSrc, 100 retOk)
if res < 0 then
return res
if dst == '' then
dst = 'SQL.'cx'.CSMDATA'
m.dst.0 = 0
m.dst.laIx = 0
st = 'SQL.'cx'.COL'
if abbrev(feVa, '?') | abbrev(feVa, ':') then do
return err('implement sqlCmsQuery fetchVars ? or :' feVa)
end
else if feVa <> '' then do
vv = feVa
end
else do
vv = ''
do kx=1 to sqlD
vv = sqlNiceVarsAdd(vv, SQLDA_REXXNAME.kx)
end
end
m.sql.cx.fetchFlds = vv
if sqlD <> words(vv) then
return err('sqlCsmQuery sqlD' sqlD '<>' words(vv) 'for' vv)
do kx=1 to sqlD
rxNa = SQLDA_REXXNAME.kx
cn = word(vv, kx)
do rx=1 to sqlRow#
if substr(sqlIndicator.rx, kx ,1) == 'ff'x then
m.dst.rx.cn = m.sqlNull
else
m.dst.rx.cn = value(rxNa'.'rx)
end
end
m.dst.0 = sqlRow#
m.sql_lastRdr = 'cms' cx
return 0
endProcedure sqlCsmQuery
sqlCsmFetch: procedure expose m.
parse arg cx, dst
src = 'SQL.'cx'.CSMDATA'
rx = m.src.laIx + 1
if rx > m.src.0 then
return 0
m.src.laIx = rx
ff = m.sql.cx.fetchFlds
do kx = 1 to words(ff)
c = word(ff, kx)
m.dst.c = m.src.rx.c
end
return 1
endProcedure sqlCsmFetch
/* copy sqlCsm end **************************************************/
/* copy sqlRx begin ***************************************************
Achtung: inc generiert sql aus sqlRx, Aenderungen nur in sqlRx|
sql interface
***********************************************************************/
/*--- initialize sqlRx -----------------------------------------------*/
sqlRxIni: procedure expose m.
if m.sqlRx_ini == 1 then
return
m.sqlRx_ini = 1
call utIni
m.sqlNull = '---'
m.sqlInd = 'sqlInd'
m.sql_defCurs= 49
m.sqlCAMsg = 0
m.sqlSuMsg = 2
m.sql_dbSys = ''
m.sql_csmhost = ''
isInProd = wordPos(sysvar(sysNode), 'RZ2') > 0
m.sql_retOk = 'dne' copies('rod', \ isInProd)
return 0
endProcedure sqlRxIni
/*--- get default db2System ------------------------------------------*/
sqlDefaultSys: procedure expose m.
parse arg
if sysvar(sysnode) == 'RZ4' then
return 'DP4G'
else if sysvar(sysnode) == 'RZX' then
return 'DX0G'
else
call err 'no default dbSys for' sysvar(sysnode)
endProcedure sqlDefaultSys
/*--- connect to the db2 subsystem sys -----------------------------*/
sqlRxConnect: procedure expose m.
parse upper arg sys, ggRetOk
call sqlIni
address tso "SUBCOM DSNREXX"
if rc <> 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
if sys = '-' then
return 0
if sys == '' then
sys = sqlDefaultSys()
m.sql_dbSys = sys
return sqlExec0('connect' sys)
endProcedure sqlRxConnect
/*--- diconnect from db2 ---------------------------------------------*/
sqlRxDisconnect: procedure expose m.
parse arg retOk
if m.sql_dbSys == '' then
return 0
m.sql_dbSys = ''
m.sql_csmHost = ''
return sqlExec0('disConnect')
endProcedure sqlRxDisconnect
/*--- reset sql cursor 'c'cx fields ----------------------------------*/
sqlReset: procedure expose m.
parse arg cx
m.sql.cx.updateCount = ''
m.sql.cx.resultSet = ''
m.sql.cx.d.sqlD = 'noSqlDA'
m.sql.cx.i.sqlD = 'noDescInp'
m.sql.cx.fetchVars = ''
m.sql.cx.fetchFlds = ''
m.sql.cx.fetchClass = ''
m.sql.cx.type = ''
return
endProcedue sqlReset
/*--- execute a query from sql, with one resultset -------------------*/
sqlRxQuery: procedure expose m.
parse arg cx, src, feVa, retOk
call sqlReset cx
s1 = ''
if pos(left(feVa, 1), '?:') < 1 then
s1 = 'into :M.SQL.'cx'.D'
res = sqlExec('prepare s'cx s1 'from :src', retOk)
if res < 0 then
return res
call sqlRxFetchVars cx, feVa
call sqlExec 'declare c'cx 'cursor for s'cx
res = sqlExec('open c'cx, retOk)
if res < 0 then
return res
m.sql.cx.updateCount = sqlErrd.3
m.sql.cx.resultSet = cx
return res
endProcedure sqlRxQuery
/*--- prepare a query from sql, with one resultset -------------------*/
sqlQueryPrepare: procedure expose m.
parse arg cx, src, feVa, retOk
call sqlReset cx
s1 = ''
if feVa == '' | feVa = 'd' then
s1 = 'into :M.SQL.'cx'.D'
res = sqlExec('prepare s'cx s1 'from :src', retOk)
if res < 0 then
return res
call sqlRxFetchVars cx, feVa
call sqlExec 'declare c'cx 'cursor for s'cx
return sqlExec('describe input s'cx 'into :M.SQL.'cx'.I')
endProcedure sqlQueryPrepare
sqlQueryExecute: procedure expose m.
parse arg cx retOk
do ix=1 to arg()-1
call sqlDASet cx , 'I', ix, arg(ix+1)
end
res = sqlExec('open c'cx 'using descriptor :M.SQL.'cx'.I', retOk)
if res < 0 then
return res
m.sql.cx.updateCount = sqlErrd.3
m.sql.cx.resultSet = cx
return res
endProcedure sqlQueryExecute
/*--- fetch next row to m.dst.* at end return false ------------------*/
sqlRxFetch: procedure expose m.
parse arg cx, dst, retOk
fetCode = sqlExec('fetch c'cx 'into' m.sql.cx.fetchVars, 100 retOk)
if fetCode == 100 then
return 0
if fetCode < 0 then
return fetCode
interpret m.sql.cx.fetchCode
return 1
endProcedure sqlRxFetch
/*--- close cursor 'c'cx ---------------------------------------------*/
sqlRxClose: procedure expose m.
parse arg cx, retOk
return sqlExec('close c'cx, retOk)
endProcedure sqlRxClose
/*-- execute an sql with no resultset, but possibly outParms ---------*/
sqlRxUpdate: procedure expose m.
parse arg cx, src, retOk
m.sql.cx.updateCount = ''
m.sql.cx.resultSet = ''
bx = verify(src, '( ')
if bx > 0 then
fun = translate(word(substr(src, bx), 1))
if fun = 'SET' then do
w2 = translate(word(substr(src, bx), 2))
if \ abbrev(w2, ':') then
return sqlExec('execute immediate :src', retOk)
trace ?r
ex = pos('=', w2)
if ex = 0 then
ex = length(w2)+1
var = strip(substr(w2, 2, ex-2))
if var = '' then
call err 'bad hostVar in' src
m.sql.outVar = var
src2 = 'set :M.sql.out.'var substr(w, ex) subword(src, 3)
return sqlExec(src2, retOk)
end
if fun == 'DECLARE' then do
if 'GLOBAL' == translate(word(substr(src, bx), 2)) then
return sqlExec('execute immediate :src', retOk)
end
res = sqlExec(src, retOk)
if wordPos(fun, 'DELETE INSERT UPDATE') > 0 then
m.sql.cx.updateCount = sqlErrd.3
return res
endProcedure sqlRxUpdate
/*-- prepare an update -----------------------------------------------*/
sqlUpdatePrepare: procedure expose m.
parse arg cx, src, retOk
res = sqlExec('prepare s'cx 'from :src', retOk)
return sqlExec('describe input s'cx 'into :M.SQL.'cx'.I')
endProcedure sqlUpdatePrepare
/*-- execute a prepared update with the given arguments --------------*/
sqlUpdateExecute: procedure expose m.
parse arg cx retOk
do ix=1 to arg()-1
call sqlDASet cx , 'I', ix, arg(ix+1)
end
res = sqlExec('execute s'cx 'using descriptor :M.SQL.'cx'.I',
, retOk)
m.sql.cx.updateCount = sqlErrd.3
return res
endProcedure sqlUpdateExecute
/*-- execute a query, update or call ---------------------------------*/
sqlExecute: procedure expose m.
parse arg cx, src, retOk
f = translate(word(src, 1))
bx = pos('(', f)
if bx > 0 then
f = left(f, max(1, bx-1))
m.sql.cx.fun = f
if f == 'SELECT' | f == 'WITH' | f == '(' then
return sqlQuery(cx, src, , retOk)
else if f == 'CALL' then
call err 'implement sql call for:' src
else
return sqlUpdate(cx, src, retOk)
endProcedure sqlExecute
/*-- fetch all rows to stem and close --------------------------------*/
sqlFetch2St: procedure expose m.
parse arg cx, dst, retOK
do sx=1 while sqlFetch(cx, dst'.'sx)
end
res = sx-1
m.dst.0 = sx-1
call sqlClose cx
return m.dst.0
endProcedure sqlFetch2St
/*-- execute a query, copy result to stem ----------------------------*/
sql2St: procedure expose m.
parse arg src, dst, feVa, retOK
cx = m.sql_defCurs
res = sqlQuery(cx, src, feVa, retOk)
return sqlFetch2St(cx, dst, retOk)
endProcedure sql2St
/*-- return first column of the only row and close -------------------*/
sqlFetch2One: procedure expose m.
parse arg cx, dst, retNone
f1 = sqlFetch(cx, dst)
if f1 then
f2 = sqlFetch(cx, dst'.2')
call sqlClose cx
if \ f1 then
if retNone \== '' then
return substr(retNone, 2)
else
call err 'sqlFetch2One: no row returned'
else if f2 then
call err 'sqlFetch2One: more than 1 row'
if m.sql.cx.fetchFlds == '' then do
c1 = substr(word(m.sql.cx.fetchVars, 1), 2)
res = value(c1)
return res
end
c1 = word(m.sql.cx.fetchFlds, 1)
return m.dst.c1
endProcedure sqlFetch2One
/*-- execute a query and return first column of the only row
if > 1 row fail, if 0 rows return arg(3) or fail ----------*/
sql2One: procedure expose m.
parse arg src, dst, feVa, retOk, retNone
cx = m.sql_defCurs
call sqlQuery cx, src, feVa, retOk
return sqlFetch2One(cx, dst, retNone)
endProcedure sql2One
/*--- describe table and return sqlDA --------------------------------*/
sqlDescribeTable: procedure expose m.
parse upper arg tb, force
if force == 1 | \ datatype(m.sql.table.tb.sqlD, 'n') then
call sqlExec 'describe table :tb into :M.SQL.TABLE.'tb
return 'SQL.TABLE.'tb
endProcedure sqlDescribeTable
/*--- return select column list for table tb
omit Blobs (blobMax < 0) or substr(blob, 1, blobMax) ----------*/
sqlColList: procedure expose m.
parse arg tb al, blobMax
sd = sqlDescribeTable(tb)
bs = ''
lst = ''
if al \== '' & right(al, 1) \== '.' then
al = al'.'
do sx=1 to m.sd.sqld
if wordPos(m.sd.sx.sqlType, '404 405 408 409 412 413') < 1 then
lst = lst',' al || m.sd.sx.sqlName
else do
bs = bs m.sd.sx.sqlName
if blobMax >= 0 then
lst = lst', length('al || m.sd.sx.sqlName')' ,
m.sd.sx.sqlName'Len' ,
|| ', substr('al || m.sd.sx.sqlName ,
|| ', 1,' blobMax')' m.sd.sx.sqlName
end
end
m.sd.colList = substr(lst, 3)
m.sd.blobs = strip(bs)
return substr(lst, 3)
endProcedure sqlColList
/*--- use describe output to generate column names,
'' use names from ca (rexxified)
nms+ use names, check ca for null values
?('?'?nm)+ use names, check for null if preceeded by ?
:... use string as is
fetchVariables and sqlNull names ---------------------*/
sqlRxFetchVars: procedure expose m.
parse arg cx, src, cd
st = 'SQL.'cx'.COL'
if abbrev(src, ':') then do
m.sql.cx.fetchVars = src
m.sql.cx.fetchCode = cd
m.sql.cx.fetchFlds = ''
return
end
m.sql.cx.fetchVars = ''
if abbrev(src, '?') then do
call err implement + rxFetchVars ?????? /*
r = substr(src, 2)
do wx=1 to words(src)
cn = word(src, wx)
if abbrev(cn, '?') then
call sqlRexxAddVar substr(cn, 2), 0, 1
else
call sqlRexxAddVar cn, 0, 0
end ????????????? */
end
else if src <> '' then do
ff = src
end
else do
ff = ''
do kx=1 to m.sql.cx.d.sqlD
ff = sqlNiceVarsAdd(ff, m.sql.cx.d.kx.sqlName)
end
end
m.sql.cx.fetchFlds = ff
if m.sql.cx.d.sqlD <> words(ff) then
call err 'sqlRxFetchVars sqlD='m.sql.cx.d.sqlD ,
'<>' words(ff) 'fields of' ff
sNu = ''
sFe = ''
do kx=1 to m.sql.cx.d.sqlD
nm = word(ff, kx)
sFe = sFe', :m.dst.'nm
if m.sql.cx.d.kx.sqlType // 2 then do
sFe = sFe' :m.dst.'nm'.sqlInd'
sNu = sNu 'if m.dst.'nm'.sqlInd < 0 then' ,
'm.dst.'nm '= m.sqlNull;'
end
end
m.sql.cx.fetchVars = substr(sFe, 3)
m.sql.cx.fetchCode = sNu cd
return
endProcedure sqlRxFetchVars
/* ????????????
sqlRexxAddVar:
parse arg nm, nicify, hasNulls
nm = sqlAddVar(st, nm, nicify)
if \ hasNulls then
vrs = vrs', :m.dst.'nm
else do
vrs = vrs', :m.dst.'nm ':m.dst.'nm'.sqlInd'
sNu = sNu 'if m.dst.'nm'.sqlInd < 0 then' ,
'm.dst.'nm '= m.sqlNull;'
end
return
endSubroutine sqlRexxAddVar ?????? */
sqlNiceVarsAdd: procedure expose m.
parse arg old, nx rest
upper nx
cx = verifId(nx)
if cx > 0 then /* avoid bad characters for classNew| */
nx = left(nx, cx-1)
if nx <> '' & wordPos(nx, old) < 1 0 then
return old nx
else
return old 'COL' || (words(old) + 1)
endProcedure sqlNiceVarsAdd
/*--- set one value in a DA, handle nulls ----------------------------*/
sqlDASet: procedure expose m.
parse arg cx, da, ix, val
m.sql.cx.da.ix.sqlData = val
m.sql.cx.da.ix.sqlInd = - (val == m.sqlNull)
/* data types schienen einmal nicht zu funktionieren .......
if wordPos(m.da.ix.sqlType, '384 385 388 389 392 393') > 0 then
m.da.ix.sqlType = 448 + (m.da.ix.sqlType // 2) */
return
endProcedure sqlDASet
sqlCommit: procedure expose m.
parse arg src
return sqlUpdate(, 'commit')
endProcedure sqlCommit
/*--- execute sql thru the dsnRexx interface ------------------------*/
sqlExec: /* no procedure, to keep variables sql... */
parse arg ggSqlStmt, ggSqlRet0
m.sql_HaHi = ''
do forever
address dsnRexx 'EXECSQL' ggSqlStmt
if rc == 0 & sqlCode == 0 & sqlWarn.0 == ' ' then
return 0
if \ dataType(sqlCode, 'n') | abs(rc) \== 1 then
return err('dsnRexx rc='rc sqlMsg())
/* if pos('-', retOK) < 1 then ?????? */
ggSqlRet = ggSqlRet0 m.sql_retOk
if pos('*', ggSqlRet) >0 | wordPos(sqlCode, ggSqlRet) >0 then do
if sqlCode < 0 & pos('say', ggSqlRet) > 0 then
call outNl errMsg(' }'sqlMsg())
return sqlCode
end
if sqlCode >= 0 then do
if (sqlCode > 0 | sqlWarn.0 \== ' ') ,
& pos('w', ggSqlRet) < 1 then
call outNl errMsg(' }'sqlMsg())
return sqlCode
end
if translate(word(ggSqlStmt, 1)) == 'DROP' then do
if (sqlCode == -204 | sqlCode == -458) ,
& wordPos('dne', ggSqlRet) > 0 then
return sqlCode
if sqlCode = -672 & wordPos('rod', ggSqlRet) > 0 ,
& length(m.sql_hahi) < 1000 then do
m.sql_hahi = m.sql_HaHi || sqlMsgLine(sqlCode,
, 'tb='sqlErrMc ,ggSqlStmt)'\n'
m.sql_hahi = m.sql_HaHi || sqlExecHaHi('alter table' ,
SqlErrMc 'drop restrict on drop')'\n'
iterate
end
end
ggSqlEE = ''
if wordPos('rb', ggSqlRet) > 0 then
ggSqlEE = '\n'sqlExecHaHi('rollback')
if wordPos('ret', ggSqlRet) < 1 then do
call err m.sql_hahi || sqlMsg() || ggSqlEE
return sqlCode
end
m.sql_errRet = 1
call outNl errMsg(' }'m.sql_haHi || sqlMsg() || ggSqlEE)
return sqlCode
end
endProcedure sqlExec
/*--- execute sql thru the dsnRexx interface fail if sqlcode <> 0 ---*/
sqlExec0: procedure expose m.
parse arg ggSqlStmt, ePlus
address dsnRexx ggSqlStmt
if rc == 0 & sqlCode == 0 & sqlWarn.0 == ' ' then
return 0
if \ dataType(sqlCode, 'n') | abs(rc) \== 1 then
ePlus = strip(ePlus 'dsnRexx rc='rc'\n')
return err(ePlus || sqlMsg())
endProcedure sqlExec0
/*--- execute sql fail or return msgLine ----------------------------*/
sqlExecHaHi: procedure expose m.
parse arg ggSqlStmt
return sqlMsgLine(sqlExec0('execSql' ggSqlStmt, m.sql_hahi) ,
, , ggSqlStmt)
endProcedure sqlExechaHi
sqlMsgLine: procedure expose m. sqlErrD.
parse arg res, cnt, src, plus
verb = translate(word(src, 1))
if datatype(res, 'n') then
res = 'sqlCode' res
if cnt \== '' then do
res = res',' cnt
vx = wordPos(translate(word(src,1)), 'DELETE INSERT UPDATE')
if datatype(cnt, 'n') then
if vx > 0 then
res = res 'rows' word('deleted inserted updated', vx)
else if cnt <> 0 then
res = res 'rows updated'
end
if plus \== '' then
res = res',' plus
if abbrev(res, ', ') then
res = substr(res, 3)
if src \== '' then do
ll = 75 - length(res)
aa = strip(src)
if length(aa) > ll then
aa = space(aa, 1)
if length(aa) > ll then
aa = left(aa, ll-3)'...'
res = res':' aa
end
return res
endProcedure sqlMsgLine
/*--- send a command to db2 through the TSO dsn processor ------------*/
sqlDsn: procedure expose m.
parse arg st, sys, cmd, rcOk
x = outtrap('M.'st'.')
push 'END'
push cmd
address tso 'DSN SYSTEM('sys')'
rr = rc
x = outtrap(off)
if rr = 0 | rcOk = '*' | wordPos(rr, rcOk) > 0 then
return rr
fl = max(1, m.st.0 - 10)
em = 'rc' rr 'for DSN SYSTEM('sys') cmd' cmd,
'\nOuputlines' fl '-' m.st.0':'
do lx=fl to m.st.0
em = em '\n' strip(m.st.lx, 't')
end
call err em
endProcedure sqlDsn
/*--- issue an sql error message -------------------------------------*/
sqlMsg: /* no procedure, to keep variables sql... */
if \ dataType(sqlCode, 'n') then do
ggRes = 'sqlCode' sqlCode 'not numeric\n'sqlCaMsg()
end
else do
ggRes = sqlDsntiar(sqlRx2CA())
ggWa = sqlMsgWarn()
if ggWa \= '' then
ggRes = ggRes'\nwarnings' ggWa
if m.sqlCAMsg == 1 then
ggRes = ggRes'\n'sqlCaMsg()
end
ggSt = 'SQL_HOST'
ggVa = 'SQL_HOST.VAR'
ggBe = 'SQL_HOST.BEF'
call sqlHostVars ggSqlStmt, 12, ggSt
ggFrom = 'ggSqlStmt'
ggW1 = translate(word(ggSqlStmt, 1))
ggW2 = translate(word(ggSqlStmt, 2))
if ggW1 == 'PREPARE' then
ggFrom = sqlHostVarFind(ggSt, 'FROM')
else if ggW1 ggW2 == 'EXECUTE IMMEDIATE' then
ggFrom = sqlHostVarFind(ggSt, 1)
ggPos = 0
if datatype(sqlErrd.5, 'n') & sqlErrd.5 > 0 then do
ggPos = sqlErrd.5
ggRes = ggRes || sqlMsgSrcPos(value(ggFrom), sqlErrd.5)
end
if ggFrom == 'ggSqlStmt' then do
ggRes = ggRes'\nsql =' sqlShorten(ggSqlStmt, 2000, ggPos)
end
else do
ggRes = ggRes'\nsql =' sqlShorten(value(ggFrom), 2000, ggPos)
ggRes = ggRes'\nstmt =' sqlShorten(ggSqlStmt, 2000)
end
ggPref = '\nwith'
do ggXX=1 to m.ggSt.0
if ggFrom = m.ggVa.ggXX then
iterate
ggRes = ggRes || ggPref m.ggBe.ggXX ':'m.ggVa.ggXX ,
'=' sqlShorten(value(m.ggVa.ggXX), 210)
ggPref = '\n '
end
if m.sqlSuMsg == 1 | (m.sqlSuMsg == 2 & m.sql_csmhost \== '') then
ggRes = ggRes'\nsubsys =' m.sql_dbSys ,
|| ', host =' m.sql_csmhost
return ggRes
endSubroutine sqlMsg
sqlShorten: procedure expose m.
parse arg txt, maxL, pos
if length(txt) <= maxL then
return txt
if \ datatype(pos, 'n') | pos < 1 then
pos = 1
ex = pos + min(60, maxL%7)
if ex <= maxL - 4 then
return left(txt, maxL-4) '...'
if ex >= length(txt) then
return left(txt, 67) '...\n'substr(txt, length(txt)-maxL+72)
else
return left(txt, 67) '...\n'substr(txt, ex-maxL+76, maxL-75) ,
'...'
endProcedure sqlShorten
/*--- use dsnTiar to translate sql Info to error text ----------------*/
sqlDsnTiar: procedure expose m.
parse arg ca
if -438 = sqlCa2Rx(ca) then
return '\nSQLCODE = -438:',
'APPLICATION RAISED ERROR WITH sqlState' sqlState ,
'and DIAGNOSTIC TEXT:' sqlErrMc
liLe = 78
msLe = liLe * 10
msg = d2c(msLe,2) || left('', msLe)
len = d2c(liLe, 4)
ADDRESS LINKPGM "DSNTIAR ca msg len"
if rc = 0 then nop
else if rc = 4 then say 'warn linkPgm dsnTiar rc' rc 'sqlCa' ca
else call err 'linkPgm dsnTiar rc' rc 'sqlCa' ca
res = strip(substr(msg, 13, liLe-10))
cx = pos(', ERROR: ', res)
if cx > 0 then
res = left(res, cx-1)':' strip(substr(res, cx+9))
do c=3+liLe by liLe to msLe while substr(msg, c, 10) = ''
res = res'\n 'strip(substr(msg, c+10, liLe-10))
end
return res
endProcedure sqlDsnTiar
/*--- format all rexx sqlCa fields into a message --------------------*/
sqlCaMsg:
return 'sqlCode' sqlCode 'sqlState='sqlState ,
'\n errMC='translate(sqlErrMc, ',', 'ff'x) ,
'\n warnings='sqlWarnCat('+') 'erP='sqlErrP ,
'\n errD.1='sqlErrD.1 '2='sqlErrD.2 '3='sqlErrD.3 ,
'\n errD.4='sqlErrD.4 '5='sqlErrD.5 '6='sqlErrD.6
endProcedure sqlCaMsg
/*--- concat the sql warnings with Separator sep --------------------*/
sqlWarnCat: procedure expose m. sqlWarn.
parse arg sep
return sqlWarn.0 || sep,
|| sqlWarn.1||sqlWarn.2||sqlWarn.3||sqlWarn.4||sqlWarn.5||sep ,
|| sqlWarn.6||sqlWarn.7||sqlWarn.8||sqlWarn.9||sqlWarn.10||sep
endProcedure sqlWarnCat
/*--- format the sqlCA into the dsnTiar SQLCA ------------------------*/
sqlRx2Ca: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
if \ (datatype(sqlcode, 'n') & datatype(sqlErrD.1, 'n') ,
& datatype(sqlErrD.3, 'n')) then
return err('sqlCode etc. not numeric\nsqlCa =' sqlCaMsg())
if digits() < 10 then
numeric digits 10
sqlCa = 'SQLCA ' || d2c(136, 4) || d2c(sqlCode, 4) ,
|| d2c(min(70, length(sqlErrMc)), 2)left(sqlErrMc, 70) ,
|| left(sqlErrP, 8) ,
|| d2c(sqlErrD.1, 4)d2c(sqlErrD.2, 4)d2c(sqlErrD.3, 4) ,
|| d2c(sqlErrD.4, 4)d2c(sqlErrD.5, 4)d2c(sqlErrD.6, 4) ,
|| sqlWarnCat() || sqlState
if length(sqlCa) <> 136 then
call err 'sqlCa length' length(sqlCa) 'not 136' ,
'\n'sqlCaMsg() '==>' ca', hex='c2x(ca)
return sqlCa
endProcedure sqlRx2Ca
/*--- extract the fields from the SqlCA and put it to rexx vars ------*/
sqlCA2Rx: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
parse arg ca
numeric digits 10
if length(ca) < 136 | c2d(substr(ca, 9, 4), 4) <> 136 then
call err 'bad sqlCa len' length(ca) 'not 136:' ca', hex='c2x(ca)
sqlCode = c2d(substr(ca, 13 ,4), 4)
sqlErrMC = substr(ca, 19, c2d(substr(ca, 17, 2), 2))
sqlErrP = substr(ca, 89, 8)
do ix=1 to 6
sqlErrD.ix = c2d(substr(ca, 93 + 4 * ix, 4), 4)
end
do ix=0 to 10
sqlWarn.ix = substr(ca, 121 + ix, 1)
end
sqlState = substr(ca, 132, 5)
return sqlCode
endProcedure sqlCA2Rx
/*--- make the text for sqlWarnings ----------------------------------*/
sqlMsgWarn: procedure expose m. sqlWarn.
r = ''
text =' 1=W var truncated, 1=S scrollable, 1=N nonScrollable,' ,
'2=W nulls in aggregate,' ,
'3=W more cols than vars,' ,
'3=Z more result sets than locators,' ,
'4=W no where, 4=D sensitive dynamic, 4=I insensitive,' ,
'4=S sensitive static,' ,
'5=W not valid sql, 5=1 readOnly, 5=2 readDelete,' ,
'5=3 readDeleteUpdate,' ,
'6=W day changed to month range,' ,
'7=W dec digits truncated,' ,
'8=W char substituted,' ,
'9=W arith excep in count, 9=Z multipe result sets,' ,
'10=W char conversion err in ca,'
do wx = 1 to 10
w = sqlWarn.wx
if w = ' ' then
iterate
t = wx'='w
cx = pos(' 'wx'='w' ', text)
ex = pos(',' , text, cx + 1)
if cx > 0 & ex > cx then
r = r substr(text, cx+1, ex-cx)
else
r = r wx'='w '?,'
end
r = strip(r, 't', ',')
if r = '' & sqlwarn.0 <> '' then
call err 'sqlWarn.0='sqlWarn.0 'but all warns empty'
return r
endProcedure sqlMsgWarn
/*--- show in the source src the point pos (where error occured)
a few lines from src around pos and arrow to pos ----------*/
sqlMsgSrcPos: procedure expose m.
parse arg src, pos
liLe = 68
liCn = 3
afLe = 25
t1 = space(left(src, pos), 1)
t2 = left(' ', substr(src, pos, 1) == ' ' ,
| substr(src, pos+1, 1) == ' ') ,
|| space(substr(src, pos+1), 1)
afLe = min(afLe, length(t2))
if length(t1) + afLe > liLe * liCn then
t1 = '...'right(t1, liLe * liCn - afLe -3)
else if length(t1)+length(t2) > liLe then
t1 = left(' ', (liCn * liLe - length(t1) -afLe) // liLe)||t1
pL = length(t1) // liLe
if length(t2) <= liLe-pL then
tx = t1 || t2
else
tx = t1 || left(t2, liLe-pL-3)'...'
res = '\nsrc' strip(substr(tx, 1, liLe), 't')
do cx=1+liLe by liLe to length(tx)
res = res || '\n +' strip(substr(tx, cx, liLe), 't')
end
loc = 'pos' pos 'of' length(src)
if length(loc)+6 < pL then
return res'\n >' right('>>>'loc'>>>', pL)
else
return res'\n >' left('', pL-1)'<<<'loc'<<<'
endProcdedure sqlMsgSrcPos
/*--- get the hostVars in the sql in src and the word before ---------*/
sqlHostVars: procedure expose m.
parse arg src, cnt, st
cx = 1
sx = 1
do cnt
cx = pos(':', src, cx) + 1
if cx < 2 then
leave
if pos(substr(src, cx, 1), m.ut_rxN1) > 0 then
iterate
ex = verify(src, m.ut_rxDot, 'n', cx)
if ex < 1 then
m.st.var.sx = substr(src, cx)
else
m.st.var.sx = substr(src, cx, ex - cx)
if m.st.var.sx == '' | length(m.st.var.sx) > 100 then
iterate
/* search word before */
do bE = cx-2 by -1 to 1 ,
while substr(src, bE, 1) == ' '
end
do bB = bE by -1 to max(1, bE-20),
while pos(substr(src, bB, 1), m.ut_alfa) > 0
end
if bB < bE & bB >= 0 then
m.st.bef.sx = substr(src, bB+1, bE-bB)
else
m.st.bef.sx = ''
sx = sx + 1
end
m.st.0 = sx-1
return sx
endProcedure sqlHostVars
/*--- find the name of hostvar, by index or by before ----------------*/
sqlHostVarFind: procedure expose m.
parse arg st, fnd
if datatype(fnd, 'n') & fnd <= m.st.0 then
return m.st.var.fnd
do ix=1 to m.st.0
if translate(m.st.bef.ix) = fnd then
return m.st.var.ix
end
return ''
endSubroutine sqlHostVarFind
/* copy sqlRx end **************************************************/
/* copy dsnList begin **************************************************
csi interface: see dfs managing catalogs chapt. 11
returncode/reason see message IDC3009I
**********************************************************************/
/*--- specify dsn mask and fields to start a csi catalog search --------
arguments:
m objectPointer
dsnMask specifies the dsns with wildcards:
% 1 character
* 0 - n character in one level
** 0 - n levels
fields a (space separated) list of field names -------------*/
csiOpen: procedure expose m.
parse arg m, dsnMask, fields
m.m.fld.0 = words(fields)
ffix = d2c(m.m.fld.0, 2)
do x=1 to m.m.fld.0
m.m.fld.x = translate(word(fields, x))
ffix = ffix || left(m.m.fld.x, 8)
end
if dsnMask \== '' & right(dsnMask, 1) \== ' ' ,
& pos('*', dsnMask) < 1 & length(dsnMask) < 42 then
dsnMask = dsnMask'.**'
m.m.filt = left(dsnMask, 149) ,
|| left('Y', 3) , /* resume offset 149 */
|| ffix /* csiNumEn offset 152 */
WORKLEN = 1024 * 64
m.m.work = D2C(WORKLEN,4) || COPIES('00'X,WORKLEN-4)
m.m.pos = workLen + 1
return
endProcedure csiOpen
/*--- put the next dsn into m.o and m.o.* (for other fields)
return 1 if next dsn exists 0 otherwise ------------------------*/
csiNext: procedure expose m.
parse arg m, o
usedL = C2D(SUBSTR(m.m.work,9,4)) /* GET AMOUNT OF WORK AREA USED */
px = m.m.pos
do forever
if px > usedL then do
if substr(m.m.filt, 150, 1) \== 'Y' then do
m.m.pos = px
m.o = ''
return 0
end
reason = left('', 4)
ADDRESS LINKPGM 'IGGCSI00 reason m.'m'.filt m.'m'.work'
if rc == 0 & substr(reason, 3, 2) == '0000'x then
nop
else if rc == 4 & substr(reason, 3, 2) == '0464'x then
say 'data set entry with error'
else
call err 'call csi returns' rc,
'rc' c2d(substr(reason, 4,1)),
'reason' c2d(substr(reason, 3,1)),
'module' substr(reason, 1,2)
usedL = C2D(SUBSTR(m.m.work,9,4)) /* GET WORK AREA USED */
numFD = C2D(SUBSTR(m.m.work,13,2)) /* no flds + 1 */
if numFd <> m.m.fld.0 + 1 then
call err 'csiNumFd' numFd 'not' m.m.fld.0 '+' 1
px = 15
iterate
end
eType = substr(m.m.work, px+1, 1)
m.o = strip(substr(m.m.work, px+2, 44), 't')
flag = substr(m.m.work, px, 1)
/* say 'eType' eType m.o 'flag' c2x(flag) */
if eType == '0' then do
if flag \== '00'x & flag \== '40'x then
call err 'flag' c2x(flag) 'for catalog' m.o
px = px + 50 /* length of catalog entry */
iterate
end
else do
if \ abbrev(x2b(c2x(flag)), '101') then
call err 'call csi entry flag' x2b(c2x(flag)),
'rc' c2d(substr(m.m.work, px+49,1)),
'reason' c2d(substr(m.m.work, px+48,1)),
'module' substr(m.m.work, px+46, 2),
'for entry' m.o,
'see qw IDC3009I'
py = px + 46
tl = c2d(substr(m.m.work, py, 2))
pl = py + 4
pf = py + m.m.fld.0 * 2 + 4
do fx = 1 to m.m.fld.0
fi = m.m.fld.fx
fl = c2d(substr(m.m.work, pl, 2))
m.o.fi = substr(m.m.work, pf, fl)
if fi = 'MGMTCLAS' then
m.o.fi = substr(m.o.fi, 3, c2d(left(m.o.fi ,2)))
else if wordPos(fi, 'COMUDSIZ NOBYTTRK') > 0 then
m.o.fi = utc2d(m.o.fi)
pf = pf + fl
pl = pl + 2
end
if py + tl <> pf then
call err 'length mismatch for entry' m.o
m.m.pos = pf
return 1
end
end
endProcedure csiNext
/*--- if dsn is arcived return 'arcive'
if dsn is tape return 'tape'
otherwise return managment class ------------------------------*/
csiArcTape: procedure expose m.
parse arg vo, cl, dt, dsn
if vo = '' then
say err '||| no volume for dsn' dsn
else if vo = 'ARCIVE' then
res = 'arcive'
else if cl <> '' then
res = cl
else if abbrev(vo, 'SHR') then
res = 'SHR'
else
res = 'tape'
if res = 'arcive' then
return res
/*if abbrev(res, 'ar') \= abbrev(dt, '00'x) , */
if abbrev(res, 'ta') \= abbrev(c2x(left(dt, 1)), '7') ,
| (left(res, 1) >= 'A') \= abbrev(dt, '30'x) then
say '||| mismatch cl' cl 'vo' vo 'dt' c2x(dt) 'dsn' dsn
return res
endProcedure csiArcTape
/*--- 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
/*--- dsnList: csi or csm to stem -----------------------------------*/
dsnList: procedure expose m.
parse arg oo, aMsk, rzPref
parse value dsnCsmSys(aMsk) with rz '/' msk
if msk \== '' & right(msk, 1) \== ' ' ,
& pos('*', msk) < 1 & length(msk) < 42 then
msk = msk'.**'
if rz == '*' then do
call csiOpen dsnList_csi, msk
do ox=1 while csiNext(dsnList_csi, oo'.'ox)
end
end
else do
pre = copies(rz'/', rzPref \== 0)
call adrCsm 'dslist system('rz') dsnMask('msk') short', 4
do ox=1 to stemSize
m.oo.ox = pre || dsName.ox
end
end
m.oo.0 = ox-1
return m.oo.0
endProcedure dsnList
/*--- mbrList with listDS or csm to stem ----------------------------*/
mbrList: procedure expose m.
parse arg m, pds
msk = strip(dsnGetMbr(pds))
if msk == '*' then
msk = ''
parse value dsnCsmSys(dsnSetMbr(pds)) with sys '/' dsn
if sys == '*' then do
call adrTso listDS "'"dsn"'" members
oy = m.tso_trap.0 + 99
mFound = 0
mx = 0
do ox=1 to m.tso_trap.0
if mFound then do
if msk \== '' then
if \ match(strip(m.tso_trap.ox), msk) then
iterate
mx = mx + 1
m.m.mx = strip(m.tso_trap.ox)
end
else
mFound = m.tso_trap.ox == '--MEMBERS--'
end
m.m.0 = mx
end
else do
if msk <> '' then
msk = 'member('translate(msk, '%', '?')')'
mbr_name.0 = -99
call adrCsm "mbrList system("sys") dataset('"dsn"')" msk,
"index(' ') short"
do mx=1 to mbr_name.0
m.m.mx = strip(mbr_name.mx)
end
m.m.0 = mbr_name.0
end
return mx
endProcedure mbrList
/*--- return wheter a dsn exists ------------------------------------*/
dsnExists: procedure expose m.
parse upper arg aDsn
parse value dsnCsmSys(aDsn) with rz '/' dsn
if rz == '*' then
return sysDsn("'"dsn"'") == 'OK'
else if dsnGetMbr(dsn) == '' then do
lc = adrCsm('dslist system('rz') dsnMask('dsn') short', 4)
if stemsize = 0 | stemSize = 1 then
return stemSize
call err 'csmExists stemSize='stemsize 'for dsn='aDsn
end
else do
cc = adrCsm("mbrList system("rz") dataset('"dsnSetMbr(dsn)"')",
"member("dsnGetMbr(dsn)") index(' ') short", 8)
if cc <> 0 then do
if pos(' NOT IN CATALOG\', m.tso_trap) > 0 ,
& pos('CSMSV29E DATA SET ', m.tso_trap) > 0 then
return 0
return err('error in csm mbrList' aDsn m.tso_trap)
end
if mbr_name.0 == 0 | mbr_name.0 == 1 then
return mbr_name.0
call err 'csmExists mbr_mem#='mbr_name.0 'for dsn='aDsn
end
endProcedure dsnExists
/*--- copy members / datasets
fr, to from or to dsn with or without member
mbrs: space separated list of mbr or old>new
----------------------------------------------------------------------*/
dsnCopy: procedure expose m.
parse arg fr, to, mbrs
if mbrs \== '' then do
if dsnGetMbr(fr) \== '' | dsnGetMbr(to) \== '' then
call err 'fr='fr 'to='to 'but with mbrs='mbrs
/* if words(mbrs) == 1 then do ???? not necessary done in cmsCopy
parse value strip(mbrs) with old '>' new
if old = '' then
call err 'bad mbr old/new' mbrs
fr = dsnSetMbr(fr, old)
to = dsnSetMbr(to, word(new old, 1))
mbrs = ''
end
*/ end
/* currently we do everything with csm
if the need arises, implement tso only version */
return csmCopy(fr, to, mbrs)
endProcedure dsnCopy
dsnDel: procedure expose m.
parse arg aDsn, aMbrs
parse value dsnCsmSys(aDsn) with sys '/' dsn
mbrs = dsnGetMbr(dsn) aMbrs
dsn = dsnSetMbr(dsn)
if sys \== '*' then
return csmDel(sys, dsn, mbrs)
if mbrs = '' then do
dRc = adrTso("delete '"dsn"'", 8)
end
else do mx=1 to words(mbrs)
m1 = word(mbrs, mx)
dRc = adrTso("delete '"dsn"("m1")'", 8)
if dRc <> 0 then do
if pos('IDC3330I **' m1' ', m.tso_trap) < 1 then
leave
say 'member not found and not deleted:' dsn'('m1')'
dRc = 0
end
end
if dRc = 0 then
return 0
if pos('IDC3012I ENTRY' dsn 'NOT FO', m.tso_trap) >= 1 then do
say 'dsn not found and not deleted:' dsn
return 4
end
call err 'adrTso rc='m.tso_rc 'stmt='m.tso_stmt m.tso_trap
return 8
endProcedure dsnDel
/* copy dsnList end ************************************************/
/* copy csm begin ******************************************************
interface to csm,
it is integrate with adrTso, eg. dsnAlloc , 'RZ3/..' uses csm
***********************************************************************/
/*--- execute a single csmExec command ------------------------------*/
adrCsm:
if wordPos(translate(word(arg(1), 1)), 'COPY MBRLIST') > 0 then
ggTO = ''
else if symbol('m.csm_timeOut') == 'VAR' then
ggTO = 'timeout('m.csm_timeOut')'
else
ggTO = 'timeout(30)'
ggStart = time()
if adrTso('csmExec' arg(1) ggTO, '*') == 0 then
return 0
if pos('CSMXC43E NO CONNECTION TO S', m.tso_trap) > 0 ,
| pos('CSMXC36E TIMEOUT LIMIT EXCEEDED DURING LOGON TO' ,
, m.tso_trap) > 0 then
/* CSMXC43E NO CONNECTION TO SYSPLEX:RR2 AVAILABLE
CSMXC36E TIMEOUT LIMIT EXCEEDED DURING LOGON TO SYS */
m.csm_err = 'noConn'
else if pos('IKJ56225I', m.tso_trap) > 0 ,
& ( pos('ALREADY IN USE', m.tso_trap) > 0 ,
| pos('CATED TO ANOTH', m.tso_trap) > 0) then
/* 5 IKJ56225I DATA SET A540769.TMP.TEXT ALREADY IN USE,
6 IKJ56225I DATA SET IS ALLOCATED TO ANOTHER JOB */
m.csm_err = 'inUse'
else
m.csm_err = ''
if pos('*', arg(2)) <= 0 & wordPos(m.tso_rc, arg(2)) <= 0 then
call err strip('csmExec' m.csm_err) 'rc='m.tso_rc ,
'\nstmt='subWord(m.tso_stmt, 2) m.tso_trap ,
'\nend of csmExec, time='ggStart '-' time()
return m.tso_rc
endProcedure adrCsm
csmDel: procedure expose m.
parse upper arg rz, dsn, aMbrs
mbrs = dsnGetMbr(dsn) aMbrs
lib = dsnSetMbr(dsn)
if mbrs = '' then do
dRc = adrCsm("allocate system("rz") dataset('"lib"')" ,
"disp(del) ddname(csmDel)", 8)
end
else do
dRc = adrCsm("allocate system("rz") dataset('"lib"')" ,
"disp(shr) ddname(csmDel)", 8)
if dRc == 0 then do
do mx=1 to words(mbrs)
m1 = word(mbrs, mx)
dRc = adrCsm("mDelete ddName(csmDel) member("m1")", 8)
if dRc <> 0 then do
if pos('CSMEX77E Member:'m1 'not f', m.tso_trap) ,
< 1 then
leave
say 'member not found, not deleted:' rz'/'dsn'('m1')'
dRc = 0
end
end
end
end
if dRc = 0 then do
call adrTso 'free dd(csmDel)'
return 0
end
if pos('CSMSV29E DATA SET' lib 'NOT IN CAT', m.tso_trap) >0 then do
say 'dsn not found and not deleted:' rz'/'dsn
call adrTso 'free dd(csmDel)', '*'
return 4
end
eMsg = 'rc='m.tso_rc 'stmt='m.tso_stmt':' m.tso_trap
call adrTso 'free dd(csmDel)', '*'
return err('csmDel' eMsg)
endProcedure csmDel
/*--- copy members / datasets
Vorlage: csrxUtil ----------------------------------------------*/
csmCopy: procedure expose m.
parse upper arg fr, to, mbrs
frDD = tsoDD('csmFr*', 'a')
frMbr = dsnGetMbr(fr) \== ''
toMbr = dsnGetMbr(to) \== ''
call csmAlloc fr, frDD, 'shr'
toDD = tsoDD('csmTo*', 'a')
toMbr = dsnGetMbr(aTo)
/*??if toMbr\== '=' then
to = aTo
else
to = dsnSteMbr(aTo, frMbr) ???????? */
call csmAlloc to, toDD, 'shr', , ':D'frDD
/* if frMbr \== '' & toMbr == '' & m.tso_dsOrg.toDD == 'PO' then do
call adrTso 'free dd('toDD')'
to = dsnSetMbr(aTo, frMbr)
call csmAlloc to toDD 'shr'
end ?????????????? */
inDD = tsoDD('csmIn*', 'a')
i.0 = 0
if mbrs \== '' then do
i.0 = words(mbrs)
do mx=1 to i.0
parse value word(mbrs, mx) with mF '>' mT
if mF = '' then
call err 'bad mbr or mbrOld>mbrNew' word(mbrs, mx),
'in csmCopy('fr',' to','mbrs')'
else if mT = '' then
i.mx = ' S M='mF
else
i.mx = ' S M=(('mF','mT'))'
end
end
else if \ frMbr & m.tso_dsOrg.frDD == 'PO' then do
call adrCsm "mbrList ddName("frDD") index(' ') short"
i.0 = mbr_mem#
do ix=1 to i.0
i.ix = ' S M='mbr_name.ix
end
end
if i.0 <= 0 then do
call adrTso 'alloc dd('inDD') dummy'
end
else do
call tsoAlloc ,inDD, 'NEW', , ':F'
call writeDD inDD, 'I.', i.0
call tsoCLose inDD
end
outDD = word(dsnAlloc('dd(csmO*) new ::V137'), 1)
cmdu = 'CSMUTIL CSM,COPYREPLACE,DD(,,,,'inDD','outDD ,
|| ',,'frDD','toDD'),MARC(0)'
cRc = adrTso(cmdU, '*')
if cRc <> 0 then do
call readDD outDD, o.
call tsoClose outDD
say 'rc='cRc',' o.0 'outputlines for' cmdU
do ox=1 to o.0
say o.ox
end
end
call tsoFree frDD toDD inDD outDD
if cRc <> 0 then
call err 'csmCopy rc='cRc
return cRc
endProcedure csmCopy
csmAlloc: procedure expose m.
parse arg sysDsn, dd, disp, rest, nn, retRc
upper dd disp
parse value dsnCsmSys(sysDsn) with sys '/' dsn
m.tso_dsn.dd = sys'/'dsn
if disp = '' then
disp = 'shr'
else if words(disp) = 2 then
disp = word(disp, 2)
a1 = "SYSTEM("sys") DDNAME("dd")"
if dsn == 'INTRDR' then do
a1 = a1 'sysout(T) writer(intRdr)'
end
else do
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")"
end
nAtts = wordPos(disp, 'NEW MOD CAT') > 0 & nn \== ''
if nAtts then
rest = dsnCreateAtts('-'dsn , nn) rest
cx = pos(' UCOUNT(', ' 'translate(rest))
if cx > 0 then do
rest = left(rest, cx) || 'nitCnt(' || substr(rest, cx+7)
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)
end
cx = pos(' CYLINDERS ', ' 'translate(rest)' ')
if cx > 0 then do
rest = delStr(rest, cx+8, 1)
end
cx = pos(' CYL ', ' 'translate(rest)' ')
if cx > 0 then do
rest = insert('inder', rest, cx+2)
end
if retRc <> '' | nAtts | nn == '' then do
alRc = adrCsm('allocate' a1 rest, retRc)
m.tso_dsorg.dd = subsys_dsOrg
return alRc
end
alRc = adrCsm('allocate' a1 rest, '*')
m.tso_dsorg.dd = subsys_dsOrg
if alRc = 0 then
return 0
say 'csmAlloc rc' alRc 'for' a1 rest '...trying to create'
call csmAlloc sysDsn, dd, 'CAT', rest ,nn
call adrTso 'free dd('dd')'
return adrCsm('allocate' a1 rest)
endProcedure csmAlloc
csmLikeAtts: procedure expose m.
parse upper arg rz '/' dsn
lc = adrCsm('dslist system('rz') dsnMask('dsnSetMbr(dsn)')')
if stemsize <> 1 then
call err 'csmLikeAtts stemSize='stemsize 'for dsn='dsn
if abbrev(dsOrg.1, 'PO') then
r = 'dsorg(po) dsnType(library)'
else if abbrev(dsOrg.1, 'PS-') then
r = 'dsorg(PS)'
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 */
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' /* split tso cmd in linews */
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
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
/* alloc necessary dd */
call dsnAlloc rz"/"proc "dd(rmSyPro) rmtDDn(sysProc)"
call dsnAlloc rz"/tmp.tsin new dd(rmTsIn) rmtDdn(sysTsIn) ::f "
call tsoOpen rmTsIn, 'w' /* write tso cmd */
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)"
/* now, run tso remote */
call adrtso "csmappc start pgm(csmexec)" ,
"parm('select tsocmd(''csmappc allocate plu(*.rmtSys)" ,
"tpname(sysikj) dealloc '')')", "*"
if rc <> 0 | appc_rc <> 0 then do /* handle csm error */
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 /* copy output to stem */
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 timing begin *************************************************/
timing: procedure expose m.
parse arg typ, c2, txt
e1 = time('E')
c1 = strip(sysvar('syscpu'))
s1 = sysvar('syssrv')
if typ == '' then
return strip(f('%c ela=%5i cpu=%8.3i su=%9i' ,
, time(), e1, c1, s1) txt)
if symbol('m.timing_ela') \== 'VAR' then
call err 'timing('typ',' c2',' txt') ohne ini'
if symbol('m.timing.typ.ela') \== 'VAR' then do
m.timing.typ.ela = 0
m.timing.typ.cpu = 0
m.timing.typ.su = 0
m.timing.typ.cnt = 0
m.timing.typ.cn2 = 0
if symbol('m.timing_types') == 'VAR' then
m.timing_types = m.timing_types typ
else
m.timing_types = typ
if symbol('m.timing_say') \== 'VAR' then
m.timing_say = 0
end
m.timing.typ.ela = m.timing.typ.ela + e1 - m.timing_ela
m.timing.typ.cpu = m.timing.typ.cpu + c1 - m.timing_cpu
m.timing.typ.su = m.timing.typ.su + s1 - m.timing_su
m.timing.typ.cnt = m.timing.typ.cnt + 1
if c2 \== '' then
m.timing.typ.cn2 = m.timing.typ.cn2 + c2
m.timing_ela = e1
m.timing_cpu = c1
m.timing_su = s1
if m.timing_say then
say left(typ, 10)right(m.timing.typ.cn2, 10) ,
'ela='m.timing.typ.ela ,
'cpu='m.timing.typ.cpu 'su='m.timing.typ.su txt
return
endProcedure timing
timingSummary: procedure expose m.
say 'timing summary' time()
do tx = 1 to words(m.timing_types)
typ = word(m.timing_types, tx)
say left(typ, 10)right(m.timing.typ.cnt, 7) ,
|| right(m.timing.typ.cn2, 7) ,
'cpu='right(m.timing.typ.cpu, 10) ,
'su='right(m.timing.typ.su, 10)
end
return
endProcedure timingSummary
/* copy timing end *************************************************/
/* copy ii begin ********* Installation Info *************************/
iiini: procedure expose m.
if m.ii_ini == 1 then
return
m.ii_ini = 1
m.ii_ds.org = ORG.U0009.B0106.KLEM43
m.ii_ds.db2 = DSN.DB2
m.ii_rz = ''
i = 'RZ0 0 T S0 RZ1 1 A S1' ,
'RZX X X X2 RZY Y Y Y2 RZZ Z Z Z2' ,
'RQ2 Q Q Q2 RR2 R R R2 RZ2 2 B S2 RZ4 4 D S4'
do while i <> ''
parse var i rz ch pl sys i
if rz <> RZ0 & rz <> RZ1 then
m.ii_rz = strip(m.ii_rz rz)
m.ii_rz2c.rz = ch
m.ii_c2rz.ch = rz
m.ii_rz2plex.rz = pl
m.ii_plex2rz.pl = rz
m.ii_rz2Sys.rz = sys
m.ii_sys2rz.sys = rz
end
i = 'DBTF T DTF DVTB V DTB DBOC C DOC DBTC B DBT DBIA A DIA' ,
'DE0G E DE0 DEVG M DEV DPXG I DPX DX0G X DX0' ,
'DPYG Y DPY DPZG N DPZ' ,
'DBOF F DOF DVBP P DBP DP2G Q DP2 DBOL O DOL DP4G U DP4'
do while i <> ''
parse var i db ch mbr i
m.ii_db2c.db = ch
m.ii_c2db.ch = db
m.ii_mbr2db.mbr = db
m.ii_db2mbr.db = mbr
m.ii_db2Elar.db = wordPos(db, 'DVTB DVBP DEVG') > 0
end
m.ii_rz2db.rz0 = 'DBTC DBIA'
m.ii_rz2db.rz1 = 'DBTF DVTB DBOC'
m.ii_rz2db.rzx = 'DE0G DEVG DX0G DPXG'
m.ii_rz2db.rzy = 'DE0G DEVG DPYG'
m.ii_rz2db.rzz = 'DE0G DEVG DPZG'
m.ii_rz2db.rq2 = 'DBOF DVBP DP2G'
m.ii_rz2db.rr2 = 'DBOF DVBP DP2G'
m.ii_rz2db.rz2 = 'DBOF DVBP DP2G'
m.ii_rz2db.rz4 = 'DBOL DP4G'
i = ''
do rx=1 to words(m.ii_rz)
rz = word(m.ii_rz, rx)
i = i repAll(' 'space(m.ii_rz2db.rz, 1), ' ', ' 'rz'/')
end
m.ii_rzDb = space(i, 1)
return
endProcedure iiIni
iiDS: procedure expose m.
parse arg nm
return iiGet(ds, nm)
iiMbr2DbSys: procedure expose m.
parse arg mbr
return iiGet(mbr2db, left(mbr, 3))
iiRz2C: procedure expose m.
parse arg rz
return iiGet(rz2c, rz)
iiRz2P: procedure expose m.
parse arg rz
return iiGet(rz2plex, rz)
iiRz2Dsn: procedure expose m.
parse arg rz
return overlay('Z', rz, 2)
iiDBSys2C: procedure expose m.
parse arg db
return iiGet(db2c, db)
iiSys2RZ: procedure expose m.
parse arg sys
return iiGet(sys2rz, left(sys, 2))
iiGet: procedure expose m.
parse upper arg st, key, ret
s2 = 'II_'st
if symbol('m.s2.key') == 'VAR' then
return m.s2.key
if m.ii_ini == 1 then
if abbrev(ret, '^') then
return substr(ret, 2)
else
return err('no key='key 'in II_'st, ret)
call iiIni
return iiGet(st, key, ret)
endProcedure iiGet
iiPut:procedure expose m.
parse upper arg rz '/' db
rz = strip(rz)
db = strip(db)
call vPut 'rz', rz
call vPut 'rzC', iiRz2C(rz)
call vPut 'rzP', iiRz2P(rz)
call vPut 'rzD', iiRz2Dsn(rz)
call vPut 'dbSys', db
if db <> '' then do
call vPut 'dbSysC', iidbSys2C(db)
call vPut 'dbSysElar', iiGet(db2Elar, db)
end
return 1
endProcedure iiPut
iiIxPut:procedure expose m.
parse arg ix
if ix > words(m.ii_rzDb) then
return 0
else
return iiPut(word(m.ii_rzDb, ix))
endProcedure iiIxPut
/* copy ii end ********* Installation Info *************************/
/* copy adrIsp begin *************************************************/
/**********************************************************************
lmd: catalog read
call sequence: lmdBegin, lmdNext*, lmdEnd
mit lmd service (mit save in file und read,
weil list zu langsam und listcat abstürzt)
1. arg (grp) als group dataset für lmd save
und dd name für file read
***********************************************************************/
lmdBegin: procedure expose m.
parse arg grp, lev
call adrIsp 'lmdinit listid(lmdId) level('lev')'
res = adrIsp('lmdlist listid(&lmdId) option(save) group('grp')', 4)
call adrIsp 'lmdfree listid(&lmdId)'
if res = 0 then do
call trc timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') shr dsn('grp'.datasets)'
end
else do
call trc 'no datasets found' timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') dummy'
end
call tsoOpen grp, 'R'
return /* end lmdBegin */
lmdNext:
parse arg ggGrp, ggSt, withVolume
if \ readDD(ggGrp, ggSt) then
return 0
if withVolume \== 1 then
do ggIx=1 to value(ggSt'0')
x = value(ggSt || ggIx, word(value(ggSt || ggIx), 1))
end
return 1
endSubroutin lmdNext
lmdEnd: procedure expose m.
parse arg grp
call tsoClose grp
call adrTso 'free dd('grp')'
return /* end lmdEnd */
lmd: procedure expose m.
parse arg lev, withVol
call lmdBegin gg1, lev
do while lmdNext(gg1, q., withVol)
do x=1 to q.0
call out q.x
end
end
call lmdEnd gg1
return
endProcedure lmd
/**********************************************************************
member list of a pds:
call sequence x=lmmBegin(dsn) lmmNext(x) * lmmEnd(x)
***********************************************************************/
lmm: procedure expose m.
parse arg dsn
id = lmmBegin(dsn)
do ix=1 by 1
m = lmmNext(id)
if m = '' then
leave
call out m
end
call lmmEnd id
return
endProcedure lmm
lmmBegin: procedure expose m.
parse arg dsn
mbr = dsnGetMbr(dsn)
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET('"pds"') ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(INPUT) "
res = lmmId
if mbr <> '' then
res = res 'pattern('mbr')'
return res
endProcedure lmmBegin
lmmEnd: procedure expose m.
parse arg lmmId opt
call adrIsp "LMMLIST DATAID("lmmId") option(free)", 8
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
return
endProcedure lmmEnd
lmmNext: procedure expose m.
parse arg lmmId opt
if adrIsp("LMMLIST DATAID("lmmid")" ,
"OPTION(LIST) MEMBER(Mbr)" opt, 4 8) = 0 then
return strip(mbr)
else
return ''
endProcedure lmmNext
lmmRm: procedure expose m.
parse arg dsn, mbrs
mbrs = dsnGetMbr(dsn) mbrs
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET("pds") ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(OUTPUT) "
err = ''
do wx=1 to words(mbrs)
m1 = word(mbrs, wx)
rr = adrIsp("lmmDel dataid("lmmId") member("m1")", 0 8 12)
if rc = 0 then
say 'removed' m1 'from' pds
else if rc = 8 then
say 'not found' m1 'in' pds
else do
err = 'error deleting' m1 'in' pds 'rc' rr strip(zerrlm)
say err
leave
end
end
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
if err <> '' then
call err err
return
endProcedure lmmRm
/*--- address ispf with error checking -------------------------------*/
adrIsp:
parse arg ggIspCmd, ggRet
address ispexec ggIspCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr ispExec rc' rc 'in' ggIspCmd':' strip(zerrlm)
endSubroutine adrIsp
/*--- address editor with error checking -----------------------------*/
adrEdit:
parse arg ggEditCmd, ggRet
address isrEdit ggEditCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr isrEdit rc' rc 'for' ggEditCmd
endSubroutine adrEdit
/* copy adrIsp end *************************************************/
/* copy adrTso begin *************************************************/
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet ---*/
adrTso:
parse arg m.tso_stmt, ggRet
call outtrap m.tso_trap.
address tso m.tso_stmt
m.tso_rc = rc
call outtrap off
if m.tso_rc == 0 then
return 0
m.tso_trap = ''
do ggXx=1 to min(7, m.tso_trap.0)
m.tso_trap = m.tso_trap'\n'strip(m.tso_trap.ggXx)
end
if m.tso_trap.0 > 7 then do
if m.tso_trap.0 > 14 then
m.tso_trap = m.tso_trap'\n............'
do ggXx=max(8, m.tso_trap.0-6) to m.tso_trap.0
m.tso_trap = m.tso_trap'\n'strip(m.tso_trap.ggXx)
end
end
if ggRet <> '*' & wordPos(m.tso_rc, ggRet) <= 0 then
call err 'adrTso rc='m.tso_rc 'stmt='m.tso_stmt m.tso_trap
return m.tso_rc
endSubroutine 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', "'")
cx = pos('~', dsn)
if cx < 1 then
if addPrefix \== 1 then
return dsn
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
if cx < 1 then
return sp'.'dsn
do until cx == 0
le = left(dsn, cx-1)
if le \== '' & right(le, 1) \== '.' then
le = le'.'
if cx == length(dsn) then
return le || sp
else
dsn = le || sp'.' ,
|| substr(dsn, cx + 1 + (substr(dsn, cx+1, 1) == '.'))
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 lib '(' . , mbr .
bx = pos('(', dsn)
if mbr = '' then
return strip(lib)
else
return strip(lib)'('mbr')'
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn '(' mbr ')'
if mbr = '' then
return arg(2)
else
return strip(mbr)
endProcedure dsnGetMbr
dsnCsmSys: procedure expose m.
parse upper arg dsn, withStar
if pos('/', dsn) < 1 then
return copies('*/', withStar \== 0)dsn
parse var dsn sys '/' d2
if sys = '' | sys = sysvar(sysnode) then
return copies('*/', withStar \== 0)d2
else
return dsn
endProcedure dsnCsmSys
/**********************************************************************
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 dd '(open)')
return /* end tsoOpen */
/*--- close dd -----------------------------------------------------*/
tsoClose: procedure expose m.
parse upper arg dd
return adrTso('execio 0 diskR' 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, ggRet
if ggCnt == '' then
ggCnt = value(ggst'0')
call adrTso 'execio' ggCnt 'diskW' ggDD '(stem' ggSt')', ggRet
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 readNxBegin
/*--- return the stem of the next line, or '' at end -----------------*/
readNx: procedure expose m.
parse arg m
if m.m.cx < m.m.0 then do
m.m.cx = m.m.cx + 1
return m'.'m.m.cx
end
m.m.buf0x = m.m.buf0x + m.m.0
m.m.cx = 1
if \ readDD(m.m.dd, 'M.'m'.', m.m.cnt) then
return ''
return m'.1'
endProcedure readNx
/*--- 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
if m.m.cx > m.m.0 then
return 'line' (m.m.buf0x + m.m.cx)':after EOF'
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 readNxEnd
/*--- 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 arg m, spec
upper spec
m.m.dsn = ''
m.m.dd = ''
m.m.disp = ''
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
m.m.disp = w
else if abbrev('CATALOG', w, 3) | abbrev(DELETE, w, 3) then
m.m.disp = di left(w, 3)
else if abbrev(w, 'DD(') then
m.m.dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
m.m.dsn = dsn2Jcl(substr(w, 5, length(w)-5))
else if m.m.dsn == '' & (w = 'INTRDR' ,
| verify(w, ".~'", 'm') > 0) then
m.m.dsn = dsn2jcl(w)
else if pos('(', w) > 0 then
leave
else if m.m.dd == '' then
m.m.dd = w
else
leave
end
if pos('/', m.m.dsn) < 1 then
m.m.sys = ''
else do
parse var m.m.dsn m.m.sys '/' m.m.dsn
if m.m.sys == '*' | m.m.sys = sysvar(sysnode) then
m.m.sys = ''
end
parse value subword(spec, wx) with at ':' nw
m.m.attr = strip(at)
m.m.new = strip(nw)
return m
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, dDi, dDD, timeOut
x = max(1, arg() - 1)
do rt=0
res = dsnAlloc(spec, dDi, dDD, '*')
if \ datatype(res, 'n') then
return res
if rt > timeOut & timeOut \== '' then
return err('timeout allocating' spec time() '\n'm.tso_trap)
if pos('DATA SET IS ALLOCATED TO ANOTHER', m.tso_trap) < 1 then
return err('allocating' spec'\n'm.tso_trap)
say time() 'sleep and retry alloc' spec
call sleep 1, 0
end
endProcedure dsnAllocWait
/*--- alloc a dsn or a dd
spec dsnSpec
dDi default disposition
dDD 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, dDi, dDD, retRc
return dsnAllo2(dsnSpec(dsn_alloc, spec), dDi, dDD, retRc)
/*--- alloc a dsn or a dd, dsnSpec analysed in m --------------------*/
dsnAllo2: procedure expose m.
parse upper arg m, dDi, dDD, retRc
m.tso_dsn.dd = ''
if m.m.dd \== '' then
dd = m.m.dd
else if dDD \== '' then
dd = dDD
else
dd = 'DD*'
dd = tsoDD(dd, 'a')
if m.m.dsn == '' & m.m.disp == '' & m.m.attr = '' then
return dd
if m.m.disp \== '' then
di = m.m.disp
else if dDi \== '' then
di = dDi
else
di = 'SHR'
if pos('(', m.m.dsn) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if m.m.sys == '' then
rx = tsoAlloc(m.m.dsn, dd, di, m.m.attr, m.m.new, retRc)
else
rx = csmAlloc(m.m.sys'/'m.m.dsn,dd, di, m.m.attr,m.m.new,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, noErr
if symbol('m.tso_ddAll') \== 'VAR' then do
call errIni
m.tso_ddAll = ''
end
if f == '-' then do
ax = wordPos(dd, m.tso_ddAll)
if ax > 0 then
m.tso_ddAll = delWord(m.tso_ddAll, ax, 1)
else if noErr \== 1 then
call err 'tsoDD dd' dd 'not used' m.tso_ddAll
end
else if f <> 'A' then
call err 'tsoDD bad fun' f
else do
if right(dd, 1) = '*' then do
d0 = left(dd, length(dd)-1) || m.err.screen
dd = d0
do dx=1 while wordPos(dd, m.tso_ddAll) > 0
dd = d0 || dx
end
end
else if pos('?', dd) > 0 then
dd = repAll(dd, '?', m.err.screen)
if wordPos(dd, m.tso_ddAll) < 1 then
m.tso_ddAll = strip(m.tso_ddAll dd)
m.tso_dsn.dd = ''
m.tso_dsOrg.dd = ''
end
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_dsn.dd = ''
else if na \== 'INTRDR' then do
c = c "DSN('"na"')"
m.tso_dsn.dd = na
end
else do
c = c "sysout(*) writer(intRdr)"
m.tso_dsn.dd = '*intRdr'
end
if wordPos(disp, 'NEW MOD') > 0 & nn \== '' then
c = c dsnCreateAtts(,nn)
if adrTso(c rest, '*') = 0 then
return 0
if pos('IKJ56246I', m.tso_trap) > 0 then
if pos('TED, FILE IN USE', m.tso_trap) > 0 then do
/* IKJ56246I DATA SET A540769.WK.REXX NOT ALLOCATED, FILE IN USE */
say 'tsoAlloc dd' dd 'already in use:' substr(m.tso_trap, 3)
say '.... trying to free'
call tsoFree dd, 1
say '.... retrying to allocate' c rest
if adrTso(c rest, '*') = 0 then
return 0
end
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& pos('IKJ56228I', m.tso_trap) > 0 ,
& pos(' NOT IN CATALOG ', m.tso_trap) > 0 then do
/* IKJ56228I DATA SET A540769.XY.REXX NOT IN CATALOG OR CATAL*/
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
if pos('*', retRc) < 1 & wordPos(m.tso_rc, retRc) < 1 then
call err 'tsoAlloc rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
call sayNl 'tsoAlloc rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
return m.tso_rc
endProcedure tsoAlloc
dsnLikeAtts: procedure expose m.
parse upper arg dsn, isFile
if isFile then do
ddDsn = m.tso_dsn.dsn
if lastPos('/', m.tso_dsn.dsn, 4) < 1 then
return tsoLikeAtts(dsn, 1)
dsn = m.tso_dsn.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, tryClose
do dx=1 to words(ddList)
dd = word(ddList, dx)
if adrTso('free dd('dd')', '*') <> 0 then do
if pos('IKJ56861I', m.tso_trap) > 0 & tryClose == 1 then
if pos('NOT FREED, DATA SET IS OPEN', m.tso_trap),
> 0 then do
/* IKJ56861I FILE A1 NOT FREED, DATA SET IS OPEN */
say 'dataset open:' substr(m.tso_trap, 3)
say '.... trying to close'
if adrTso('execio 0 diskR' dd '(finis)', '*') = 0 then
call adrTso 'free dd('dd')', '*'
end
if m.tso_rc \== 0 then
call sayNl 'rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
end
call tsoDD dd, '-', 1
end
return
endProcedure tsoFree
dsnCreateAtts: procedure expose m.
parse arg dsn, atts
res = ''
if dsn \== '' & \ abbrev(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 'dsnCreateAtt bad :' a1
end
aU = ' 'translate(atts)
hasOrg = pos(' DSORG(', aU) > 0 | pos(' DSNTYPE(', aU) > 0
hasMbr = pos('(', dsn) > 0
if hasMbr & \ hasOrg then
atts = atts 'dsorg(po) dsntype(library)'
if hasOrg | hasMbr then do
ww = DSORG DSNTYPE
do wx=1 to words(ww)
do forever
cx = pos(' 'word(ww, wx)'(', ' 'translate(res))
if cx == 0 then
leave
cy = pos(')', res, cx)
res = delstr(res, cx, cy+1-cx)
end
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(1, 50) cylinders'
return res
endProcedure dsnCreateAtts
/*--- 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
tsoDsiMaxl:
rc = listDsi(arg(1) 'FILE')
if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
return SYSLRECL - 4 * abbrev(sysRecFm, 'V')
endSubroutine tsoDsiMaxL
/* copy adrTso end ****************************************************/
/* copy csv begin *****************************************************/
csvIni: procedure expose m.
if m.csv.ini == 1 then
return
m.csv.ini = 1
call jIni
call classNew "n CsvRdr u JRWDelegOC, f OPT v", "m",
, "jReset m.m.deleg = in2File(arg); m.m.opt = arg2",
, "jOpen call csvRdrOpen m, opt",
, "jRead return csvRdrRead(m)"
call classNew "n CsvWordRdr u CsvRdr", "m",
, "jOpen call csvWordOpen m, opt",
, "jRead return csvWordRead(m)"
call classNew "n CsvColRdr u CsvRdr", "m",
, "jOpen call csvColOpen m, opt",
, "jRead return csvColRead(m)"
call classNew "n CsvWrt u CsvRdr", "m",
, "jOpen call csvWrtOpen m, opt",
, "jRead return csvWrtRead(m)"
return
endProcedure csvIni
/*--- create a new csvRdr --------------------------------------------*/
csvRdr: procedure expose m.
parse arg rdr, opt
return oNew('CsvRdr', rdr, opt)
/*--- open csvRdr: read first line and create dataClass -------------*/
csvRdrOpen: procedure expose m.
parse arg m, aOp
mr = m.m.deleg
call jOpen mr, aOp
if jRead(mr) then
call csvRdrOpenFinish m, space(translate(m.mr, ' ', ','), 1)
return
endProcedure csvRdrOpen
csvRdrOpenFinish: procedure expose m.
parse arg m, ff
if m.m.opt == 'u' then
upper ff
m.m.class = classNew("n* CsvF u f%v" ff)
call classMet m.m.class, 'new'
call classMet m.m.class, 'oFldD'
return
endProcedure csvRdrOpen
/*--- read next line and return derived object -----------------------*/
csvRdrRead: procedure expose m.
parse arg m
mr = m.m.deleg
do until m.mr <> ''
if \ jRead(mr) then
return 0
end
m.m = csv2O(mNew(m.m.class), m.m.class, m.mr)
return 1
endProcedure csvRdrRead
/*--- read next line and return derived object -----------------------*/
csv2o: procedure expose m.
parse arg m, cl, src
ff = classMet(cl, 'oFldD')
s = csv_2o_SCAN
call scanSrc s, src
do fx=1 to m.ff.0
f1 = m || m.ff.fx
if scanString(s, '"') then
m.f1 = m.s.val
else do
call scanUntil s, ','
m.f1 = m.s.tok
end
if scanEnd(s) then
leave
if \ scanLit(s, ',') then
call scanErr s, ',' expected
end
return csv2Ofinish(m, cl, fx+1)
endProcedure csv2o
csv2Ofinish: procedure expose m.
parse arg m, cl, fy
call classClearStems cl, oMutate(m, cl)
do fx=fy to m.cl.fldd.0
f1 = m || m.cl.fldd.fx
m.f1 = ''
end
return m
endProcedure csv2Ofinish
/*--- create a new csvRdr --------------------------------------------*/
csvWordRdr: procedure expose m.
parse arg rdr, opt
return oNew('CsvWordRdr', rdr, opt)
/*--- open csvRdrWord: read first line and create dataClass --------*/
csvWordOpen: procedure expose m.
parse arg m, aOp
mr = m.m.deleg
call jOpen mr, aOp
if jRead(mr) then
call csvRdrOpenFinish m, space(m.mr, 1)
return
endProcedure csvWordOpen
/*--- read next line and return derived object from words------------*/
csvWordRead: procedure expose m.
parse arg m
mr = m.m.deleg
do until m.mr <> ''
if \ jRead(mr) then
return 0
end
m.m = csvWord2O(mNew(m.m.class), m.m.class, m.mr)
return 1
endProcedure csvRdrRead
csvWord2O: procedure expose m.
parse arg m, cl, src
ff = cl'.FLDD'
s = csv_2o_SCAN
call scanSrc s, src
do fx=1 to m.ff.0
call scanSpaceOnly s
if \ scanWord(s) then
leave
f1 = m || m.ff.fx
m.f1 = m.s.val
end
return csv2Ofinish(m, cl, fx)
endProcedure csvWordRead
/*--- create a new csvColRdr------------------------------------------*/
csvColRdr: procedure expose m.
parse arg rdr, opt
return oNew('CsvColRdr', rdr, opt)
/*--- open csvRdr: read first line and create dataClass -------------*/
csvColOpen: procedure expose m.
parse arg m, aOp
mr = m.m.deleg
call jOpen mr, aOp
if \ jRead(mr) then
return
s = scanSrc(csv_colOpen, m.mr)
ff = ''
do cx=1
call scanWhile s, ' <>'
if scanEnd(s) then
leave
call scanUntil s, ' <>'
ff = ff m.s.tok
call scanSpaceOnly s
m.m.pEnd.cx = m.s.pos + (scanLook(s, 1) == '>')
end
m.m.pEnd.0 = cx-1
call csvRdrOpenFinish m, ff
return
endProcedure csvColOpen
/*--- read next line and return derived object -----------------------*/
csvColRead: procedure expose m.
parse arg m
mr = m.m.deleg
do until m.mr <> ''
if \ jRead(mr) then
return 0
end
m.m = csvCol2O(m, mNew(m.m.class), m.m.class, m.mr)
return 1
endProcedure csvRdrRead
csvCol2O: procedure expose m.
parse arg oo, m, cl, src
ff = cl'.FLDD'
cx = 1
do fx=1 to m.oo.pEnd.0 - 1
f1 = m || m.ff.fx
m.f1 = strip(substr(src, cx, m.oo.pEnd.fx - cx))
cx = m.oo.pEnd.fx
end
f1 = m || m.ff.fx
m.f1 = strip(substr(src, cx))
return csv2Ofinish(m, cl, fx+1)
endProcedure csvCol2O
/*--- create a new csvRdr --------------------------------------------*/
csvWrt: procedure expose m.
parse arg rdr
return oNew('CsvWrt', rdr)
endProcedure csvWrt
/*--- open csvRdr: read first line and create dataClass --------------*/
csvWrtOpen: procedure expose m.
parse arg m, aOp
call jOpen m.m.deleg, aOp
m.m.class = ''
m.m.o1 = ''
return
endProcedure csvWrtOpen
/*--- read next line and return derived object -----------------------*/
csvWrtRead: procedure expose m.
parse arg m
mr = m.m.deleg
if m.m.o1 \== '' then do
i1 = m.m.o1
m.m.o1 = ''
end
else if jRead(mr) then
i1 = m.mr
else
return 0
if m.m.class == '' then do
m.m.class = objClass(i1)
m.m.o1 = i1
t = ''
ff = oFlds(i1)
do fx=1 to m.ff.0
t = t','m.ff.fx
end
m.m = substr(t, 2)
return 1
end
else do
m.m = csv4Obj(i1, oFldD(i1), 0)
return 1
end
endProcedure csvWrtRead
csv4obj: procedure expose m.
parse arg o, ff, hasNull, oNull
res = ''
do fx=1 to m.ff.0
of1 = o || m.ff.fx
v1 = m.of1
if hasNull & v1 = oNull then
res = res','
else if v1 = '' then
res = res',""'
else if pos(',', v1) > 0 | pos('"', v1) > 0 then
res = res','quote(v1, '"')
else
res = res','v1
end
return substr(res, 2)
endProcedure csv4obj
/* csv+ protocoll, first 1 or 2 field contain meta info --------------
+,flds nextLine --> flds || nextLine (continuation possible multi)
+rest,flds nextLine --> \rest,flds || nextLine
c id,flds --> class definition
d id classId,flds --> object definition
o id classId,flds --> object definition and output
r,id output of (possibly several) defined objects
v,text output a string (ignoring , and everything
-------------------------------------------------------------- */
csvExtReset: procedure expose m.
parse arg m, m.m.wr
return m
csvExtWrite: procedure expose m.
parse arg m, o
c = objClass(o)
if c == m.class_N | c == m.class_S then
call jWrite m.m.wr, 'v,'o
else if c == m.class_W then
call jWrite m.m.wr, 'v,'o2String(o)
else if m.m.done.o == 1 then
call jWrite m.m.wr, 'r,'o
else
call jWrite m.m.wr, 'o' csvExtDef(m, o)
return m
endProcedure csvExtWrite
csvExtDef: procedure expose m.
parse arg m, o
if symbol('m.m.done.o') == 'VAR' then
call err o 'already defined'
m.m.done.o = 1
c = objClass(o)
if c == m.class_N | c == m.class_S | c == m.class_W then
call err 'csvExtDef('o') class' className(c)
if m.m.done.c \== 1 then
call jWrite m.m.wr, 'c,'csvExtClass(m, c)
r = c','o
ff = classMet(c, 'oFldD')
do fx=1 to m.ff.0
c1 = m.ff.fx.class
f1 = o || m.ff.fx
v1 = m.f1
if m.c1 == 'r' then do
c2 = objClass(v1)
if c2 == m.class_S then
v1 = s2o(v1)
else if c2 == m.class_N | c2 == m.class_W then
nop
else if m.m.done.v1 \== 1 then
call jWrite m.m.wr, 'd' csvExtDef(m, v1)
end
if pos(',', v1) > 0 | pos('"', v1) > 0 then
r = r','quote(v1, '"')
else
r = r','v1
end
return r
endProcedure csvExtDef
csvExtClass: procedure expose m.
parse arg m, c
if symbol('m.m.done.c') == 'VAR' then
call err c 'already defined'
m.m.done.c = 1
r = c
ff = classMet(c, 'oFldD')
do fx=1 to m.ff.0
fC = m.ff.fx.class
r = r','copies('f' substr(m.ff.fx, 2)' ', m.ff.fx \== '') ,
|| if(m.fC == 'r', 'r', m.fC.name)
end
return r
endProcedure csvExtClass
/* copy csv end *****************************************************/
/* copy j begin *******************************************************
the j framework
jReset
jOpen
jClose
jRead
jWrite
***********************************************************************/
jRead: procedure expose m.
parse arg m
if arg() > 1 then
return err('??? old interface') / 0
if m.m.jReading \== 1 then
return err('jRead('m') but not opened r')
ix = m.m.readIx + 1
if ix > m.m.buf.0 then do
m.m.bufI0 = m.m.bufI0 + m.m.buf.0
m.m.readIx = 0
interpret objMet(m, 'jRead')
ix = 1
if m.m.buf.0 < ix then
return err('jRead but no lines') / 0
end
m.m.readIx = ix
m.m = m.m.buf.ix
return 1
endProcedure jRead
jReadVar: procedure expose m.
parse arg m, var
if arg() > 2 then call err '??? old interface' / 0
if \ jRead(m) then
return 0
m.var = m.m
return 1
endProcedure jReadVar
jReadObRe: procedure expose m.
parse arg m
if arg() > 1 then call err '??? old interface' / 0
if jRead(m) then
return m.m
else
return ''
endProcedure jReadObRe
jReadO: procedure expose m.
parse arg m
if arg() > 1 then call err '??? old interface' /0
return jRead(m)
endProcedure jReadO
jWrite: procedure expose m.
parse arg m, line
if \ m.m.jWriting then
return err('jWrite('m',' line') but not opened w')
ix = m.m.buf.0 + 1
m.m.buf.0 = ix
m.m.buf.ix = line
if ix > m.m.bufMax then
interpret objMet(m, 'jWrite')
return
endProcedure jWrite
jPosBefore: procedure expose m.
parse arg m, lx
interpret objMet(m, 'jPosBefore')
return m
endProcedure jPosBefore
jWriteAll: procedure expose m.
parse arg m, rdr
rdr = o2file(rdr)
met = objMet(m, 'jWriteAll')
if \ m.m.jWriting then
return err('jWriteAll('m',' rdr') but not opened w')
interpret met
return
endProcedure jWriteAll
jWriteNow: procedure expose m.
parse arg m, rdr
rdr = o2file(rdr)
interpret objMet(m, 'jWriteNow')
return
endProcedure jWriteNow
jCat: procedure expose m.
parse arg opt m
if m = '' then do
m = opt
opt = m.j.cWri
end
call jOpen m, opt
do ax=2 to arg()
call jWriteAll m, arg(ax)
end
call jClose m
return m
endProcedure jCat
jWriteNowImpl: procedure expose m.
parse arg m, rdr
call jOpen rdr, m.j.cRead
do while jRead(rdr)
call jWrite m, m.rdr
end
call jClose rdr
return
endProcedure jWriteNow
jWriteNowImplO: procedure expose m.
parse arg m, rdr
call jOpen rdr, m.j.cRead
do while jRead(rdr)
call jWrite m, m.rdr
end
call jClose rdr
return
endProcedure jWriteNow
/*--- reset JRW: fail if open, initialise ---------------------------*/
jReset0: procedure expose m.
parse arg m, arg, arg2
if m.m.jReading == 1 | m.m.jWriting == 1 then
return err('still open jReset('m',' arg2')')
m.m.jReading = 0
m.m.jWriting = 0
m.m.jUsers = 0
m.m.buf.0 = 0
m.m.bufMax = 0
return m
endProcedure jReset0
jReset: procedure expose m.
parse arg m, arg, arg2
interpret objMet(m, 'oResetNoMut')
return m
endProcedure jReset
jOpen: procedure expose m.
parse arg m, opt
met = objMet(m, 'jOpen')
oUsers = m.m.jUsers
if opt = m.j.cRead then do
if m.m.jReading then
nop
else if m.m.jWriting then
return err('already opened for writing jOpen('m',' opt')')
else do
m.m.readIx = 0
m.m.bufI0 = 0
interpret met
m.m.jReading = 1
end
end
else if \ abbrev('>>', opt, 1) then do
return err('bad option' opt 'in jOpen('m',' opt')')
end
else do
if m.m.jWriting then
nop
else if m.m.jReading then
return err('already opened for reading jOpen('m',' opt')')
else do
m.m.bufI0 = 0
interpret met
m.m.jWriting = 1
end
end
m.m.jUsers = oUsers + 1
return m
endProcedure jOpen
jClose: procedure expose m.
parse arg m
met = objMet(m, 'jClose')
oUsers = m.m.jUsers
if oUsers = 1 then do
interpret met
m.m.jReading = 0
m.m.jWriting = 0
end
else if oUsers < 1 then
call err 'jClose' m 'but already closed' / ???????
m.m.jUsers = oUsers - 1
return m
endProcedure jClose
/*--- cat the lines of the file together, with mid between lines,
fail if not all lines are strings -------------------*/
jCatLines: procedure expose m.
parse arg m, fmt
if abbrev(fmt, '-sql') then do
call err '-sql in jCatLines'
end
f2 = fmt'%#?a%c%#? %#?e%# %& %&a'
call jOpen m, m.j.cRead
if \ jRead(m) then do
call jClose m
return f(f2'%##e')
end
res = f(f2'%##a', m.m)
do while jRead(m)
res = res || f(f2, m.m)
end
call jClose m
return res
endProcedure jCatLines
/*--- text for a method, for buffer of size 1 only ------------------*/
jWrite1Met: procedure expose m.
parse arg f1
return "jWrite if m.m.buf.0\==1 then call err 'bad jWrite1Met';" ,
"var = m'.BUF.1'; m.m.buf.0 = 0;" f1
/*--- text for a method, for buffer
jWriteBMet: procedure expose m.
parse arg f1, fe
return "jWrite" ,
copies("do wx=1 to m.m.buf.0;" ,
"var = m'.BUF.'wx;" f1"; end;", f1 <> '') ,
copies("vBu = m'.BUF';" fe";", fe <> ''),
"m.m.bufI0 = m.m.bufI0 + m.m.buf.0; m.m.buf.0 = 0"
------------------*/
jIni: procedure expose m.
if m.j.ini == 1 then
return
m.j.ini = 1
m.j.cRead = '<'
m.j.cWri = '>'
m.j.cApp = '>>'
call classIni
am = "call err 'call of abstract method"
cLa= classNew('n JRWLazy u LazyRun', 'm',
, "oReset" m.class_lazyRetMutate,
"'call jReset0 m;' classMet(cl, 'jReset')")
c1 = classNew('n JRW u ORun, f JREADING v, f JWRITING v', 'm',
, "METHODLAZY" cLa,
, "jReset" ,
, "jRead" am "jRead('m')'" ,
, "jWrite" am "jWrite('m',' line')'" ,
, "jWriteAll call jWriteNowImpl m, rdr",
, "jWriteNow call jWriteNowImpl m, rdr",
, "jOpen" am" jOpen('m',' opt')'" ,
, "jClose" ,
, "oRun call pipeWriteAll m",
, "o2String return jCatLines(m, fmt)",
, "o2File return m")
call classNew 'n JRWDelegOC u JRW', 'm',
, "jReset m.m.deleg = arg;" ,
, "jOpen call jOpen m.m.deleg, opt" ,
, "jClose call jClose m.m.deleg"
call classNew 'n JRWDeleg u JRWDelegOC', 'm',
, "jRead md = m.m.deleg; if \ jRead(md) then return 0;" ,
"m.m = m.md; return 1",
, "jWrite call jWrite m.m.deleg, line" ,
am = "call err 'call errObject"
call classNew 'n JRWErr u JRW', 'm',
, "jWriteAll" er "jWriteAll 'm', rdr'",
, "jWriteNow" er "jWriteNow 'm', 'rdr'",
, "jClose" er "jClose 'm'"
call classNew 'n JSay u JRW', 'm',
, jWrite1Met(" say o2Text(m.var, 157)"),
, "jOpen if \ abbrev(opt, m.j.cWri) then",
"call err 'can only write JSay#jOpen('m',' opt')';"
call classNew 'n JRWEof u JRW', 'm',
, "jRead return 0",
, "jOpen if opt \== '<' then call err 'JRWEof#open('m',' opt')'"
m.j.in = jOpen(oNew('JRWEof'), m.j.cRead)
m.j.out = jOpen(oNew('JSay'), '>')
m.j.errRead = "return err('jRead('m') but not opened r')"
m.j.errWrite = "return err('jWrite('m',' line') but not opened w')"
call classNew "n JBuf u JRW, f BUF s r", "m",
, "jReset call jBufReset m, arg, arg2" ,
, "jOpen call jBufOpen m, opt",
, "jRead return 0",
, "jWrite call err 'buf overflow",
, "jPosBefore m.m.readIx = m.m.readIx+0;m.m.readIx = lx-1"
call classNew "n JText u JRWDelegOC, f MAXL v ", "m",
, "jReset m.m.deleg = arg; m.m.maxl = arg2",
, jWrite1Met("call jWrite m.m.deleg, o2Text(line, m.m.maxl)")
return
endProcedure jIni
/*--- return a JRW from rdr or in ------------------------------------*/
in2File: procedure expose m.
parse arg m
interpret objMet(m, 'in2File')
return err('in2File did not return')
endProcedure in2File
/* jstr is part of out interface --> in2Str */
in2Str: procedure expose m.
parse arg m, fmt
interpret objMet(m, 'in2Str')
return err('in2Str did not return')
endProcedure in2Str
in2Buf: procedure expose m.
parse arg m
interpret objMet(m, 'in2Buf')
return err('in2Buf did not return')
endProcedure in2Buf
in: procedure expose m.
if arg() > 0 then call err '??? old interface'
r = m.j.in
m.in_ret = jRead(r)
m.in = m.r
return m.in_ret
endProcedure in
inVar: procedure expose m.
parse arg var
return jReadVar(m.j.in, var)
endProcedure inVar
inObRe: procedure expose m.
if arg() > 0 then call err '??? old interface'
return jReadObRe(m.j.in)
endProcedure inObRe
inO: procedure expose m.
if arg() > 0 then call err '??? old interface'
return in()
endProcedure inO
out: procedure expose m.
parse arg line
call jWrite m.j.out, line
return 0
endProcedure out
/*--- 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
outX: procedure expose m.
parse arg line
if symbol('m.tst_m') \== 'VAR' then
call jWrite m.j.out, line
else
call tstOut m.tst_m, line
return 0
endProcedure out
outO: procedure expose m.
parse arg arg
call out arg
return
endProcedure outO
/*--- jBuf: buffer read or write (supports datataypes) ---------------*/
jBuf: procedure expose m.
m = oNew(m.class_jBuf) /* calls jBufReset */
do ax=1 to arg()
m.m.buf.ax = arg(ax)
end
m.m.buf.0 = ax-1
return m
endProcedure jBuf
/*--- jText: write text descriptions --------------------------------*/
jText: procedure expose m.
parse arg wr, maxL
return oNew('JText', wr, maxL)
jBufReset: procedure expose m.
parse arg m
call oMutate m, m.class_jBuf
do ax=1 to arg() - 1
m.m.buf.ax = arg(ax+1)
end
m.m.buf.0 = ax-1
m.m.bufMax = 1e30
return m
endProcedure jBufReset
jBufOpen: procedure expose m.
parse arg m, opt
if opt == m.j.cRead then do
m.m.readIx = 0
return m
end
if opt == m.j.cWri then do
m.m.buf.0 = 0
end
else if opt \== m.j.cApp then
call err 'jBufOpen('m',' opt') with bad opt'
return m
endProcedure jBufOpen
jBufWriteStem: procedure expose m.
parse arg m, st
ax = m.m.buf.0
do sx=1 to m.st.0
ax = ax + 1
m.m.buf.ax = m.st.sx
end
m.m.buf.0 = ax
return m
endProcedure jBufWriteStem
jBufCopy:
parse arg rdr
b = jOpen(jBuf(), m.j.cWri)
call jWriteNow b, rdr
return jClose(b)
endProcedure jBufCopy
jSingle: procedure expose m.
parse arg m
call jOpen m, '<'
one = jRead(m)
two = jRead(m)
call jClose m
if \ one then
if arg() < 2 then
call err 'empty file in jSingle('m')'
else
return arg(2)
if two then
call err '2 or more recs in jSingle('m')'
return m.m
endProcedure jSingle
/* copy j end *********************************************************/
/* copy o begin ******************************************************
an object is register for a class in o2c
a class has a list of parents in cParent
a class has a methodTable cMet with lazy initialization
a method generator
otherwise an existing method is simply copied
***********************************************************************/
classInheritsOf: procedure expose m.
parse arg cl, sup
cl = class4name(cl)
sup = class4name(sup)
if m.cl.inheritsOf \== 1 then do
m.cl.inheritsOf = 1
call classInheritsOfAdd cl, cl'.INHERITSOF'
end
return m.cl.inheritsOf.sup == 1
endProcedure classInheritsOf
classInheritsOfAdd: procedure expose m.
parse arg cl, trg, pa
pa = classCycle(cl, pa)
m.trg.cl = 1
call assert "m.cl == 'u'"
do cx=1 to m.cl.0
c1 = m.cl.cx
if m.c1 == 'u' then
call classInheritsOfAdd c1, trg, pa
end
return
endProcedure classInheritsOf
classClear: procedure expose m.
parse arg cl, m
do fx=1 to m.cl.fldd.0
f1 = m || m.cl.fldd.fx
m.f1 = ''
end
return classClearStems(cl, m)
endProcedure classClear
classClearStems: procedure expose m.
parse arg cl, m
do sx=1 to m.cl.stmD.0
s1 = m || m.cl.stmD.sx
m.s1.0 = 0
end
return m
endProcedure classClearStems
classCopy: procedure expose m.
parse arg cl, m, t
do fx=1 to m.cl.fldd.0
ff = m || m.cl.fldd.fx
tf = t || m.cl.fldd.fx
m.tf = m.ff
end
do sx=1 to m.cl.stmD.0
call classCopyStem m.cl.stmD.sx.class,
, m || m.cl.stmD.sx, t || m.cl.stmD.sx
end
return t
endProcedure classCopy
classCopyStem: procedure expose m.
parse arg cl, m, t
m.t.0 = m.m.0
do sx=1 to m.t.0
call classCopy cl, m'.'sx, t'.'sx
end
return 0
endProcedure classCopyStem
/*--- return true if src is a rexxVariable a, m.a.c etc. -------------*/
rxIsVar: procedure expose m.
parse arg src
if pos(left(src, 1), m.ut_rxN1) > 0 then
return 0
else
return verify(src, m.ut_rxId) = 0
endProcedure rxIsVar
/*--- return true if src is a rexxConstant rerpresenting its value ---*/
rxIsConst: procedure expose m.
parse arg src, vars c
if \ rxIsVar(src) then
return 0
srU = translate(src)
if srU \== src then
return 0
srU = '.'srU'.'
if pos('.GG', srU) > 0 then
return 0
if vars == '' then
return 1
upper vars
do vx=1 to words(vars)
if pos('.'word(vars, vx)'.', vars) > 0 then
return 0
end
return 1
endProcedure rxIsConst
/*--- return rexx code m.cc or mGet('cc') ----------------------------*/
rxMGet: procedure expose m.
parse arg v1, cc, vars
if cc == '' then
return 'm.'v1
else if rxIsConst(cc, vars) then
return 'm.'v1'.'cc
else
return 'mGet('v1 || quote('.'cc, "'")')'
endProcedure rxMGet
/*--- print object ---------------------------------------------------*/
objOut: procedure expose m.
parse m, pr, p1
return classOutDone(m.class_O, m, pr, p1)
/*--- recursively output (with outX:) object a with class t ---------*/
classOut: procedure expose m.
parse arg t, a, pr, p1
return classOutDone(if(t=='',m.class_O, t), a, pr, p1)
/*--- ouput object a with class t and stopper done ------------------*/
classOutDone: procedure expose m. done.
parse arg t, a, pr, p1
if p1 == '' then
p1 = pr
if right(p1, 1) \== ' ' then
p1 = p1' '
if done.ini \== 1 then do
done.ini = 1
t = class4Name(t, t)
p1 = p1'@'a' '
end
if done.t.a == 1 then
return outX(p1'done :'className(t) '@'a)
done.t.a = 1
if t = m.class_O then do
if a == '' then
return outX(p1'obj null')
t = objClass(a)
if t = m.class_N | t = m.class_S then
return outX(p1'obj has no class @'m.a)
else
return classOutDone(t, a, pr, p1'isA')
end
if t == m.class_V then
return outX(p1'=' m.a)
if t == m.class_W == 'w' then
return outX(p1'}' substr(a, 2))
if m.t == 'f' then
return classOutDone(m.t.1, a'.'m.t.name, pr, p1'.'m.t.name)
if m.t == 'r' then do
if m.a == '' then
return outX(p1'refTo :'className(m.t.1) '@null@')
else
return classOutDone(m.t.1, m.a, pr,
, p1'refTo @'m.a)
end
if m.t = 'u' then do
t1 = m.t.1
vv = m.t.0 > 0 & m.t.1 == m.class_V
call outX p1 || if(m.t.name == '', 'union', ':'m.t.name),
|| copies(' =' m.a, vv)
do ux=1+vv to m.t.0
call classOutDone m.t.ux, a, pr' '
end
return 0
end
if m.t = 's' then do
call outX p1'stem' m.a.0
do ux=1 to m.a.0
call classOutDone m.t.1, a'.'ux, pr' ', pr' .'ux
end
return 0
end
if m.t = 'c' then do
if m.t.name = m.a then
call classOutDone m.t.1, a, pr, p1'choice' m.a
return 0
end
if m.t = 'm' then
return 0
return err('bad class type' m.t)
endProcedure classOutDone
/*--- mutate and reset an object for a class -----------------------*/
oReset: procedure expose m.
parse arg m, cl, arg, arg2
interpret classMet(class4name(cl), 'oReset')
return m
endProcedure oReset
/*--- create an an object of the class cl and reset it --------------*/
oNew: procedure expose m.
parse arg cl, arg, arg2
interpret classMet(class4name(cl), 'new')
return m
endProcedure oNew
/*--- return the class of object obj --------------------------------*/
objClass: procedure expose m.
parse arg m
if arg() > 1 then
return err('old objClass') / 0
if symbol('m.o.o2c.m') == 'VAR' then
return m.o.o2c.m
else if abbrev(m, m.o_escW) then
return m.class_w
else if m \== '' then
return m.class_S
else
return m.class_N
endProcedure objClass
oKindOf: procedure expose m.
parse arg obj, sup
cl = objClass(obj)
return classInheritsOf(cl, sup)
endProcedure oKindOf
/*--- return the code of method met of object m -----------------------*/
objMet: procedure expose m.
parse arg m, met
if symbol('m.o.o2c.m') == 'VAR' then
cl = m.o.o2c.m
else if abbrev(m, m.o_escW) then
cl = m.class_w
else if m \== '' then
cl = m.class_S
else
cl = m.class_N
if symbol('m.cl.method.met') == 'VAR' then
return m.cl.method.met
else
return classMet(cl, met) /* will do lazy initialisation */
endProcedure objMet
/*--- return the stem of fieldnames of object m ---------------------*/
oFlds: procedure expose m.
parse arg m
return objMet(m, 'oFlds')
endProcedure oFlds
oFldD: procedure expose m.
parse arg m
return objMet(m, 'oFldD')
endProcedure oFlds
oClear: procedure expose m.
parse arg m
interpret objMet(m, 'oClear')
return m
endProcedure oClear
/*--- copy object m of class cl to t --------------------------------*/
oClaCopy: procedure expose m.
parse arg cl, m, t
interpret "drop cl;" classMet(cl, 'oCopy')
endProcedure oClaCopy
/*--- copy object m to t / create a new object if t=='' -------------*/
oCopy: procedure expose m.
parse arg m, t
interpret objMet(m, 'oCopy')
endProcedure oCopy
oCopyGen: procedure expose m.
parse arg cl
if cl == m.class_N | cl == m.class_S | cl == m.class_W then
return 'return m'
call classMet cl, 'new'
do sx=1 to m.cl.stms.0
s1 = m.cl.stms.sx
call classMet m.cl.s2c.s1, 'oCopy'
end
return "if t=='' then t = mNew('"cl"');" ,
"call oMutate t, '"cl"';" ,
"return classCopy('"cl"', m, t)"
endProcedure oCopyGen
/*--- return a new instance of a subclass of Run
with code code in method oRun -------------------------------*/
oRunner: procedure expose m.
parse arg code
return oNew(classNew('n* ORun u ORun, m oRun' code))
endProcedure oRunner
/*--- run method oRun of object m -----------------------------------*/
oRun: procedure expose m.
parse arg m, arg, arg2
interpret objMet(m, 'oRun')
return
endProcedure oRun
/*--- run method oRun of object m No Procedure:
??? optimize: class only run ???
use from caller unprotected---------------------------------*/
oRunNP: procedure expose m.
interpret objMet(arg(1), 'oRun')
return
endProcedure oRunNP
/*--- run method oRun and return output in new JBuf ------------------*/
oRun2File: procedure expose m.
parse arg rn
b = jBuf()
call pipe '+F' , b
call oRun rn
call pipe '-'
return b
endProcedure oRun2File
/*--- cast the object to a file -------------------------------------*/
o2File: procedure expose m.
parse arg m
interpret objMet(m, 'o2File')
call err 'o2file did not return'
endProcedure o2File
/*--- cast the object to a String -----------------------------------*/
o2String: procedure expose m.
parse arg m, fmt
if arg() = 1 then
fmt = ' '
interpret objMet(m, 'o2String')
return err('o2String did not return')
endProcedure o2String
/*--- return a short string representation of an object o=¢...! -----*/
o2Text: procedure expose m.
parse arg m, maxL, fmt
if maxL == '' then
maxL = 75
interpret objMet(m, 'o2Text')
endProcedure o2Text
/*--- return a short string representation of the fields of an object-*/
o2TexLR: procedure expose m.
parse arg m, maxL, le, ri
if maxL == '' then
maxL = 75
interpret objMet(m, 'o2TexLR')
endProcedure o2TexLR
o2TextFlds: procedure expose m.
parse arg m, cl, maxL
maxL = maxL - 3
r = ''
do fx=1 to m.cl.fldd.0
c1 = m.cl.fldd.fx.class
r = r || left(' ', fx > 1)substr(m.cl.fldd.fx, 2)
if c1 = m.class_V then
r = r'='
else if m.c1 == 'r' then
r = r'=>'
else
r = r'=?'c1'?'
a1 = m || m.cl.fldd.fx
r = r || m.a1
if length(r) > maxL then
return left(r, maxL)'...'
end
return r
endProcedure o2TextFlds
o2TextGen: procedure expose m.
parse arg cl, le, ri
m1 = classMet(cl, 'o2String', '-')
if m1 \== '-' then do
if translate(word(m1, 1)) \== 'RETURN' then
call err 'o2TextGen' className(cl)'#o2String return?:' m1
return '__r = strip('subword(m1, 2)', "t");',
'if length(__r) <= maxL then return __r;' ,
'else return left(__r, maxL-3)"..."'
end
call classMet cl, 'oFlds'
if le = '' & ri = '' then
return "return o2TextFlds(m, '"cl"', maxL)"
else
return "return" le "|| o2TextFlds(m, '"cl"'" ,
", maxL - length("le") - length("ri")) || "ri
endProcedure o2TextGen
/*--- cast a String to an object -----------------------------------*/
s2o: procedure expose m.
parse arg str
return m.o_escW || str
endProcedure s2o
oIfStr: procedure expose m.
parse arg m
if length(m) > 200 then
return m
cl = objClass(m)
if cl == m.class_N | cl == m.class_S then
return m
else if cl = m.class_V then
return = m.m
else if cl == m.class_W then
return = substr(m, 2)
else if arg() >= 2 then
return arg(2)
else
call err m 'of class' className(cl) 'not kind of string'
endProcedure oIfStr
/* copy o end *******************************************************/
/* copy class begin **************************************************
a class has fields and methods,
the class module handles only the metadata,
object handling (instanciation, methodcalls etc.) is in O
classes are represented by a metadata tree,
its nodes of class class have diffenrent types:
class subTypes (implemented as choices)
'u' = union: NAME -> name of class if <> '',
stem -> references component classes
'f' = field: NAME -> fieldName (x.name),
CLASSS -> reference to class of fieldValue
's' = stem: class -> ref to class at each stem element
'c' = choice: NAME -> selection value,
CLASS -> ref to class of choice
'm' = method: NAME -> methodName,
MET -> rexxCode
'r' = reference CLASS -> ref to type at reference
special classes
'v' = Value String Value
'w' = ValueAsA StringValue packed into an address (prefix escW)
'o' = AnyClass any class with dynamic classLookup on object
formal definition, see classIni
class expression (ce) allow the following syntax
ce = className | classAdr | 'n'('?','*','|')? name union | union
| 'f' name ce | 's' ce | 'c' name ce | 'm' name code | r ce?
union = 'u' (cu (',' cu)*)?
cu = ce | c1* '%' c1* '%'? name+ (same type for each name)
the modifiers of 'n' means
none: create new class, fail if name already defined
'?': create new class or return old of that name
'*': use an exisiting class of that definition
or create new class with a unique name
'|': create a new class with a unique name
'm' extends to then end of the ce (line)
'u' allows several components, in classNew also multiple args
Achtung, aber NICHT rekursiv|
***********************************************************************/
classIni: procedure expose m.
if m.class.ini == 1 then
return
m.class.ini = 1
m.o_escW = '!'
call mapIni
m.class.0 = 0
call mapReset class_n2c /* name to class */
m.class_V = classNew('n v u', 'm',
, "o2String return m.m",
, "o2File return file(m.m)")
m.class_W = classNew('n w u', 'm' ,
, "o2String return substr(m, 2)" ,
, "o2File return file(substr(m,2))")
m.class_O = classNew('n o u')
m.class_R = classNew('r')
m.class_C = classNew('n class u')
call classNew 'n= class u v' ,
, 'c u u f NAME v', /* union or class */
, 'c f u f NAME v', /* field */
, 'c s u' , /* stem */
, 'c c u f NAME v', /* choice */
, 'c r u' , /* reference */
, 'c m u f NAME v, f MET v' /* method */
call mAdd m.class_C, classNew('s r class')
m.class_lazyRetMutate = "return 'call oMutate m, '''cl''';'"
m.class_lazyRoot = classNew('n LazyRoot u', 'm',
, "METHODLAZY" ,
, "f2c call classMet cl, 'oFlds'; return cl'.F2C'" ,
, "f2x call classMet cl, 'oFlds';",
"call mInverse cl'.FLDS', cl'.F2X';" ,
"return cl'.F2X'" ,
, "oFlds call classFldGen cl; return cl'.FLDS'" ,
, "oFldD call classMet cl, 'oFlds'; return cl'.FLDD'" ,
, "o2Text return o2textGen(cl, 'm''=¢''', '''!''')",
, "o2TexLR return o2textGen(cl, 'le', 'ri')",
, "s2c call classMet cl, 'oFlds'; return cl'.S2C'" ,
, "stms call classMet cl, 'oFlds'; return cl'.STMS'" ,
, "in2Str return classMet(cl, 'o2String')" ,
, "in2File return classMet(cl, 'o2File')" ,
, "in2Buf return 'return jBufCopy('" ,
"classMetRmRet(cl,'o2File')')'",
, "scanSqlIn2Scan return" ,
"'return scanSqlReset(s,'" ,
"classMetRmRet(cl, 'in2File')', wOpt, sOpt)'",
, "new call mNewArea cl, 'O.'substr(cl,7);" ,
"return 'm = mNew('''cl''');'" ,
"classMet(cl,'oReset')",
, "oReset call classMet cl, 'oClear';" m.class_lazyRetMutate,
"'call classClear '''cl''', m;'" ,
, "oResetNoMut return classRmFirstmt(" ,
"classMet(cl, 'oReset'), 'call oMutate ');" ,
, "oClear call classMet cl, 'oFlds'" ,
"; return 'call classClear '''cl''', m'",
, "oCopy return oCopyGen(cl)")
laStr = classNew('n LazyString u LazyRoot', 'm',
, "scanSqlIn2Scan return 'if wOpt == '''' then wOpt = 0;" ,
"return scanSqlReset(s,'" ,
"classMetRmRet(cl, 'in2File')', wOpt, sOpt)'")
/* 'o2Text ?r return m"=¢?:!"' */
m.class_S = classNew('n String u', 'm',
, 'METHODLAZY' laStr,
, 'in2Str return m' ,
, 'in2File return jBuf(m)',
, 'in2Buf return jBuf(m)',
, 'o2String return m')
m.class_N = classNew('n Null u', 'm',
, 'in2Str return o2String(m.j.in, fmt)',
, 'in2File return m.j.in',
, 'in2Buf return jBufCopy(m.j.in)')
laRun = classNew('n LazyRun u LazyRoot', 'm',
, "o2Text return 'return m''=¢'className(cl)'!'''")
/* 'o2Text ?r return m"=¢?:!"' */
call classNew 'n ORun u', 'm',
, 'METHODLAZY' laRun ,
, 'oRun call err "call of abstract method oRun"',
, 'o2File return oRun2File(m)',
, 'o2String return jCatLines(oRun2File(m), fmt)'
return
endProcedure classIni
/*--- remove first statement if src starts with strt ----------------*/
classRmFirStmt: procedure expose m.
parse arg src, strt
if \ abbrev(src, strt) then
return src
return substr(src, pos(';', src)+2)
classNe1: procedure expose m.
parse arg n, ty, nm, refs, io
ky = ty','nm','space(refs, 1)','strip(io)
if ty == 'f' & abbrev('=', nm) then do
if words(refs) = 1 & io == '' then
return strip(refs)
else
call err 'bad field name:' ky
end
if n then
if symbol('m.class_k2c.ky') == 'VAR' then
return m.class_k2c.ky
m.class.0 = m.class.0 + 1
n = 'CLASS.'m.class.0
call mapAdd class_n2c, n, n
m.n = ty
m.n.name = nm
m.n.met = strip(io)
m.n.0 = words(refs)
do rx=1 to m.n.0
m.n.rx = mapGet(class_n2c, word(refs, rx))
end
if right(nm, 1) == '*' then
nm = left(nm, length(nm)-1)substr(n, 7)
if length(ty) \== 1 | pos(ty, 'ufscrm') < 1 then
call err 'bad type' ty': classNe1('ky')' /0
else if nm == '' & pos(ty, 'm') > 0 then
call err 'empty name: classNe1('ky')'
else if nm \== '' & ty \== 'c' & verifId(nm) > 0 then
call err 'bad name' nm': classNe1('ky')'
else if nm \= '' & pos(ty, 'rs') > 0 then
call err 'name for type' ty': classNe1('ky')'
else if (pos(ty, 'fcsr') > 0 & m.n.0 \== 1) ,
| ( ty == 'm' & m.n.0 \== 0) then
call err m.n.0 'bad ref count in classNe1('ky')'
return n
endProcedure classNe1
classNew: procedure expose m.
parse arg clEx 1 ty rest
n = ''
nm = ''
io = ''
refs = ''
if wordPos(ty, 'n n? n* n=') > 0 then do
nmTy = right(ty, 1)
parse var rest nm ty rest
if nmTy = '=' then do
if \ mapHasKey(class_n2c, nm) then
call err 'class' nm 'not defined: classNew('clEx')'
n = mapGet(class_n2c, nm)
end
if ty \== 'u' then
call err 'class name' nm 'without u: classNew('clEx')'
if nmTy == '?' then do
if mapHasKey(class_n2c, nm) then
return mapGet(class_n2c, nm)
end
else if nmTy == '*' & arg() == 1 then do
if mapHasKey(class_n2c, clEx) then
return mapGet(class_n2c, clEx)
end
end
else do
nmTy = ''
if arg() == 1 then
if mapHasKey(class_n2c, clEx) then
return mapGet(class_n2c, clEx)
if length(ty) <> 1 | pos(ty, 'ufscmr') < 1 then
return err('bad type' ty': classNew('clEx')')
if pos(ty, 'fcm') > 0 then
parse var rest nm rest
if ty == 'm' then
io = rest
else if pos(ty, 'fsc') > 0 | (ty == 'r' & rest \== '') then
refs = classNew(strip(rest))
else if ty == 'r' then
refs = m.class_O
end
if ty == 'u' then do
lx = 0
do while lx < length(rest)
t1 = word(substr(rest, lx+1), 1)
cx = pos(',', rest, lx+1)
if cx <= lx | t1 == 'm' then
cx = length(rest)+1
one = strip(substr(rest, lx+1, cx-lx-1))
lx=cx
if pos('%', word(one, 1)) < 1 then
refs = refs classNew(one)
else do
parse value translate(word(one, 1), ' ', '-') ,
with wBe '%' wAf '%' ww
do wx=2 to words(one)
refs = refs classNew(wBe word(one, wx) wAf)
end
end
end
pref = ''
do ax=2 to arg()
if length(arg(ax)) == 1 & arg(ax) \== ' ' then
pref = arg(ax)' '
else
refs = refs classNew(pref || arg(ax))
end
end
if nmTy == '=' then do
if m.n \== ty | ty \== 'u' then
call err 'n= mismatch'
do ux=1 to words(refs)
call mAdd n, word(refs, ux)
end
end
else if nmTy == '*' then
n = classNe1(0, ty, nm'*', refs, io)
else
n = classNe1(nmTy == '', ty, nm, refs, io)
if arg() == 1 then
call mapAdd class_n2c, clEx, n
if nmTy == '*' & m.n.name == nm'*' then
m.n.name = nm || substr(n, 6)
if nmTy \== '' & nmTy \== '=' then
call mapAdd class_n2c, m.n.name, n
if nmTy == 'n' | nmTy == '?' then do
v = 'CLASS_'translate(nm)
if symbol('m.v') == 'VAR' then
call err 'duplicate class' v
m.v = n
end
return n
endProcedure classNew
/*--- return the name of a class if it exists otherwise the class ---*/
className: procedure expose m.
parse arg cl
if \ mapHasKey(class_n2c, cl) then
return 'notAClass:' cl
c2 = mapGet(class_n2c, cl)
if m.c2 = 'u' & m.c2.name \= '' then
return m.c2.name
else
return cl
endProcedure className
/*--- return class of given name or class ---------------------------*/
class4Name: procedure expose m.
parse arg nm
if symbol('m.class_n2c.nm') == 'VAR' then
return m.class_n2c.nm
if arg() > 1 then
return arg(2)
call err 'no class' nm
endProcedure class4Name
/*--- mutate object m to the class cl -------------------------------*/
oMutate: procedure expose m.
parse arg m, cl
m.o.o2c.m = cl
return m
endProcedure oMutate
/*--- mutate object m to the class named name -----------------------*/
oMutatName: procedure expose m.
parse arg m, nm
m.o.o2c.m = class4Name(nm)
return m
endProcedure oMutatName
/*--- find the code for a met in a class ---------------------------*/
classMet: procedure expose m.
parse arg cl, met
if symbol('m.cl.method.met') == 'VAR' then
return m.cl.method.met
if symbol('m.cl.method.methodLazy') == 'VAR' then do
/* build lazy method */
m.cl.method.met = "call err 'building lazy method" cl"#"met"'"
m.cl.method.met = classMetLazy(m.cl.method.methodLazy, cl, met)
if m.cl.method.met \== '\-\' then
return m.cl.method.met
drop m.cl.method.met
if arg(3) \== '' then
return arg(3)
else
return err('no method' met 'in class' className(cl))
end
if symbol('m.class_n2c.cl') \== 'VAR' then
call err 'no class classMet('cl',' met')'
if cl \== m.class_n2c.cl then
return classMet(m.class_n2c.cl, met)
if m.cl == 'u' then
call classMetGen cl, cl'.'method
if symbol('m.cl.method.methodLazy') \== 'VAR' then
m.cl.method.methodLazy = m.class_lazyRoot
return classMet(cl, met, arg(3))
endProcedure classMet
classMetLazy: procedure expose m.
parse arg build, cl, met
if build = '' then
return '\-\'
cd = classMet(build, met, '\-\')
if abbrev(cd, '?') then
return err('? met' cd 'b='build cl'#'met) / 0
else if cd \== '\-\' then
interpret cd
else
return cd
endProcedure classMetLazy
classMetRmRet: procedure expose m.
parse arg cl, met
cd = classMet(cl, met)
if word(cd, 1) == 'return' then
return subword(cd, 2)
else
return cd
endProcedure classMetRmRet
/*--- generate all methods for a class recursively -------------------*/
classMetGen: procedure expose m.
parse arg aC, trg, pa
pa = classCycle(aC, pa)
if m.aC \== 'u' then
call err 'cl not u:' m.aC aC
do cx=1 to m.aC.0
cl = m.aC.cx
if pos(m.cl, 'ufscr') > 0 then
iterate
if m.cl \== 'm' then
call err 'bad cla' cl m.cl
m1 = m.cl.name
if symbol('m.trg.m1') == 'VAR' then
nop
else
m.trg.m1 = m.cl.met
end
do cx=1 to m.aC.0
cl = m.aC.cx
if m.cl \== 'u' then
iterate
call classmetGen cl, trg, pa
end
return
endProcedure classmetGen
classCycle: procedure expose m.
parse arg cl, pa
if wordPos(cl, pa) < 1 then
return pa cl
call err classCycle cl pa / 0
endProcedure classCycle
classFlds: procedure expose m.
parse arg cl
return classMet(cl, 'oFlds')
endProcedure classFlds
classFldD: procedure expose m.
parse arg cl
return classMet(cl, 'oFldD')
endProcedure classFldD
classFldGen: procedure expose m.
parse arg cl
m.cl.fldS.0 = 0
m.cl.fldS.self = 0
m.cl.fldD.0 = 0
m.cl.stmS.0 = 0
m.cl.stmS.self = 0
m.cl.stmD.0 = 0
return classFldAdd(cl, cl)
endPorcedure classFldGen
/*--- add the the fields of class cl to stem f ----------------------*/
classFldAdd: procedure expose m.
parse arg f, cl, nm, pa
pa = classCycle(cl, pa)
if cl == m.class_V | cl == m.class_W | cl == m.class_O ,
| m.cl == 'r' then
return classFldAdd1(f'.FLDD', f'.FLDS', f'.F2C', cl, nm,
, if(cl=m.class_W, m.o_escW, ''))
if m.cl = 's' then do
if m.cl.1 == '' then
call err 'stem null class'
return classFldAdd1(f'.STMD', f'.STMS', f'.S2C', m.cl.1, nm, 0)
end
if m.cl = 'f' then
return classFldAdd(f, m.cl.1, nm ,
|| left('.', m.cl.name \== '' & nm \== '') || m.cl.name, pa)
do tx=1 to m.cl.0
call classFldAdd f, m.cl.tx, nm, pa
end
return 0
endProcedure classFldAdd
classFldAdd1: procedure expose m.
parse arg fd, fs, f2, cl, nm, null
if symbol('m.f2.nm') == 'VAR' then
if m.f2.nm == cl then
return 0
else
return err('f2 mismatch f2='f2 Nm 'cl='cl 'old='m.f2.nm)
m.f2.nm = cl
cc = mAdd(fd, left('.', nm \== '')nm)
m.cc.class = cl
if nm == '' then do
m.fs.self = 1
m.fs.self.class = cl
/* call mMove fa, 1, 2
m.fa.1 = ''
call mPut fa'.SELF', 1 */
end
else do
cc = mAdd(fs, nm)
m.cc.class = cl
end
return 0
endProcedure classFldAdd1
/* copy class end ***************************************************/
/* copy mapExp begin **************************************************/
mapVia: procedure expose m.
parse arg a, ky
sx = pos('|', ky)
if sx < 1 then
return mapGet(a, ky)
via = mapGet(a, left(ky, sx-1))
do while sx <= length(ky)
fx = sx+1
sx = pos('|', ky, fx)
if sx < 1 then
sx = length(ky) + 1
if sx = fx then do
if symbol('m.via') \== 'VAR' then
call err 'missing m.'via 'at' sx 'in mapVia('a',' ky')'
via = m.via
end
else do
f = substr(ky, fx, sx - fx)
if symbol('m.via.f') \== 'VAR' then
call err 'missing m.'via'.'f ,
'at' sx 'in mapVia('a',' ky')'
via = m.via.f
end
end
return via
endProcedure mapVia
mapExpAt: procedure expose m.
parse arg a, src, sx
m.map.ExpAt = 0
cx = pos('$', src, sx)
if cx < 1 then
return substr(src, sx)
res = substr(src, sx, cx-sx)
do forever
if substr(src, cx+1, 1) = '{' then do
ex = pos('}', src, cx+2)
if ex < 1 then
call err 'missing } after' substr(src, cx) 'in' src
res = res || mapVia(a, strip(substr(src, cx+2, ex-cx-2)))
ex = ex + 1
end
else do
ex = verify(src, m.ut_alfDot, 'n', cx+1)
if ex < 1 then
return res || mapVia(a, substr(src, cx+1))
if ex = cx+1 then do
m.map.ExpAt = cx
return res
end
res = res || mapVia(a, substr(src, cx+1, ex-cx-1))
end
cx = pos('$', src, ex)
if cx < 1 then
return res || substr(src, ex)
res = res || substr(src, ex, cx-ex)
end
endProcedure mapExpAt
mapExp: procedure expose m.
parse arg a, src
res = mapExpAt(a, src, 1)
if m.map.ExpAt \== 0 then
call err 'mapExp stopped at' substr(src, map.ExpAt) 'in' src
return res
endProcedure mapExp
mapExpAllAt: procedure expose m.
parse arg a, dst, src, sx, cx
do while sx <= m.src.0
li = mapExpAt(a, m.src.sx, cx)
dx = m.map.ExpAt
if (cx=1 & dx = 0) | li \= '' then
call mAdd dst, li
if dx = 0 then do
cx = 1
sx = sx+1
end
else do
return sx dx
end
end
return ''
endProcedure mapExpAllAt
mapExpAll: procedure expose m.
parse arg a, dst, src
sto = mapExpAllAt(a, dst, src, 1, 1)
if sto == '' then
return
lx = word(sto, 1)
call err 'mapExpAll stopped at' sto':' m.src.lx
endProcedure mapExpAll
/* copy mapExp end ****************************************************/
/* copy map begin ******************************************************
a map stores values at keys
it may also maintain a list of keys
the basic ideas are similar to the java Interface java.util.Map
contrary to stems we also handle keys longer then 250 bytes
***********************************************************************/
/*--- initialize the module ------------------------------------------*/
mapIni: procedure expose m.
if m.map_ini = 1 then
return
m.map_ini = 1
call mIni
m.map.0 = 0
m.map_inlineSearch = 1
call mapReset map_inlineName, map_inline
return
endProcedure mapIni
mapInline: procedure expose m.
parse arg pName, opt
if mapHasKey(map_inlineName, pName) then do
im = mapGet(map_inlineName, pName)
if pos('l', opt) < 1 & symbol('m.im.0') \== 'VAR' then do
m.im.0 = m.im.lEnd - m.im.lBegin - 1
do ix=1 to m.im.0
m.im.ix = strip(sourceline(ix+m.im.lBegin), 't')
end
end
return im
end
name = '/'
do lx = m.map_inlineSearch to sourceline()
if \ abbrev(sourceline(lx), '$') then
iterate
li = sourceline(lx)
s1 = pos('/', li)+ 1
if s1 < 3 | s1 > 4 then
iterate
s2 = pos('/', li, s1)
if s2 <= s1 then
iterate
if s1 == 3 then do
if name \== substr(li, s1, s2-s1) then
iterate
im = 'map_inline.' || (m.map_inline.0+1)
call mapAdd map_inlineName, name, im
m.im.lBegin = lBeg
m.im.lEnd = lx
m.im.mark = mrk
if name == pName then do
m.map_inlineSearch = lx+1
return mapInline(pName)
end
name = '/'
end
else if \ mapHasKey(map_inlineName,
, substr(li, s1, s2-s1)) then do
lBeg = lx
mrk = substr(li, 2, s1-3)
name = substr(li, s1, s2-s1)
end
else do
name = '/'
end
end
if pos('r', opt) > 0 then
return ''
return err('no inline data /'pName'/ found')
endProcedure mapInline
/*--- create a new map ----------------------------------------------*/
mapNew: procedure expose m.
parse arg opt
m.map.0 = m.map.0 + 1
return mapReset('MAP.'m.map.0 , opt)
endProcedure mapNew
/*--- make an empty map, if opt <> '' maintain stem of keys
('K' in map_keys, '=' in a else in opt) --------------*/
mapReset: procedure expose m.
parse arg a, opt
if symbol('m.map_keys.a') == 'VAR' then
call mapClear a
if opt = '=' then
st = a
else if translate(opt) = 'K' then
st = 'MAP_KEYS.'a
else
st = opt
m.map_keys.a = st
if st \== '' then
m.st.0 = 0
return a
endProcedure
/*--- add a new key value pair to the map ----------------------------*/
mapAdd: procedure expose m.
parse arg a, ky, val
vv = mapAdr(a, ky, 'a')
if vv == '' then
return err('duplicate in mapAdd('a',' ky',' val')')
m.vv = val
return val
endProcedure mapAdd
/*--- change the value at a key or add key value ---------------------*/
mapPut: procedure expose m.
parse arg a, ky, val
vv = mapAdr(a, ky, 'p')
m.vv = val
return val
endProcedure mapPut
/*--- return 1 if key ky exists in map a, 0 otherwise ----------------*/
mapHasKey: procedure expose m.
parse arg a, ky
return mapAdr(a, ky, 'g') \== ''
endProcedure mapHasKey
/*--- return the value of key ky in map a if it exists,
else if called with a third argument return third argument
else issue an error ----------------------------------------*/
mapGet: procedure expose m.
parse arg a, ky
vv = mapAdr(a, ky, 'g')
if vv \== '' then
return m.vv
else if arg() > 2 then
return arg(3)
else
return err('missing key in mapGet('a',' ky')')
endProcedure mapGet
/*--- return a stem of all keys --------------------------------------*/
mapKeys: procedure expose m.
parse arg a
if m.map_keys.a == '' then
call err 'mapKeys('a') with no keys'
return m.map_keys.a
endProcedure mapKeys
/*--- remove a key from the map, do nothing if it is missing ---------*/
mapRemove: procedure expose m.
parse arg a, ky
vv = mapAdr(a, ky, 'g')
if vv == '' then
return ''
if m.map_keys.a \== '' then do
trace ?R /* not tested yet ???wkTest */
k = m.map_keys.a
mx = m.k.0
do i=1 to mx
if m.k.i == ky then do
m.k.i = m.k.mx
m.k.0 = mx - 1
return
end
end
end
val = m.vv
drop m.a.ky
return val
endProcedure mapRemove
/*--- remove all entries ---------------------------------------------*/
mapClear: procedure expose m.
parse arg a
st = mapKeys(a)
liLe = 247 - length(a)
do kx=1 to m.st.0
ky = m.st.kx
drop m.st.kx
if length(ky) < liLe then do
drop m.a.ky
end
else do
adr = mapAdr(a, ky, 'g')
if adr \== '' then do
ha = left(adr, length(adr) - 2)
do i = 1 to m.ha.0
vv = ha'v'i
drop m.ha.i m.vv
end
drop m.ha.0
end
end
end
m.st.0 = 0
return a
endProcedure mapClear
/*--- return the value pointer for a key, '' if non existing
f = 'g' return address if exists otherwise ''
'p' return address if exists otherwise newly added address
'a' return '' if exists otherwise newly added address ---*/
mapAdr: procedure expose m.
parse arg a, ky, f
if length(ky) + length(a) < 247 then do
res = a'.'ky
if symbol('m.res') == 'VAR' then
return copies(res, f \== 'a')
else if f == 'g' then
return ''
end
else do
len = length(ky)
q = len % 2
ha = a'.'len || left(ky, 80) || substr(ky,
, len % 2 - 40, 85-length(len)-length(a)) || right(ky, 80)
if symbol('M.ha.0') == 'VAR' then do
do i=1 to m.ha.0
if m.ha.i == ky then
return copies(ha'v'i, f \== 'a')
end
end
else do
i = 1
end
if f == 'g' then
return ''
if i > 9 then
call err 'overflow long key' y 'in map' a 'hash' ha'.K.'i
m.ha.0 = i
m.ha.i = ky
res = ha'v'i
end
if m.map_keys.a \== '' then
call mAdd m.map_keys.a, ky
return res
endProcedure mapAdr
/* copy map end *******************************************************/
/* copy m begin ********************************************************
we use variables as follows
m. stem m: all global data and object data that must survive
a procedure call (m for memory in Memoria of B5000)
m.<mbr>.** and m.<mbr>_**: every rexx Module (copy) should only
allocate these addresses to avoid address conficts
with <mbr> the name of therexx module
we pass parameters around (e.g. a=address, m=memory, st=stem)
and the called function may use m.a or m.a.subField etc.
gg*: local variable in subroutines without procedure
everything else: temporary data within procedure
every subroutine is declared as procedure expose m.
(also if no m. variable is used, because e.g. of error handling)
the few subroutines that cannot use procedure, should use only
variables starting with gg
***********************************************************************/
/*---make an area -----*/
mNewArea: procedure expose m.
parse arg nm, adr
ax = m.m_area.0 + 1
m.m_area.0 = ax
m.m_area.ax = nm
if adr == '=' then
adr = nm
else if adr == '' then
adr = 'M.'ax
if symbol('m.m_2a.nm') == 'VAR' then
call err 'area name' nm 'already used'
if symbol('m.m_2a.adr') == 'VAR' then
call err 'adr' adr 'for area' nm 'already used'
m.m_2a.adr = adr
m.m_2a.nm = adr
m.adr.0 = 0
m.m_free.adr.0 = 0
return nm
endProcedure mNewArea
mNew: procedure expose m. ggArea
parse arg name
if symbol('m.m_2a.name') \== 'VAR' then
call err 'area' name 'does not exists'
adr = m.m_2a.name
if m.m_free.adr.0 > 0 then do
fx = m.m_free.adr.0
m.m_free.adr.0 = fx-1
return m.m_free.adr.fx
end
m.adr.0 = m.adr.0 + 1
return adr'.'m.adr.0
endProcedure mNew
mFree: procedure expose m.
parse arg m
adr = left(m, lastPos('.', m)-1)
fx = m.m_free.adr.0 + 1
m.m_free.adr.0 = fx
m.m_free.adr.fx = m
return ''
endProcedure mFree
/*--- iterate over all allocate elements of an area ------------------*/
mIterBegin: procedure expose m.
parse arg nm
return m.m_2a.nm'.0'
endProcedure mIterBegin
mIter: procedure expose m.
parse arg cur
if cur == '' then
return ''
lx = lastPos('.', cur)
adr = left(cur, lx-1)
ix = substr(cur, lx+1)
do ix=ix+1 to m.adr.0
n = adr'.'ix
do fx=1 to m.m_free.adr.0 while m.m_free.adr.fx \== n
end
if fx > m.m_free.adr.0 then
return n
end
return ''
endProcedure mIter
/*--- get m.a --------------------------------------------------------*/
mGet: procedure expose m.
parse arg a
return m.a
endProcedure mGet
/*--- put value v into m.a -------------------------------------------*/
mPut: procedure expose m.
parse arg a, v
m.a = v
return v
endProcedure mPut
/*--- cut stem a to length len ---------------------------------------*/
mCut: procedure expose m.
parse arg a, len
m.a.0 = len
return a
endProcedure mCut
/*--- add one or several arguments to stem m.a -----------------------*/
mAdd: procedure expose m.
parse arg a
ix = m.a.0
do ax = 2 to arg()
ix = ix + 1
m.a.ix = arg(ax)
end
m.a.0 = ix
return a'.'ix
endProcedure mAdd
/*--- pop last element from stem m.a ---------------------------------*/
mPop: procedure expose m.
parse arg a
ix = m.a.0
if ix < 1 then
call err 'pop from empty stem' a
m.a.0 = ix-1
return m.a.ix
endProcedure mPop
/*--- create the inverse map of a stem -------------------------------*/
mInverse: procedure expose m.
parse arg a, i
do x=1 to m.a.0
v = m.a.x
m.i.v = x
end
return m.a.0
endProcedure inverse
/*--- add to m.dst.* a (sub)sequence of m.src.* ----------------------*/
mAddSt: procedure expose m.
parse arg dst, src, fx , tx
dx = m.dst.0
if fx == '' then
fx = 1
if tx == '' then
tx = m.src.0
do sx = fx to tx
dx = dx + 1
m.dst.dx = m.src.sx
end
m.dst.0 = dx
return
endProcedure mAddSt
/*--- find position of first occurrence of ele in stem m,
return 0 if nonemove a part of a stem -----------------------*/
mPos: procedure expose m.
parse arg m, ele, sx
if sx == '' then
sx = 1
do x=sx to m.m.0
if m.m.x = ele then
return x
end
return 0
endProcedure mPos
/*--- move a part of a stem ------------------------------------------*/
mMove: procedure expose m.
parse arg m, sx, dx
if dx < sx then do
y = dx
do x=sx to m.m.0
m.m.y = m.m.x
y = y + 1
end
end
else if dx > sx then do
y = m.m.0 + dx - sx
do x=m.m.0 by -1 to sx
m.m.y = m.m.x
y = y - 1
end
end
m.m.0 = m.m.0 + dx - sx
return
endProcedure mMove
/*--- insert a stem into another ------------------------------------*/
mInsert: procedure expose m.
parse arg m, tx, st
call mMove m, tx, tx+m.st.0
do sx=1 to m.st.0
dx = tx-1+sx
m.m.dx = m.st.sx
end
return
endProcedure mInsert
/*--- strip all elements of a stem -----------------------------------*/
mStrip: procedure expose m.
parse arg st, opt
if opt == '' then
opt = 'b'
do x=1 to m.st.0
m.st.x = strip(m.st.x, opt)
end
return st
endProcedure mStrip
/* cat the lines of a stem with separator ---------------------------*/
mCat: procedure expose m.
parse arg st, sep
if m.st.0 < 1 then
return ''
res = m.st.1
do sx=2 to m.st.0
res = res || sep || m.st.sx
end
return res
endProcedure mCat
mIni: procedure expose m.
if m.m_ini == 1 then
return
m.m_ini = 1
call utIni
m.m_area.0 = 0
call mNewArea
return
endProcedure mIni
/* copy m end *********************************************************/
/* copy fTab begin *****************************************************
output Modes: t = tableMode 1 line per object
c = colMode 1 line per column/field of object
lifeCycle fTab sql
fTabReset sqlFTabReset
fTabAdd * sqlFTabAdd *
sqlFTabOthers ?
fTabGenerate
fTabBegin header lines
fTab1 * / tTabCol *
fTabEnd trailer lines
***********************************************************************/
fTabIni: procedure expose m.
if m.fTab_ini == 1 then
return
m.fTab_ini = 1
call classIni
m.fTab_class = classNew("n FTab u ORun, m oRun call fTab m")
return
endProcedure fTabIni
fTabReset: procedure expose m.
parse arg m, m.m.titBef, m.m.titAft, m.m.opt
call fTabIni
if m.m.titBef == '' & m.m.titaft == '' then do
m.m.titBef = 'c 1'
m.m.titAft = '1 c'
end
if m.m.titBef == '-' then
m.m.titBef = ''
if m.m.titAft == '-' then
m.m.titAft = ''
m.m.generated = ''
m.m.0 = 0
m.m.len = 0
m.m.cols = ''
m.m.sqlOthers = 1
m.m.set.0 = 0
return oMutate(m, m.fTab_class)
endProcedure fTabReset
/* add a piece to title tx at current pos */
fTabAddTit: procedure expose m.
parse arg m, cx, tx, t1
m.m.generated = ''
if ty < m.m.cx.tit.0 then do
do xx=m.m.cx.tit.0+1 to tx-1
m.m.cx.tit.xx = ''
end
m.m.cx.tit.0 = tx
end
m.m.cx.tit.tx = t1
return m
endProcedure fTabAddTit
/*--- set the infos for one column -----------------------------------*/
fTabSet: procedure expose m.
parse arg m, c1 aDone, f1, l1
sx = m.m.set.0 + 1
m.m.set.0 = sx
m.m.set.sx = c1 aDone
m.m.set.sx.fmt = f1
m.m.set.sx.labelCy = l1
m.m.set.sx.labelTi = c1
m.m.set.c1 = sx
return
endProcedure fTabSet
fTabAdd: procedure expose m. /* old interface, new is ...RCT */
parse arg m, c1Done, f1, l1
call fTabAddRCT m, c1Done, f1, , l1
ox = m.m.0
m.m.ox.tit.0 = max(arg()-3, 1)
do tx=2 to m.m.ox.tit.0
m.m.ox.tit.tx = arg(tx+3)
end
return
endProcedure fTabAdd
fTabAddRCT: procedure expose m.
parse arg m, rxNm aDone, f1, cyNm, tiNm
cx = m.m.0 + 1
m.m.generated = ''
m.m.0 = cx
m.m.cx.tit.0 = max(arg()-4, 1)
m.m.cx.tit.1 = ''
do tx=2 to m.m.cx.tit.0
m.m.cx.tit.tx = arg(tx+4)
end
r1 = rxNm
if rxNm == '' then
r1 = '='
else if rxNm == '=' then
rxNm = ''
m.m.cols = m.m.cols r1
if words(m.m.cols) <> cx then
call err 'mismatch of column number' cx 'col' rxNm / 0
if length(aDone) > 1 | wordPos('<'aDone'>', '<> <0> <1>') < 1 then
call err 'bad done' length(aDone) '<'aDone'> after rxNm' rxNm
m.m.cx.col = rxNm
m.m.cx.done = aDone \== 0
if cyNm == '' then
m.m.cx.labelCy = r1
else
m.m.cx.labelCy = cyNm
if tiNm == '' then
m.m.cx.labelTi = m.m.cx.labelCy
else
m.m.cx.labelTi = tiNm
px = pos('%', f1)
ax = pos('@', f1)
if px < 1 | (ax > 0 & ax < px) then
m.m.cx.fmt = f1
else
m.m.cx.fmt = left(f1, px-1)'@.'rxNm || substr(f1, px)
return m
endProcedure fTabAddRCT
fTabGenerate: procedure expose m.
parse arg m, sep
f = ''
tLen = 0
m.m.tit.0 = words(m.m.titBef m.m.titAft) + 5
do tx=1 to m.m.tit.0
m.m.tit.tx = ''
end
do kx=1 to m.m.0
rxNm = m.m.kx.col
call mPut 'F_TEMP'left('.', rxNm\=='')rxNm, m.m.kx.labelTi
t1 = f(m.m.kx.fmt, 'F_TEMP')
m.m.kx.len = length(t1)
if pos(strip(t1), m.m.kx.labelTi) < 1 then
t1 = left(left('', max(0, verify(t1, ' ') -1)) ,
|| m.m.kx.labelTi, length(t1))
m.m.kx.tit.1 = t1
if kx = 1 then do
f = m.m.kx.fmt
end
else do
tLen = tLen + length(sep)
f = f || sep || m.m.kx.fmt
end
m.m.kx.start = tLen+1
do tx=1 to m.m.kx.tit.0
if m.m.kx.tit.tx \== '' then
if tx > 1 | pos('-', m.m.opt) < 1 then
m.m.tit.tx = left(m.m.tit.tx, tLen) ,
|| strip(m.m.kx.tit.tx, 't')
else if \ abbrev(m.m.kx.tit.tx, ' ') then
m.m.tit.tx = left(m.m.tit.tx, tLen, '-') ,
|| strip(m.m.kx.tit.tx, 't')
else
m.m.tit.tx = left(m.m.tit.tx, tLen, '-') ,
|| right(strip(m.m.kx.tit.tx),
, length(m.m.kx.tit.tx), '-')
end
tLen = tLen + m.m.kx.len
end
m.m.len = tLen
if pos('-', m.m.opt) > 0 then
m.m.tit.1 = left(m.m.tit.1, tLen +3, '-')
m.m.fmt = fCache('%.', f)
cSta = m.m.tit.0+3 /* compute cycle titles */
cycs = ''
cyEq = 1
do cEnd=cSta until kx > m.m.0
cycs = cycs cEnd
cx = cSta
firstRound = 1
do kx=1 to m.m.0
if firstRound then
m.m.tit.cx = left('', m.m.kx.start-1)m.m.kx.labelCy
else if length(m.m.tit.cx) <= m.m.kx.start - 2 then
m.m.tit.cx = left(m.m.tit.cx, m.m.kx.start - 1) ,
|| m.m.kx.labelCy
else
leave
if cyEq then
cyEq = translate(m.m.kx.labelCy) ,
= translate(m.m.kx.labelTi)
cx = cx + 1
if cx > cEnd then do
cx = cSta
firstRound = 0
end
end
end
m.m.cycles = strip(cycs)
if cyEq & words(cycs) <= 1 then
m.m.cycles = ''
m.m.generated = m.m.generated't'
return
endProcedure fTabGenerate
fTabColGen: procedure expose m.
parse arg m
do kx=1 to m.m.0
t = m.m.kx.labelTI
l = if(m.m.kx.labelCy == t, , m.m.kx.labelCy)
f = lefPad(lefPad(strip(l), 10) t, 29)
if length(f) > 29 then
if length(l || t) < 29 then
f = l || left('', 29 - length(l || t))t
else
f = lefPad(strip(l t), 29)
g = strip(m.m.kx.fmt)
o = right(g, 1)
if pos(o, 'dief') > 0 then
f = f '@'m.m.kx.col'%12e @'m.m.kx.col'%18c'
else if o = 'C' then
f = f left(g, length(g)-1)'c'
else
f = f g
m.m.kx.colFmt = f
end
m.m.generated = m.m.generated'c'
return
endProcedure fTabColGen
fTab: procedure expose m.
parse arg m, rdr
call fTabBegin m
call fAll m.m.fmt, rdr
return fTabEnd(m)
endProcedure fTab
fTabCol: procedure expose m.
parse arg m, i
do cx=1 to m.m.0
call out f(m.m.cx.colFmt, i)
end
return 0
endProcedure fTabCol
fTabBegin: procedure expose m.
parse arg m
if pos('t', m.m.generated) < 1 then
call fTabGenerate m, ' '
return fTabTitles(m, m.m.titBef)
endProcedure fTabBegin
fTabEnd: procedure expose m.
parse arg m
return fTabTitles(m, m.m.titAft)
fTabTitles: procedure expose m.
parse arg m, list
list = repAll(list, 'c', m.m.cycles)
do tx=1 to words(list)
t1 = word(list, tx)
call out m.m.tit.t1
end
return m
endProcedure fTabTitles
/*--- auto tables detect format from data ---------------------------*/
/*--- detect fmt from a rdr and write it formatted to stdOut --------*/
fTabAuto: procedure expose m.
parse arg m, rdr, wiTi
if m == '' then
m = fTabReset(f_auto, 1)
i = in2Buf(rdr)
if m.i.buf.0 <= 0 then
return m
call fTabDetect m, i'.BUF', wiTi
return fTab(m, i)
endProcedure fTabAuto
/*--- generate format for all fields of a stem of objects -----------*/
fTabDetect: procedure expose m.
parse arg m, b
ff = oFldD(m.b.1)
do fx=1 to m.ff.0
call fTabAddDetect m, substr(m.ff.fx, 2), b
end
return
endProcedure fTabDetect
/*--- generate format for all fields of a stem of objects -----------*/
sqlfTabDetect: procedure expose m.
parse arg m, b
cx = m.m.sqlX
ff = m.sql.cx.fetchFlds
do fx=1 to words(ff)
call fTabAddDetect m, word(ff, fx), b, m.sql.cx.d.fx.sqlName
end
return
endProcedure fTabDetect
/*--- detect format for one field in stem st ------------------------*/
fTabAddDetect: procedure expose m.
parse arg m, c1 aDone, st, cyNm, tiNm
lMa = -1
rMa = -1
bMa = -1
aDiv = 0
nMi = 9e999
nMa = -9e999
eMi = 9e999
eMa = -9e999
eDa = 2
dMa = -9e999
suf = left('.', c1 \== '')c1
do sx=1 to m.st.0
v = mGet(m.st.sx || suf)
lMa = max(lMa, length(strip(v, 't')))
rMa = max(rMa, length(strip(v, 'l')))
bMa = max(bMa, length(strip(v, 'b')))
if \ dataType(v, 'n') then do
if length(v) > 100 then
aDiv = 99
else if aDiv <=3 then
if aDiv.v \== 1 then do
aDiv.v = 1
aDiv = aDiv + 1
end
iterate
end
v = strip(v)
nMi = min(nMi, v)
nMa = max(nMa, v)
ex = verify(v, 'eEfF', 'm')
if ex > 0 then do
eMa = max(eMa, substr(v, ex+1))
eMi = min(eMi, substr(v, ex+1))
v = left(v, ex-1)
do while pos(left(v,1), '+-0') > 0
v = substr(v, 2)
end
eDa = max(eDa, length(v) - (pos('.', v) > 0))
end
dx = pos('.', v)
if dx > 0 then do
do while right(v, 1) == 0
v = left(v, length(v)-1)
end
dMa = max(dMa, length(v)-dx)
end
end
if nMi > nMa | aDiv > 3 then
newFo = '-'max(1, (lMa+0))'C'
else if eMi <= eMa then do
newFo = ' ' || (eDa+max(length(eMa), length(eMi))+3) ,
|| '.'||(eDa-1)'e'
end
else do
be = max(length(trunc(nMi)), length(trunc(nMa)))
if dMa <= 0 then
newFo = max(be, bMa)'I'
else
newFo = max(be+1+dMa, bMa)'.'dMa'I'
end
call fTabAddRCT m, c1 aDone, '%'newFo, cyNm, tiNm
/* say c1 '????==> %'newFo */
return newFo
endProcedure fTabAddDetect
/*--- format with units seconds ==> 3d13 oder 5.43e6 ==> 5m43 --------*/
fTime: procedure expose m.
?????????????? use f(%kd) ????????????????
fDec: procedure expose m.
?????????????? use f(%kd) ????????????????
fUnits: procedure expose m.
parse arg v, scale, aLen, aPrec, plus
if \ dataType(v, 'n') then do
f1 = fUnitsF1(v, scale, aLen, length(plus), length(plus), aPrec)
return right(v, m.f1.len)
end
if v >= 0 then
sign = plus
else
sign = '-'
v = abs(v) /* always get rid also of sign of -0 | */
f1 = fUnitsF1(v, scale, aLen, length(plus), length(sign), aPrec)
do forever
w = format(v * m.f1.fact, , m.f1.prec)
if pos('E-', w) > 0 then
w = format(0, , m.f1.prec)
if w < m.f1.lim2 then do
if m.f1.kind == 'r' then
x = sign || w || m.f1.unit
else if m.f1.kind == 'm' then
x = sign || (w % m.f1.mod) || m.f1.unit ,
|| right(w // m.f1.mod, m.f1.len2, 0)
else
call err 'bad kind' m.f1.kind 'in f1' f1
if length(x) <= m.f1.len then
return right(x, m.f1.len)
end
if m.f1.next == '' then
return left(sign, m.f1.len, '+')
f1 = m.f1.next
end
endProcedure fUnits
fUnitsF1: procedure expose m.
parse arg v, scale, len, pLen, sLen, aPrec
slp = 'F_Unit.'scale'.'len'.'pLen'.'sLen'.'aPrec
if symbol('m.slp.0') \== 'VAR' then do
sc = 'F_Unit.'scale
if symbol('m.sc.0') \== 'VAR' then do
call fUnitsF1Ini1
if symbol('m.sc.0') \== 'VAR' then
call err 'bad scale' sc
end
if scale = 'd' | scale = 'b' then do
if aPrec == '' then
aPrec = 0
if len = '' then
len = aPrec + (aPrec >= 0) + 4 + pLen
dLen = len - sLen
l2 = '1e' || (dLen - aPrec - (aPrec > 0))
call fUnitsF1I0 slp, 'nn', 'nn', , , , len
do x=m.sc.min to m.sc.0
si = fUnitsF1I0(slp, x, m.sc.x.kind, m.sc.x.unit,
, m.sc.x.fact, l2, len)
m.si.lim1 = m.si.lim2 / m.si.fact
m.si.prec = aPrec
m.si.next = slp'.' || (x+1)
end
if aPrec > 0 then do
y = x-1
si = fUnitsF1I0(slp, x, m.sc.y.kind, m.sc.y.unit,
, m.sc.y.fact, ('1e' || dLen), len)
m.si.lim1 = m.si.lim2 / m.si.fact
m.si.prec = 0
end
end
else if scale = 't' then do
if len = '' then
len = 5 + pLen
dLen = len - sLen
call fUnitsF1I0 slp, 'nn', 'nn', , , , len
do x=m.sc.min to m.sc.0
si = fUnitsF1I0(slp, x, m.sc.x.kind, m.sc.x.unit,
, m.sc.x.fact, m.sc.x.lim2, len ,
, m.sc.x.mod, m.sc.x.len2)
if x = m.sc.0 - 1 then
m.si.lim2 = '24e' || (dLen-3)
else if x = m.sc.0 then
m.si.lim2 = '1e' || (dLen-1)
m.si.lim1 = m.si.lim2 / m.si.fact
m.si.prec = 0
m.si.next = slp'.' || (x+1)
end
end
else
call err implement
x = m.slp.0
m.slp.x.next = ''
end
if \ datatype(v, 'n') then
return slp'.nn'
do q=11 to m.slp.0-1 while v >= m.slp.q.lim1
end
if q = 11 & v <> trunc(v) then do
do q=10 by -1 to m.slp.min+1 while v < m.slp.q.lim1
end
q = q + 1
end
return slp'.'q
endProcedure fUnitsF1
fUnitsF1Ini1: procedure expose m.
/* 0 5 10 5 20 */
iso = ' afpnum kMGTPE '
sB = 'F_Unit.b'
sD = 'F_Unit.d'
sT = 'F_Unit.t'
fB = 1
fD = 1
call fUnitsF1i0 sB, 11, 'r', ' ', fB
call fUnitsF1i0 sD, 11, 'r', ' ', fD
do x=1 to 6
fB = fB * 1024
/* call fUnitsF1i0 sB, 11-x, 'r', substr(iso, 11-x, 1), fB */
call fUnitsF1i0 sB, 11+x, 'r', substr(iso, 11+x, 1), 1/fB
fD = fD * 1000
call fUnitsF1i0 sD, 11+x, 'r', substr(iso, 11+x, 1), 1/fD
call fUnitsF1i0 sD, 11-x, 'r', substr(iso, 11-x, 1), fD
end
call fUnitsF1i0 sT, 11, 'm', 's', 100, 6000, , 100, 2
call fUnitsF1i0 sT, 12, 'm', 'm', 1, 3600, , 60, 2
call fUnitsF1i0 sT, 13, 'm', 'h', 1/60, 1440, , 60, 2
call fUnitsF1i0 sT, 14, 'm', 'd', 1/3600, , , 24, 2
call fUnitsF1i0 sT, 15, 'r', 'd', 1/3600/24
return
endProcedure fUnitsF1Ini1
fUnitsF1I0: procedure expose m.
parse arg sc, ix
si = sc'.'ix
parse arg , , m.si.kind, m.si.unit, m.si.fact,
, m.si.lim2, m.si.len,
, m.si.mod, m.si.len2
if \ datatype(ix, 'n') then
return si
if symbol('m.sc.0') \== 'VAR' then do
m.sc.0 = ix
m.sc.min = ix
end
else do
m.sc.0 = max(ix, m.sc.0)
m.sc.min = min(ix, m.sc.min)
end
return si
endProcedure fUnitsF1I0
/* copy fTab end ****************************************************/
/* copy f begin *******************************************************/
/*--- format with the given format ggA1, ggA2, etc. -----------------*/
f: procedure expose m.
parse arg ggFmt, ggA1, ggA2
if symbol('M.f_gen.ggFmt') \== 'VAR' then
call fCache ggFmt, ggFmt
interpret m.f_gen.ggFmt
endProcedure f
fImm: procedure expose m.
parse arg ggFmt, ggA1
interpret m.ggFmt
endProcedure fImm
fCacheNew: procedure expose m.
if symbol('m.f_gen0') == 'VAR' then
m.f_gen0 = m.f_gen0 + 1
else
m.f_gen0 = 1
return '%.'m.f_gen0
endProcedure fCacheNew
/*--- compile format fmt put in the cache with address a ------------*/
fCache: procedure expose m.
parse arg a, fmt
if a == '%.' then
a = fCacheNew()
else if symbol('M.f_gen.a') == 'VAR' then
return a
cy = -2
nm = ' '
gen = ' '
opt = 0
do forever /* split preprocesser clauses */
cx = cy+3
cy = pos('%#', fmt, cx)
if cy < 1 then
act = substr(fmt, cx)
else
act = substr(fmt, cx, cy-cx)
do ax=1
ay = pos('%&', act)
if ay < 1 then
leave
ct = substr(act, ay+2, 1)
if symbol('f.ct') \== 'VAR' then
call err 'undefined %&'ct 'in format' fmt
act = left(act, ay-1) || f.ct || substr(act, ay+3)
if ax > 100 then
say 'fGen' fmt nm '==>' act 'actPos' substr(fmt, cx)
end
if cy <> 1 & (\ opt | symbol('f.nm') \== 'VAR') then
f.nm = act
if cy < 1 | length(fmt) <= cy+1 then
leave
nm = substr(fmt, cy+2, 1)
opt = nm == '?'
if pos(nm, '?;#') > 0 then do
if nm == '#' then do
if length(fmt) <> cy+3 then
call err 'fCache bad %##'nm 'in' fmt
else if a == fmt then
a = left(a, cy-1)
leave
end
cy = cy+1
nm = substr(fmt, cy+2, 1)
if nm == ';' then do
gen = nm
iterate
end
end
if pos(nm, m.ut_alfa' ') < 1 then
call err 'fCache bad name %#'nm 'in' fmt
if pos(nm, gen) < 1 then
gen = gen || nm
end
if symbol('m.f_s_0') \== 'VAR' | m.f_s_0 == 0 then
m.f_s_0 = 1
else do
m.f_s_0 = m.f_s_0 + 1
f_s = 'F_S_'m.f_s_0
end
do cx=1 to length(gen)
nm = substr(gen, cx, 1)
act = f.nm
a2 = a
if nm == ' ' then
a2 = a
else
a2 = a'%##'nm
call scanSrc f_s, act
m.f_gen.a2 = fGen(f_s)
if \ scanEnd(f_s) then
call scanErr f_s, "bad specifier '"m.f_s.tok"'"
end
m.f_s_0 = m.f_s_0 - 1
return a
endProcedure fCache
/*--------------------------------------------------------------------
Format generator should be compatible with fPrint|
<<<< + extension of fPrint, - in fPrint but not implemented
%% %@ the escaped char
('@' argN? '.'? field)?'%' flags? width? ('.' precision)? specifier
specifier: is the most significant one and defines the type
- c Character rigPad or lefPad, prec ==> substr(..., prec)
- C Cut %-nC = left(v,n), %nC = right(v,n) %n.mC = substr(m, n)
- hH Characters in hex
- iI Signed decimal integer (padded or cut)
- eE Scientific notation (mantissa/exponent) using e character 3.92e+2
- S Strip (both)
- txy time date formatting from format x to format y see fTstGen
- kx units Formatting x = t=time d=decimal b=binary (k) B=binary (kB)
Flags:
- - Left-justify within the given field width; Right is default
- + print '+' before non negative numbers
-' ' print ' ' before non negative numbers
- / cut to length
preprocessor implemented in fCache
%#v before contents of variable v (1 alfa or 1 space),
stored at address%##v
%#?v define variable v if not yet defined
%#; restart of variables to generate
%&v use of previously defined variable v
----------------------------------------------------------------------*/
fGen: procedure expose m.
parse arg f_s
ax = 0
cd = ''
cp = ''
do forever
txt = fText(f_s)
if txt \== '' then
cd = cd '||' quote(txt, "'")
if scanEnd(f_s) then
leave
if \ scanLit(f_s, '@') then do
ax = ax + 1
af = ''
hasDot = 0
end
else do
if scanWhile(f_s, '0123456789') then
ax = m.f_s.tok
else if ax < 1 then
ax = 1
hasDot = scanLit(f_s, '.')
af = fText(f_s)
end
if \ scanLit(f_s, '%') then
call scanErr f_s, 'missing %'
call scanWhile f_s, '-+ /'
flags = m.f_s.tok
if scanWhile(f_s, '0123456789') then
len = m.f_s.tok
else
len = ''
if \ scanLit(f_s, '.') then
prec = ''
else do
call scanWhile f_s, '0123456789'
prec = m.f_s.tok
end
call scanChar f_s, 1
sp = m.f_s.tok
if ax < 3 | ass.ax == 1 then
aa = 'ggA'ax
else do
aa = 'arg(' || (ax+1) || ')'
if af \== '' then do
cp = cp 'ggA'ax '=' aa';'
aa = 'ggA'ax
ass.ax = 1
end
end
if af \== '' | hasDot then
aa = rxMGet(aa, af)
if sp == 'c' then do
if prec \== '' then
aa = 'substr('aa',' prec')'
if len == '' then
cd = cd '||' aa
else if pos('-', flags) > 0 then
cd = cd '|| lefPad('aa',' len')'
else
cd = cd '|| rigPad('aa',' len')'
end
else if sp == 'C' then do
if prec \== '' then do
cd = cd '|| substr('aa',' prec
if len == '' then
cd = cd')'
else
cd = cd',' len')'
end
else if len == '' then
cd = cd '||' aa
else if pos('-', flags) > 0 then
cd = cd '|| left('aa',' len')'
else
cd = cd '|| right('aa',' len')'
end
else if sp == 'H' then
cd = cd "|| fH("aa"," len',' (pos('-', flags) > 0)')'
else if sp == 'h' then
cd = cd "|| translate(fH("aa", '"siL"'), 'abcdef','ABCDEF')"
else if sp == 'i' then
cd = cd "|| fI("aa"," len", '"flags"'," word(prec 0, 1)")"
else if sp == 'I' then
cd = cd "|| fI("aa"," len", '/"flags"'," word(prec 0, 1)")"
else if sp == 'E' | sp == 'e' then do
if len == '' then
len = 8
if prec = '' then
prec = len - 6
cd = cd "|| fE("aa"," len"," prec", '"sp"', '"flags"')"
end
else if sp = 'S' then
cd = cd '|| strip('aa')'
else if sp = 't' then do
call scanChar f_s, 2
cd = cd '||' fTstGen(m.f_s.tok, aa)
end
else if sp = 'k' then do
call scanChar f_s, 1
if pos(m.f_s.tok, 'tdbBiI') < 1 then
call scanErr f_s, "bad unit type" m.f_s.tok
if pos('+', flags) > 0 then
pl = ", '+'"
else if pos(' ', flags) > 0 then
pl = ", ' '"
else
pl = ''
cd = cd "|| fUnits("aa", '"m.f_s.tok"'," len"," prec pl")"
end
/* else if sp = '(' then do
if af == '' | flags \== '' | len \== 0 | prec \== '' then
call scanErr f_s, "bad call shoud be @sub%("
interpret "cRes = fGen"af"(f_s, ax)"
cd = cd '||' cRes
if \ scanLit(f_s, '%)') then
if \ scanEnd(f_s) then
call scanErr f_s, '%) to end call' af 'expected'
end */
else do
call scanBack f_s, '%'sp
leave
end
end
if cd \== '' then
return strip(cp 'return' substr(cd, 5))
else
return "return ''"
endProcedure fGen
fText: procedure expose m.
parse arg f_s
res = ''
do forever
if scanUntil(f_s, '@%') then
res = res || m.f_s.tok
if \ scanLit(f_s, '%%', '%@') then
return res
res = res || substr(m.f_s.tok, 2)
end
endProcedure fText
fAll: procedure expose m.
parse arg fmt, rdr
i = jOpen(in2File(rdr), '<')
do while jRead(i)
call out f(fmt, m.i)
end
call jClose i
return
endProcedure fAll
/*--- format character2hex (if not sql null) -------------------------*/
fH: procedure expose m.
parse arg v, l, leftJ
if v \== m.sqlNull then
v = c2x(v)
if length(v) > l then
return v
else if leftJ \== 1 then
return right(v, l)
else
return left(v, l)
endProcedure fH
/*--- format integer or fixPoint Decimal -----------------------------*/
fI: procedure expose m.
parse arg v, l, flags, d
if \ datatype(v, 'n') then
return fRigLeft(strip(v), l, flags)
v = format(v, , d, 0)
if pos('+', flags) > 0 then
if \ abbrev(v, '-') then
v = '+'v
if length(v) > l then
if pos('/', flags) > 0 then
return left('', l, '*')
else
return v
return fRigLefPad(v, l, flags)
endProcedure fI
/*--- format with exponent l=total output len
d=number of digits after . in mantissa
c=exponent character
flags: - to ouput text left justified
differences: exponent is always printed but without +
overflow ==> expand exponent, *****, 0e-999 ---------*/
fE: procedure expose m.
parse arg v, l, d, c, flags
if \ datatype(v, 'n') then
return fRigLeft(v, l, flags)
if pos(' ', flags) < 1 then
if v >= 0 then
if pos('+', flags) > 0 then
return '+'substr(fE(v, l, d, c, ' 'flags), 2)
else
return substr(fE(v, l+1, d+1, c, ' 'flags), 2)
x = format(v, 2, d, 7, 0)
m = 2 + d + (d>0)
call assert "length(x) == m+9", 'm x length(x)'
if substr(x, m+1) = '' then
return left(x, m)c || left('', l-m-1, 0)
call assert "substr(x, m+1, 1) == 'E'","exponenent in x not at m"
y = verify(x, '0', 'n', m+3)
call assert 'y>0'
if substr(x, m+1, 2) == 'E+' then do
if m+10-y <= l-m-1 then
return left(x,m)c || right(x, l-m-1)
z = l - 4 - (m+10-y)
end
else if substr(x, m+1, 2) == 'E-' then do
if m+10-y <= l-m-2 then
return left(x,m)c'-'right(x, l-m-2)
z = l - 5 - (m+10-y)
end
else
call err 'bad x' x
if z >= -1 & max(0, z) < d then
return fE(v, l, max(0, z), c, flags)
else if substr(x, m+1, 2) == 'E-' then
return left(x,1)'0'c'-'left('', l-4, 9)
else
return left('', l, '*')
endProcedure fE
/*--- right or left with truncation ----------------------------------*/
fRigLeft: procedure expose m
parse arg s, len, flags
if length(s) = len then
return s
else if pos('-', flags) > 0 | length(s) > len then
return left(s, len)
else
return right(s, len)
endProcedure fRigLefPad
/*--- right or left pad without truncation --------------------------*/
fRigLefPad: procedure expose m
parse arg s, len, flags
if pos('-', flags) > 0 then
if length(strip(s, 't')) >= len then
return strip(s, 't')
else
return left(s, len)
else
if length(strip(s, 'l')) >= len then
return strip(s, 'l')
else
return right(s, len)
endProcedure fRigLefPad
/*--- generate timestamp formats: from format c to format d ----------*/
fTstGen: procedure expose m.
parse arg c 2 d, s
/* special L = LRSN in Hex
l = lrsn (6 or 10 Byte) */
if c == 'L' then
return fTstGen('S'd, 'timeLRSN2LZT('s')')
if c == 'l' then
return fTstGen('S'd, 'timeLRSN2LZT(c2x('s'))')
cd = c || d
if symbol('m.f_tstFo.c') \== 'VAR' ,
| symbol('m.f_tstFo.d') \== 'VAR' then do
if m.f_tstIni == 1 then
call err "bad timestamp from or to format '"cd"'"
m.f_tstIni = 1
a = 'F_TSTFO.'
/* Y: year A = 2010 ...
M: month B=Januar ...,
H: hour A=0 B=10 C=20 D=30 */
m.f_tst_N0 = 'yz345678 hi:mn:st'
m.f_tst_N = 'yz345678 hi:mn:st.abcdef'
m.f_tst_S0 = 'yz34-56-78-hi.mn.st'
m.f_tst_S = 'yz34-56-78-hi.mn.st.abcdef'
call mPut a'S', m.f_tst_S
call mPut a's', m.f_tst_S0
call mPut a' ', m.f_tst_S0
call mPut a'D', 'yz345678'
call mPut a'd', '345678'
call mPut a't', 'hi.mn.st'
call mPut a'T', 'hi:mn:st.abcdef'
call mPut a'E', '78.56.yz34'
call mPut a'e', '78.56.34'
call mPut a'Y', 'YM78'
call mPut a'M', 'M78himns'
call mPut a'A', 'A8himnst'
call mPut a'H', 'Himnst'
call mPut a'n', m.f_tst_N0
call mPut a'N', m.f_tst_N
call mPut a'j', 'jjjjj' /* julian date 34jjj */
call mPut a'J', 'JJJJJJ' /* day since 1.1.00: 6 digits */
call mPut a'l', copies('l', 10) /* LRSN out 10 Byte, input var*/
call mPut a'L', copies('L', 20) /* LRSN in hex */
call mPut a'u', 'uuuuuuuu' /* Unique */
return fTstGen(cd, s)
end
if c == ' ' then do
if pos(d, 'SN') > 0 then
return fTstgFi(m.f_tst_N, m.f_tstFo.d,
, "date('S') time('L')")
else if pos(d, 'sMAn ') > 0 then
return fTstgFi(m.f_tst_N0, m.f_tstFo.d,
, "date('S') time()")
else if pos(d, 'DdEeY') > 0 then
return fTstgFi(mGet('F_TSTFO.D'), m.f_tstFo.d, "date('S')")
else if pos(d, 'tH') > 0 then
return fTstgFi(mGet('F_TSTFO.t'), m.f_tstFo.d, "time()")
else if pos(d, 'T') > 0 then
return fTstgFi(mGet('F_TSTFO.T'), m.f_tstFo.d, "time('L')")
else
call err 'fTstGen implement d='d
end
return fTstgFi(m.f_tstFo.c, m.f_tstFo.d, s)
endProcedure fTstGen
fTstgFi: procedure expose m.
parse arg f, d, s
code = fTstgFF(f, d, s)
if pos('$', code) == lastPos('$', code) ,
| verify(s, '(). ', 'm') < 1 then
return repAll(code, '$', s)
a = fCacheNew()
m.f_gen.a = 'return' repAll(s, '$', 'ggA1')
return "fImm('F_GEN."a"'," s")"
endProcedure fTstFi
fTstgFF: procedure expose m.
parse arg f, t, s
if verify(f, 'lLjJu', 'm') > 0 then do
if f == 'l' then do
if t == 'l' then
return 'timeLrsn10('s')'
else if t == 'L' then
return 'c2x(timeLrsn10('s'))'
else if verify(t, 'lL', 'm') = 0 then
return fTstFi(m.fTst_fo.S, t, 'timeLrsn2LZT('s')')
end
call err 'fTstgFF implement' f 'to' t
end
if symbol('m.F_TSTSCAN') == VAR then
m.f_tstScan = m.f_tstScan + 1
else
m.f_tstScan = 1
a = f_tstScan || m.f_tstScan
call scanSrc a, t
cd = ''
toNull = 'imnstabcdef78'
if verify(f, 'hH', 'm') = 0 then
toNull = toNull'hH'
if verify(f, 'M56', 'm') = 0 then
toNull = toNull'M56'
if verify(f, 'yz34Y', 'm') = 0 then
toNull = toNull'yz34Y'
do while \ scanEnd(a)
c1 = ''
do forever
if scanVerify(a, f' .:-', 'n') then do
c1 = c1 || m.a.tok
end
else if pos(scanLook(a, 1), toNull) > 0 then do
call scanChar a, 1
c1 = c1 || translate(m.a.tok, '00000000000010A?010001?',
, 'imnstabcdef78hHM56yz34Y')
end
else do
if c1 == '' then
nop
else if c1 == f then
c1 = s
else if pos(c1, f) > 0 then
c1 = "substr("s"," pos(c1, f)"," length(c1)")"
else
c1 = "translate('"c1"'," s", '"f"')"
leave
end
end
if c1 \== '' then do
end
else if scanVerify(a, 'yz34Y', 'n') then do
t1 = m.a.tok
if pos('yz34', f) > 0 then
c1 = "substr("s "," pos('yz34', f)", 4)"
else if pos('34', f) > 0 then
c1 = "timeYear24(substr("s "," pos('34', f)", 2))"
else if pos('Y', f) > 0 then
c1 = "timeY2Year(substr("s "," pos('Y', f)", 1))"
if t1 = '34' then
c1 = "substr("c1", 3)"
else if t1 = 'Y' then
c1 = "timeYear2Y("c1")"
end
else if scanVerify(a, '56M', 'n') then do
if m.a.tok == '56' & pos('M', f) > 0 then
c1 = "timeM2Month(substr("s"," pos('M', f)", 1))"
else if m.a.tok == 'M' & pos('56', f) > 0 then
c1 = "timeMonth2M(substr("s"," pos('56', f)", 2))"
end
else if scanVerify(a, 'hiH', 'n') then do
if m.a.tok == 'hi' & pos('Hi', f) > 0 then
c1 = "timeH2Hour(substr("s"," pos('Hi', f)", 2))"
else if m.a.tok == 'Hi' & pos('hi', f) > 0 then
c1 = "timeHour2H(substr("s"," pos('hi', f)", 2))"
end
else if scanLit(a, 'jjjjj') then do
c1 = "time2jul(" fTstGFF(f, 'yz34-56-78', s)")"
end
else if scanLit(a, 'JJJJJJ') then do
c1 = "date('B'," fTstGFF(f, 'yz345678', s)", 's')"
end
else if scanLit(a, copies('l', 10), copies('L', 20),
, 'uuuuuuuu') then do
c1 = "timeLZT2LRSN("fTstGFF(f, m.f_tst_S, s)")"
if abbrev(m.a.tok, 'l') then
c1 = "x2c("c1")"
else if abbrev(m.a.tok, 'u') then
c1 = "timeLrsn2Uniq("c1")"
end
else do
call scanChar a, 1
c1 = "'implement "m.a.tok"'"
/* call err 'implement' */
end
if c1 == '' then
call scanErr a, 'fTstGFF no conversion from' f
cd = cd "||" c1
end
m.f_tstScan = m.f_tstScan - 1
if cd == '' then
return "''"
else
return substr(cd, 5)
endProcedure fTstGFF
fWords: procedure expose m.
parse arg fmt, wrds
f2 = fmt'%#?a%c%#? %#?e%# %& %&a'
if wrds = '' then
return f(f2'%##e')
res = f(f2'%##a', word(wrds, 1))
do wx=2 to words(wrds)
res = res || f(f2, word(wrds, wx))
end
return res
endProcedure fWords
fCat: procedure expose m.
parse arg fmt, st
return fCatFT(fmt, st, 1, m.st.0)
fCatFT: procedure expose m.
parse arg fmt, st, fx, tx
f2 = fmt'%#?a%c%#? %#?e%# %& %&a'
if tx < fx then
return f(f2'%##e')
res = f(f2'%##a', m.st.fx)
do sx=fx+1 to tx
res = res || f(f2, m.st.sx)
end
return res
endProcedure fCatFT
/* copy f end *******************************************************/
/* copy err begin *** errorhandling, messages, help ****************/
errIni: procedure expose m.
if m.err.ini == 1 then
return
m.err.ini = 1
m.err.handler = ''
m.err.handler.0 = 0
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 do
address tso 'profile MsgId' /* brauchen wir in tsoAlloc| */
if sysVar('sysISPF') = 'ACTIVE' then do
m.err.ispf = 1
address ispExec 'vget zScreen shared'
m.err.screen = zScreen
end
end
return
endProcedure errIni
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err.opt, m.err.handler
m.err.handler.0 = 0
if pos('I', translate(m.err.opt)) > 0 & m.err.ispf then
address ispExec 'control errors return'
return
endSubroutine errReset
/* push error handler ------------------------------------------------*/
errHandlerPush: procedure expose m.
parse arg aH
ex = m.err.handler.0 + 1
m.err.handler.0 = ex
m.err.handler.ex = m.err.handler
m.err.handler = aH
return
endProcedure errHandlerPush
/* push error handler return Constant value --------------------------*/
errHandlerPushRet: procedure expose m.
parse arg rv
call errHandlerPush "return '"rv"'"
return
/* pop error handler ------------------------------------------------*/
errHandlerPop: procedure expose m.
if m.err.handler.0 < 1 then
call err 'errHandlerPop but err.handler.0='m.err.handler.0
ex = m.err.handler.0
m.err.handler = m.err.handler.ex
m.err.handler.0 = ex - 1
return
endProcedure errHandlerPop
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
if abbrev(ggOpt, '^') then
return substr(ggOpt, 2)
call errIni
drop err handler cleanup opt call return stackHistory
if ggOpt == '' & m.err.handler <> '' then
interpret m.err.handler
call errSay 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_cat == 'f' then
x = show + stackHistory + by + bad + arithmetic + conversion
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_ddAll') == 'VAR' then
call tsoFree m.tso_ddAll, 1
return
endProcedure errCleanup
/*--- say an errorMessage msg with pref and linesplits --------------*/
errSay: procedure expose m.
parse arg msg
return sayNl(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_cat = 'f'
do while substr(msg, 2, 1) == '}'
parse var msg m.err_cat '}' msg
end
if m.err_cat == ' ' | m.err_cat == 'o' then
return msg
pTxt = ',fatal error,error,input error,scanErr,warning,onlyMsg,'
px = pos(','m.err_cat, pTxt)
if px < 1 then do
px = 1
m.err_cat = 'f'
end
pre = substr(pTxt, px+1, pos(',', pTxt, px+2)-px-1)
if m.err_cat == 's' then
return pre msg
parse source . . s3 . /* current rexx */
return pre 'in' s3':' msg
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
outNL: procedure expose m.
parse arg msg
bx = 1
do lx=1 to 20
ex = pos('\n', msg, bx)
if ex < bx then
leave
call out substr(msg, bx, ex-bx)
bx = ex+2
end
call out substr(msg, bx)
return
endProcedure outNL
/*--- say (part of) the lines of a stem ----------------------------*/
sayNl: procedure expose m.
parse arg msg
bx = 1
do lx=1 to 20
ex = pos('\n', msg, bx)
if ex < bx then
leave
say strip(substr(msg, bx, ex-bx), 't')
bx = ex+2
end
say strip(substr(msg, bx), 't')
return 0
endProcedure sayNl
/*--- 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'
/* 012345678901234567890123456789 */
m.ut_lc = 'abcdefghijklmnopqrstuvwxyz'
m.ut_alfLC = m.ut_lc /* backward compatibility */
m.ut_uc = translate(m.ut_lc)
m.ut_Alfa = m.ut_lc || m.ut_uc
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'+-*/=()¢!{}<> .:,;?|''"%&#@$£\_'
m.ut_ucNum = m.ut_uc || m.ut_digits
m.ut_base64 = m.ut_uc || m.ut_lc || m.ut_digits'+-'
m.ut_alfLC = m.ut_lc /* backward compatibility */
m.ut_alfUC = m.ut_uc /* backward compatibility */
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')
/*--- 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(strip(s, 't')) >= len then
return strip(s, 't')
return left(s, len)
endProcedure lefPad
/*--- right without truncation ---------------------------------------*/
rigPad: procedure expose m
parse arg s, len
if length(strip(s, 'l')) >= len then
return strip(s, 'l')
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_lc, m.ut_uc)
/*--- 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
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
utInter: procedure expose m.
interpret arg(1)
return
endProcedure utInter
/* copy ut end ********************************************************/
}¢--- A540769.WK.REXX(O) cre=2016-08-23 mod=2016-08-23-05.32.51 A540769 --------
/* copy o begin *******************************************************
an object is register for a class in o2c
a class has a list of parents in cParent
a class has a methodTable cMet with lazy initialization
a method generator
otherwise an existing method is simply copied
**********************************************************************/
classInheritsOf: procedure expose m.
parse arg cl, sup
cl = class4name(cl)
sup = class4name(sup)
if m.cl.inheritsOf \== 1 then do
m.cl.inheritsOf = 1
call classInheritsOfAdd cl, cl'.INHERITSOF'
end
return m.cl.inheritsOf.sup == 1
endProcedure classInheritsOf
classInheritsOfAdd: procedure expose m.
parse arg cl, trg, pa
pa = classCycle(cl, pa)
m.trg.cl = 1
call assert "m.cl == 'u'"
do cx=1 to m.cl.0
c1 = m.cl.cx
if m.c1 == 'u' then
call classInheritsOfAdd c1, trg, pa
end
return
endProcedure classInheritsOf
classClear: procedure expose m.
parse arg cl, m
do fx=1 to m.cl.fldd.0
f1 = m || m.cl.fldd.fx
m.f1 = ''
end
return classClearStems(cl, m)
endProcedure classClear
classClearStems: procedure expose m.
parse arg cl, m
do sx=1 to m.cl.stmD.0
s1 = m || m.cl.stmD.sx
m.s1.0 = 0
end
return m
endProcedure classClearStems
classCopy: procedure expose m.
parse arg cl, m, t
do fx=1 to m.cl.fldd.0
ff = m || m.cl.fldd.fx
tf = t || m.cl.fldd.fx
m.tf = m.ff
end
do sx=1 to m.cl.stmD.0
call classCopyStem m.cl.stmD.sx.class,
, m || m.cl.stmD.sx, t || m.cl.stmD.sx
end
return t
endProcedure classCopy
classCopyStem: procedure expose m.
parse arg cl, m, t
m.t.0 = m.m.0
do sx=1 to m.t.0
call classCopy cl, m'.'sx, t'.'sx
end
return 0
endProcedure classCopyStem
/*--- return true if src is a rexxVariable a, m.a.c etc. ------------*/
rxIsVar: procedure expose m.
parse arg src
if pos(left(src, 1), m.ut_rxN1) > 0 then
return 0
else
return verify(src, m.ut_rxId) = 0
endProcedure rxIsVar
/*--- return true if src is a rexxConstant rerpresenting its value --*/
rxIsConst: procedure expose m.
parse arg src, vars c
if \ rxIsVar(src) then
return 0
srU = translate(src)
if srU \== src then
return 0
srU = '.'srU'.'
if pos('.GG', srU) > 0 then
return 0
if vars == '' then
return 1
upper vars
do vx=1 to words(vars)
if pos('.'word(vars, vx)'.', vars) > 0 then
return 0
end
return 1
endProcedure rxIsConst
/*--- return rexx code m.cc or mGet('cc') ---------------------------*/
rxMGet: procedure expose m.
parse arg v1, cc, vars
if cc == '' then
return 'm.'v1
else if rxIsConst(cc, vars) then
return 'm.'v1'.'cc
else
return 'mGet('v1 || quote('.'cc, "'")')'
endProcedure rxMGet
/*--- print object --------------------------------------------------*/
objOut: procedure expose m.
parse m, pr, p1
return classOutDone(m.class_O, m, pr, p1)
/*--- recursively output (with outX:) object a with class t ---------*/
classOut: procedure expose m.
parse arg t, a, pr, p1
return classOutDone(if(t=='',m.class_O, t), a, pr, p1)
/*--- ouput object a with class t and stopper done ------------------*/
classOutDone: procedure expose m. done.
parse arg t, a, pr, p1
if p1 == '' then
p1 = pr
if right(p1, 1) \== ' ' then
p1 = p1' '
if done.ini \== 1 then do
done.ini = 1
t = class4Name(t, t)
p1 = p1'@'a' '
end
if done.t.a == 1 then do;
if t = m.class_o then
t = objClass(a)
return outX(p1'done :'className(t) '@'a)
end
done.t.a = 1
if t = m.class_O then do
if a == '' then
return outX(p1'obj null')
t = objClass(a)
if t = m.class_N | t = m.class_S then
return outX(p1'obj has no class @'m.a)
else
return classOutDone(t, a, pr, p1'isA')
end
if t == m.class_V then
return outX(p1'=' m.a)
if t == m.class_W == 'w' then
return outX(p1'}' substr(a, 2))
if m.t == 'f' then
return classOutDone(m.t.1, a'.'m.t.name, pr, p1'.'m.t.name)
if m.t == 'r' then do
if m.a == '' then
return outX(p1'refTo :'className(m.t.1) '@null@')
else
return classOutDone(m.t.1, m.a, pr,
, p1'refTo @'m.a)
end
if m.t = 'u' then do
t1 = m.t.1
vv = m.t.0 > 0 & m.t.1 == m.class_V
call outX p1 || if(m.t.name == '', 'union', ':'m.t.name),
|| copies(' =' m.a, vv)
do ux=1+vv to m.t.0
call classOutDone m.t.ux, a, pr' '
end
return 0
end
if m.t = 's' then do
call outX p1'stem' m.a.0
do ux=1 to m.a.0
call classOutDone m.t.1, a'.'ux, pr' ', pr' .'ux
end
return 0
end
if m.t = 'c' then do
if m.t.name = m.a then
call classOutDone m.t.1, a, pr, p1'choice' m.a
return 0
end
if m.t = 'm' then
return 0
return err('bad class type' m.t)
endProcedure classOutDone
/*--- mutate and reset an object for a class -----------------------*/
oReset: procedure expose m.
parse arg m, cl, arg, arg2
interpret classMet(class4name(cl), 'oReset')
return m
endProcedure oReset
/*--- create an an object of the class cl and reset it --------------*/
oNew: procedure expose m.
parse arg cl, arg, arg2
interpret classMet(class4name(cl), 'new')
return m
endProcedure oNew
/*--- return the class of object obj --------------------------------*/
objClass: procedure expose m.
parse arg m
if arg() > 1 then
return err('old objClass') / 0
if symbol('m.o.o2c.m') == 'VAR' then
return m.o.o2c.m
else if abbrev(m, m.o_escW) then
return m.class_w
else if m \== '' then
return m.class_S
else
return m.class_N
endProcedure objClass
oKindOf: procedure expose m.
parse arg obj, sup
return classInheritsOf(objClass(obj), sup)
/*--- return the code of method met of object m ---------------------*/
objMet: procedure expose m.
parse arg m, met
if symbol('m.o.o2c.m') == 'VAR' then
cl = m.o.o2c.m
else if abbrev(m, m.o_escW) then
cl = m.class_w
else if m \== '' then
cl = m.class_S
else
cl = m.class_N
if symbol('m.cl.method.met') == 'VAR' then
return m.cl.method.met
else
return classMet(cl, met) /* will do lazy initialisation */
endProcedure objMet
/*--- return true if obj is kind of string -------------------------*/
oKindOfString: procedure expose m.
parse arg obj
return objMet(obj, 'oKindOfString')
/*--- if obj is kindOfString return string
otherwise return arg(2) or fail ---------------------------*/
oAsString: procedure expose m.
parse arg m
interpret objMet(m, 'oAsString')
/*--- return the stem of fieldnames of object m ---------------------*/
oFlds: procedure expose m.
parse arg m
return objMet(m, 'oFlds')
endProcedure oFlds
oFldD: procedure expose m.
parse arg m
return objMet(m, 'oFldD')
endProcedure oFlds
oClear: procedure expose m.
parse arg m
interpret objMet(m, 'oClear')
return m
endProcedure oClear
/*--- copy object m of class cl to t --------------------------------*/
oClaCopy: procedure expose m.
parse arg cl, m, t
interpret "drop cl;" classMet(cl, 'oCopy')
endProcedure oClaCopy
/*--- copy object m to t / create a new object if t=='' -------------*/
oCopy: procedure expose m.
parse arg m, t
interpret objMet(m, 'oCopy')
endProcedure oCopy
oCopyGen: procedure expose m.
parse arg cl
if cl == m.class_N | cl == m.class_S | cl == m.class_W then
return 'return m'
call classMet cl, 'new'
do sx=1 to m.cl.stms.0
s1 = m.cl.stms.sx
call classMet m.cl.s2c.s1, 'oCopy'
end
return "if t=='' then t = mNew('"cl"');" ,
"call oMutate t, '"cl"';" ,
"return classCopy('"cl"', m, t)"
endProcedure oCopyGen
/*--- return a new instance of a subclass of Run
with code code in method oRun -------------------------------*/
oRunner: procedure expose m.
parse arg code
return oNew(classNew('n* ORun u ORun, m oRun' code))
endProcedure oRunner
/*--- run method oRun of object m -----------------------------------*/
oRun: procedure expose m.
parse arg m, arg, arg2
interpret objMet(m, 'oRun')
return
endProcedure oRun
/*--- run method oRun of object m No Procedure:
??? optimize: class only run ???
use from caller unprotected---------------------------------*/
oRunNP: procedure expose m.
interpret objMet(arg(1), 'oRun')
return
endProcedure oRunNP
/*--- run method oRun and return output in new JBuf -----------------*/
oRun2File: procedure expose m.
parse arg rn
b = jBuf()
call pipe '+F' , b
call oRun rn
call pipe '-'
return b
endProcedure oRun2File
/*--- cast the object to a file -------------------------------------*/
o2File: procedure expose m.
parse arg m
interpret objMet(m, 'o2File')
call err 'o2file did not return' / 0
endProcedure o2File
/*--- cast the object to a String -----------------------------------*/
o2String: procedure expose m.
parse arg m, fmt
if arg() = 1 then
fmt = ' '
interpret objMet(m, 'o2String')
return err('o2String did not return')
endProcedure o2String
/*--- return a short string representation of an object o=¢...! -----*/
o2Text: procedure expose m.
parse arg m, maxL, fmt
if maxL == '' then
maxL = 75
interpret objMet(m, 'o2Text')
endProcedure o2Text
/*--- return a short string representation of the fields of an obj --*/
o2TexLR: procedure expose m.
parse arg m, maxL, le, ri
if maxL == '' then
maxL = 75
interpret objMet(m, 'o2TexLR')
endProcedure o2TexLR
o2TextFlds: procedure expose m.
parse arg m, cl, maxL
maxL = maxL - 3
r = ''
do fx=1 to m.cl.fldd.0
c1 = m.cl.fldd.fx.class
r = r || left(' ', fx > 1)substr(m.cl.fldd.fx, 2)
if c1 = m.class_V then
r = r'='
else if m.c1 == 'r' then
r = r'=>'
else
r = r'=?'c1'?'
a1 = m || m.cl.fldd.fx
r = r || m.a1
if length(r) > maxL then
return left(r, maxL)'...'
end
return r
endProcedure o2TextFlds
o2TextGen: procedure expose m.
parse arg cl, le, ri
m1 = classMet(cl, 'o2String', '-')
if m1 \== '-' then do
if translate(word(m1, 1)) \== 'RETURN' then
call err 'o2TextGen' className(cl)'#o2String return?:' m1
return '__r = strip('subword(m1, 2)', "t");',
'if length(__r) <= maxL then return __r;' ,
'else return left(__r, maxL-3)"..."'
end
call classMet cl, 'oFlds'
if le = '' & ri = '' then
return "return o2TextFlds(m, '"cl"', maxL)"
else
return "return" le "|| o2TextFlds(m, '"cl"'" ,
", maxL - length("le") - length("ri")) || "ri
endProcedure o2TextGen
o2TextStem: procedure expose m.
parse arg st, to, maxL
do sx=1 to m.st.0
m.to.sx = o2Text(m.st.sx, maxL)
end
m.to.0 = m.st.0
return to
endProcedure o2TextStem
/*--- cast a String to an object -----------------------------------*/
s2o: procedure expose m.
parse arg str
return m.o_escW || str
endProcedure s2o
/* copy o end ********************************************************/
}¢--- A540769.WK.REXX(OUT) cre=2009-11-03 mod=2015-07-06-12.31.00 A540769 ------
/* copy out begin ******************************************************
out interface simple with say only
***********************************************************************/
/*--- output a message to the current destination -------------------*/
out: procedure expose m.
parse arg msg
say msg
return
endProcedure out
/* copy out end *****************************************************/
}¢--- A540769.WK.REXX(PATRICE) cre=2010-11-04 mod=2010-11-04-10.47.38 A540769 ---
call sqlConnect 'DBAF'
r = sqlPreAllCl(1, "select name from sysibm.sysdatabase" ,
"where name like 'DA%'" ,
"order by name",
, st, ":m.st.sx.db")
say r
do y=1 to 3
say m.st.y.db
end
call sqlDisconnect
exit
/* copy sql begin ***************************************************
sql interface
***********************************************************************/
sqlIni: procedure expose m.
m.sqlNull = '---'
return
endProcedure sqlIni
/*--- prepare statement 's'cx from sql src into descriptor desc ------*/
sqlPrepare: procedure expose m.
parse arg cx, src, descOut, descInp
s = ''
if descOut == 1 then
s = 'into :M.SQL.'cx'.D'
call sqlExec 'prepare s'cx s 'from :src'
if descInp == 1 | (descInp == '' & pos('?', src) > 0) then
call sqlExec 'describe input s'cx 'into :M.SQL.'cx'.I'
else
m.sql.cx.i.sqlD = 0
return
endProcedure
/*--- prepare and declare 'c'cx from sql src -------------------------*/
sqlPreDeclare: procedure expose m.
parse arg cx, src, descOut, descInp
call sqlPrepare cx, src, descOut, descInp
call sqlExec 'declare c'cx 'cursor for s'cx
return
endProcedure sqlPreDeclare
/*--- prepare, declare and open 'c'cx from sql src -------------------*/
sqlPreOpen: procedure expose m.
parse arg cx, src, descOut, descInp
call sqlPreDeclare cx, src, descOut, descInp
call sqlOpen cx
return
endProcedure sqlPreOpen
/*--- open cursor 'c'cx using arguments arg(2), arg(3)... ------------*/
sqlOpen: procedure expose m.
parse arg cx
do ix=1 to arg()-1
call sqlDataSet 'SQL.'cx'.I', ix, arg(ix+1)
end
call sqlExec 'open c'cx 'using descriptor :M.SQL.'cx'.I'
return
endProcedure sqlOpen
/*--- close cursor 'c'cx ---------------------------------------------*/
sqlClose: procedure expose m.
parse arg cx, src
return sqlExec('close c'cx)
endProcedure sqlClose
/*--- fetch cursor 'c'cx into variables ggVars -----------------------*/
sqlFetchInto:
parse arg ggCx, ggVars
if ggVars == '' then
ggVars = 'descriptor :M.SQL.'ggCX'.D'
/* accept sqlCodes > 0 except 100 */
return sqlExec('fetch c'ggCx 'into' ggVars, 0 100) <> 100
endProcedure sqlFetchInto
/*--- return sql variable list for stem st and fields the word in vars
if withInd == 1 then with sqlIndicator variables
sqlVars('S', 'A B') --> ':S.A, :S.B'
sqlVars('S', 'A B', 1) --> ':S.A :S.A.SQLIND, :S.B :S.B.SQLIND'
----------------------------------------------------------------------*/
sqlVars: procedure expose m.
parse arg st, vars, withInd
res = ''
if st ^== '' then
st = st'.'
do ix=1 to words(vars)
res = res', :'st || word(vars, ix)
if withInd == 1 then
res = res ':'st || word(vars, ix)'.SQLIND'
end
return substr(res, 3)
endProcedure sqlVars
sqlVarsNull: procedure expose m.
parse arg st, vars
hasNulls = 0
do ix = 1 to words(vars)
fld = word(vars, ix)
if m.st.fld.sqlInd < 0 then do
m.st.fld = m.sqlNull
hasNulls = 1
end
end
return hasNulls
endProcedure sqlVarsNull
sqlDescNull: procedure expose m.
parse arg cx
desc = 'SQL.'ggCX'.D',
hasNulls = 0
do ix=1 to m.desc.SQLD
if m.desc.ix.sqlInd < 0 then do
m.desc.ix.sqlData = m.sqlNull
hasNulls = 1
end
end
return hasNulls
endProcedure sqlDescNull
/*--- open cursor 'c'cx fetch all into variables vars and close
st = passed stem, sx = row number
return number of rows fetched ----------------------------------*/
sqlOpAllCl:
parse arg ggCx, st, ggVars
do ggAx=4 to arg()
call sqlDataSet 'SQL.'ggCx'.I', ggAx-3, arg(ggAx)
end
call sqlOpen ggCx
do sx = 1 while sqlFetchInto(ggCx, ggVars)
end
m.st.0 = sx - 1
call sqlClose ggCx
return m.st.0
endProcedure sqlOpAllCl
sqlDataSet: procedure expose m.
parse arg da, ix, val
m.da.ix.sqlData = val
m.da.ix.sqlInd = - (arg(ix+2) == m.sqlNull)
return
endProcedure sqlDataSet
/*--- prepare, declare open cursor 'c'cx, fetch all and close
return number of rows fetched ----------------------------------*/
sqlPreAllCl:
parse arg ggCx, ggSrc, st, ggVars
call sqlPreDeclare ggCx, ggSrc
return sqlOpAllCl(ggCx, st, ggVars)
endProcedure sqlPreAllCl
/*--- execute statement 's'cx using arguments arg(2), arg(3)... ------*/
sqlExecute:
parse arg ggCx retOk
do ggAx=2 to arg()
call sqlDataSet 'SQL.'ggCx'.I', ggAx-1, arg(ggAx)
end
return sqlExec('execute s'ggCx 'using descriptor :M.SQL.'ggCx'.I',
, retOk)
endProcedure
/*--- execute immediate the sql src ----------------------------------*/
sqlExImm:
parse arg ggSrc, ggRet
return sqlExec('execute immediate :ggSrc', ggRet)
endProcedure sqlExImm
sqlCommit: procedure expose m.
parse arg src
return sqlExec('commit')
endProcedure sqlCommit
/*--- execute sql thru the dsnRexx interface -------------------------*/
sqlExec: /* no procedure, to keep variables sql... */
parse arg ggSqlStmt, ggRet, ggNo
if ggNo <> '1' then
ggSqlStmt = 'execSql' ggSqlStmt
address dsnRexx ggSqlStmt
/* say 'sqlCode' sqlCode 'rc' rc 'for' ggSqlStmt ggNo */
if rc = 0 then
return 0
else if ggRet = '*' | wordPos(sqlCode, ggRet) > 0 then
return sqlCode
else if rc < 0 then
call err sqlmsg()
else if sqlWarn.0 ^== ' ' | sqlCode <> 0 then
call errSay sqlMsg(), ,'w'
return sqlCode
endSubroutine sqlExec
/*--- connect to the db2 subsystem ggSys -----------------------------*/
sqlConnect: procedure expose m.
parse arg ggSys, ggRetCon
call sqlIni
address tso "SUBCOM DSNREXX"
if rc <> 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
if ggSys = '-' then
return 0
return sqlExec("connect" ggSys, ggRetCon ,1)
endProcedure sqlConnect
/*--- diconnect from db2 ---------------------------------------------*/
sqlDisconnect: procedure expose m.
parse arg ggRet
return sqlExec("disconnect ", ggRet, 1)
endProcedure sqlDisconnect
/*--- issue an sql error message -------------------------------------*/
sqlMsg: /* no procedure, to keep variables sql... */
signal on syntax name sqlMsgOnSyntax
ggRes = 'sqlCode' sqlCodeT(sqlCode, sqlErrMc, sqlwarn.0':' ,
|| sqlwarn.1||sqlwarn.2||sqlwarn.3||sqlwarn.4||sqlwarn.5',',
|| sqlwarn.6||sqlwarn.7||sqlwarn.8||sqlwarn.9||sqlwarn.10)
if 0 then
sqlMsgOnSyntax: do
ggRes = 'sqlCode' sqlCode translate(sqlErrMc, ',', 'ff'x),
'<<rexx sqlCodeT not found or syntax>>\nwarnings'
do ggX=0 to 10
if sqlWarn.ggx <> '' then
ggRes = ggRes ggx'='sqlWarn.ggx
end
end
signal off syntax
ggRes = ggRes'\nstate' sqlState'\nstmt = ' ggSqlStmt
ggPref = '\nwith'
ggXX = pos(':', ggSqlStmt)+1
do 12 while ggXX > 1
ggYY = verify(ggSqlStmt, ' ,:+-*/&%?|()¢!', 'm', ggXX)
if ggYY < 1 then
ggYY = length(ggSqlStmt) + 1
ggVar = substr(ggSqlStmt, ggXX, ggYY - ggXX)
if ggVar <> '' then do
ggRes = ggRes || ggPref ggVar '=' value(ggVar)
ggPref = '\n '
end
ggXX = pos(':', ggSqlStmt, ggYY+1) + 1
end
return ggRes
endSubroutine sqlMsg
/*--- send a command to db2 through the TSO dsn processor ------------*/
sqlDsn: procedure expose m.
parse arg st, sys, cmd, rcOk
x = outtrap('M.'st'.')
push 'END'
push cmd
address tso 'DSN SYSTEM('sys')'
rr = rc
x = outtrap(off)
if rr = 0 | rcOk = '*' | wordPos(rr, rcOk) > 0 then
return rr
fl = max(1, m.st.0 - 10)
em = 'rc' rr 'for DSN SYSTEM('sys') cmd' cmd,
'\nOuputlines' fl '-' m.st.0':'
do lx=fl to m.st.0
em = em '\n' strip(m.st.lx, 't')
end
call err em
endProcedure sqlDsn
/* copy sql end **************************************************/
/* copy err begin ******************************************************
messages, errorhandling,help
***********************************************************************/
errIni: procedure expose m.
if m.err.ini == 1 then
return
call outIni
m.err.ini = 1
m.err.handler = ''
m.err.cleanup = ';'
m.err.opt = ''
return
endProcedure errIni
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err.opt, m.err.handler
if pos('I', translate(m.err.opt)) > 0 then
if sysVar('sysISPF') = 'ACTIVE' then
call adrIsp 'control errors return'
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
call errIni
drop err handler cleanup opt call return
if ggOpt == '' & m.err.handler \== '' then do
if 1 then do /* no detection of recursive err call loop
--> will anyway fail by stack overflow */
interpret m.err.handler
end
else do
/* avoid recursive err call loop */
drop call return
if symbol('m.err.call') \== 'VAR' then
m.err.call = 1
else
m.err.call = m.err.call + 1
if m.err.call > 10 then do
say 'errHandler loop:' m.err.handler
end
else do
m.err.return = 1
call errInterpret m.err.handler
m.err.call = m.err.call - 1
if m.err.return then
return result
end
end
end
call outPush
call errSay ggTxt, 'e'
call errCleanup
if ggOpt == '' then
ggOpt = m.err.opt
ggOpt = translate(ggOpt)
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 then do
call errSay 'divide by zero to show stackHistory', 'e'
x = 1 / 0
end
call errSay 'exit(12)', 'e'
exit errSetRc(12)
endSubroutine err
errAddCleanup: procedure expose m.
parse arg code
if m.err.ini \== 1 then
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
if m.err.ini \== 1 then
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
cl = m.err.cleanup
if cl = ';' then
return
m.err.cleanup = ';'
call out 'err cleanup begin' cl
call errInterpret cl
call out 'err cleanup end' cl
return
endProcedure errCleanup
errInterpret: procedure expose m.
parse arg code
interpret code
m.err.return = 0
return
endProcedure errInterpret
/*--- assert that the passed rexx expression evaluates to true -------*/
assert:
interpret 'assertRes =' arg(1)
if \ assertRes then
call err 'assert failed' arg(1)':' arg(2)
return
endProcedure assert
/*--- output an errorMessage msg with pref pref
split message in lines at '/n' ---------------------------*/
errSay: procedure expose m.
parse arg msg, pref
parse source . . ggS3 . /* current rexx */
if pref == 'e' then
msg = 'fatal error in' ggS3':' msg
else if pref == 'w' then
msg = 'warning in' ggS3':' msg
else if pref \== '' then
msg = pref':' msg
return outNl(msg)
endProcedure errSay
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg, op
call errSay msg, 'e'
call help
call err msg, op
endProcedure errHelp
/*--- return the Operating System we are running on: TSO or LINUX ---*/
errOS: procedure expose m.
parse source os .
return os
endProcedure errOS
/*--- set rc for ispf: -------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared varible 3IspfRc
back as return code
----------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- output a trace message if m.tr is set -----------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
call out 'debug' msg
return
endProcedure debug
/*--- return current time and cpu usage ------------------------------*/
timing: procedure expose m.
return return time() 'ela='time('E') 'cpu='sysvar('syscpu'),
'su='sysvar('syssrv')
timingTest: procedure expose m.
say 'begin' timing() sysvar('sysnode')
do 30000000
end
say 'end ' timing()
return
/*--- display the first comment block of the source as help ----------*/
help: procedure expose m.
parse source . . s3 .
call out right(' help for rexx' s3, 79, '*')
do lx=1 by 1
if pos('/*', sourceLine(lx)) > 0 then
leave
else if lx > 10 then do
call out '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
call out li
end
call out right(' end help for rexx' s3, 79, '*')
return 4
endProcedure help
/*--- output all lines (separated by '\n') of all args --------------*/
outNl: procedure expose m.
do ax=1 to max(1, arg())
msg = arg(ax)
sx = 0
bx = -1
do lx=1 until bx >= length(msg)
ex = pos('\n', msg, bx+2)
if ex < 1 then
ex = length(msg)+1
call out substr(msg, bx+2, ex-bx-2)
bx = ex
end
end
return 0
endProcedure outNl
/*--- 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
/*--- if function ----------------------------------------------------*/
if: procedure expose m.
parse arg co, ifTrue, ifFalse
if co then
return ifTrue
else
return ifFalse
endProcedure if
/* copy err end *****************************************************/
/* copy out begin ******************************************************
out interface with simplistic implementation
***********************************************************************/
outIni: procedure expose m.
parse arg msg
if m.out.ini == 1 then
return
m.out.ini = 1
m.out.dst = ''
return
endProcedure outIni
/*--- output a message to the current destination -------------------*/
out: procedure expose m.
parse arg msg
if m.out.ini \== 1 then
call outIni
if m.out.dst == '' then do
say msg
end
else do
st = m.out.dst
sx = m.st.0 + 1
m.st.0 = sx
m.st.sx = msg
end
return 0
endProcedure out
/*--- push an out destination ---------------------------------------*/
outPush: procedure expose m.
parse arg m.out.dst
return
endProcedure outPush
/* copy out end *****************************************************/
}¢--- A540769.WK.REXX(PDSTOSEQ) cre=2013-02-09 mod=2013-02-09-23.00.27 A540769 ---
/*REXX******************************** begin member getmem *****
callable find members interface */
/* trace ?R */
arg mArg
/* call adrTsoRc 'execio 0 diskr outDD1 (finis)'
call adrTso 'free dd(outDD1)'
/
call des 'tmp.text(ser1)'
exit */
call showTime('start')
llq = 'PLI'
call serOpen 'tmp.text(ser1)'
call serPds 'wk.rexx', '*'
/* call serPds 'wk.pli', '*' */
call serClose
exit
serPds:
parse arg serPds, serMask
call gmIni , serPds, serMask
now = date('s') Time('n')
call serBegin 'pds', serPds now
do while (gmNext() <> '')
call serBegin 'mbr', gmMbr
call serDD serPds'('strip(gmMbr)')'
call serEnd 'mbr', gmMbr
end
call serEnd 'pds', serPds now
call showTime('serPds end' serPds)
return /* end serPds */
serDD:
parse arg serDsn
call adrTso 'alloc dd(serDD2) shr dsn('serDsn')'
do forever
serRc2 = adrTsoRc('execio 100 diskr serDD2 (stem st2.)')
if serRc2 <> 0 & serRc2 <> 2 then
call err 'bad rc' serRc2 'for tso execio 1 diskr serDD2'
call serStem st2.0, 'st2.'
if serRc2 <> 0 then
leave
end
call adrTsoRc 'execio 0 diskr serDD2 (finis)'
call adrTso 'free dd(serDD2)'
return /* end serDD */
out: procedure
parse arg typ, text
select;
when typ = '=' then do;
if left(text, length(serMark)) = serMark then
call out1 serMark 'data 1'
call out1 text
end
when left(typ, 1) = '(' then
call out1 serMark 'begin' substr(typ, 2) text
when left(typ, 1) = ')' then
call out1 serMark 'end' substr(typ, 2) text
when typ = '$alloc' then
call adrTso 'alloc dd(outDD) shr dsn('text')'
when typ = '$free' then do
call adrTso 'execio 0 diskw outDD (finis)'
call adrTso 'free dd(outDD)'
end
otherwise call err 'bad typ "' typ '" in out, text' text
end
return /* end out */
serBegin: procedure expose serMark
parse arg typ, name
call serOut serMark 'begin' typ name
return
serEnd: procedure expose serMark
parse arg typ, name
call serOut serMark 'end ' typ name
return
serOpen:
parse arg serOutDsn
serMark = '(((>>>'
call adrTso 'alloc dd(serOutDD) shr dsn('serOutDsn')'
return
serClose: procedure
call adrTso 'execio 0 diskw serOutDD (finis)'
call adrTso 'free dd(serOutDD)'
call showTime('serClose' serOutDsn)
return
serOut: procedure
parse arg line1
call adrTso 'execio 1 diskw serOutDD (stem line)'
return
serStem:
parse arg serCnt, serStem
call adrTso 'execio' serCnt 'diskw serOutDD (stem' serStem')'
return
des:
parse arg desInDsn
desMark = '(((>>> '
call adrTso 'alloc dd(desInDD) shr dsn('desInDsn')'
do forever
desRc = adrTsoRc('execio 100 diskr desInDD (stem des.)')
if desRc <> 0 & desRc <> 2 then
call err 'bad rc' desRc 'for tso execio 100 diskr serInDD'
desIx = 1
do while desIx < des.0
if left(des.desIx, length(desMark)) = desMark then do
desW2 = word(des.desIx, 2)
if desW2 = 'begin' then
call desBegin subWord(des,desIx, 3)
else if desW2 = 'end' then
call desEnd subWord(des,desIx, 3)
else
call err 'bad desW2' desW2 'in' des.desIx
desIx = desIx + 1
end
else do
do dexIx = 1 by 1
dex.dexIx = des.desIx
desIx = desIx + 1
if left(des.desIx, length(desMark)) = desMark then
leave
end
call desStem dexIx, 'dex.'
end
end
if desRc <> 0 then
leave
end
call adrTsoRc 'execio 0 diskr desInDD (finis)'
call adrTso 'free dd(desInDD)'
return /* end des */
desBegin: procedure
parse arg name text
say 'desBegin' name',' text
return
desEnd: procedure
parse arg name text
say 'desEnd' name',' text
return
desStem:
parse arg desCnt, desSt2
say 'desStem' desCnt desSt2':' left(value(desSt2'.1'), 50)
return
outMbr: /* example for lmm services, but too slow| */
parse arg outId, outMbr
call adrIsp 'lmmfind dataid(&'outId') member('outMbr')'
call out '(mbr', outMbr
outCnt = 0
do forever
outRc = adrIspRc('lmget dataid(&'outId')' ,
'mode(invar) dataloc(outRec)' ,
'maxLen(99999) datalen(outLen)')
if outRc = 0 then do
outCnt = outCnt + 1
call out '=', outRec
end
else if outRc = 8 then
leave
else
call err 'rc' outRc 'for isp lmget dataid(&'outId')'
end
call out ')mbr', outMbr outCnt
return /* outMbr */
gmIni:
parse arg gmSuf, gmDsn, gmPat
call adrTso "ALLOC DS("gmDsn") F(gmDD"gmSuf") REU SHR "
call adrIsp "LMINIT DATAID(gmII"gmSuf") DATASET("gmDSN") ENQ(SHRW)"
call adrIsp "LMOPEN DATAID(&gmII"gmSuf") OPTION(INPUT) "
if gmOpt = '' then
gmX = value('gmPP'gmSuf, '')
else
gmX = value('gmPP'gmSuf, 'pattern('gmPat')')
say 'gmPat' gmPat '=> gmPP'gmSuf '=' value('gmPP'gmSuf)
return; /* end gmIni */
gmFree:
parse arg gmSuf
if adrIspRc("LMMLIST DATAID(&gmII"gmSuf") option(free)") <> 0 then
if rc <> 8 then
call err "rc" rc "for isp" ,
"LMMLIST DATAID(&gmII"gmSuf") option(free)"
call adrIsp "LMCLOSE DATAID(&gmII"gmSuf")"
call adrIsp "LMFREE DATAID(&gmII"gmSuf")"
call adrTso "free f(gmDD"gmSuf")"
return /* end gmFree */
gmNext:
parse arg gmSuf
gmMbr = ''
gmRc = adrIspRc("LMMLIST DATAID(&gmII"gmSuf")" ,
"OPTION(LIST) MEMBER(gmMbr)" value('gmPP'gmSuf))
if gmRc <> 0 then
if gmRc <> 8 & gmRC <> 4 then
call err "adrIsp RC" gmRc "for" ,
"LMMLIST DATAID(&gmII"gmSuf")" ,
"OPTION(LIST) MEMBER(gmMbr)"
return gmMbr /* end gmNext */
showMbr:
parse arg shId, shMbr
call adrIsp 'lmmfind dataid(&'shId') member('shMbr') lrecl(lrecl)'
say 'lmmFind' shMbr 'lRecl' lRecl
do i=1 to 10
call adrIsp 'lmget dataid(&'shId') mode(invar) dataloc(rec)',
'datalen(recLen) maxlen('lrecl')'
say i 'len' recLen':' rec
end
return /* showMbr */
showTime:
parse arg showmsg
say time() sysvar('syscpu') sysvar('syssrv') showmsg
return 0
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
say 'fatal error in ??:' txt
exit 12
}¢--- A540769.WK.REXX(PERRUT) cre=2011-02-08 mod=2011-02-08-14.59.50 A540769 ---
select
insert
}¢--- A540769.WK.REXX(PIPE) cre=2016-09-09 mod=2016-09-09-07.55.45 A540769 -----
/* copy pipe begin ****************************************************
**********************************************************************/
pipeIni: procedure expose m.
if m.pipe_ini == 1 then
return
m.pipe_ini = 1
call catIni
call mapReset v
m.v_with.0 = 0
m.v_withMap = ''
m.v_with.0.map = ''
m.pipe.0 = 1
m.pipe.1.in = m.j.in
m.pipe.1.out = m.j.out
call pipe '+'
return
endProcedure pipeIni
/*-------------------------------
+- push pop frame
PYNFA ouput: Parent saY Newcat File, Appendtofile
psf| input: parent string file oldOut
old --> new
pipeBegin --> pipe '+N'
pipeBeLa f --> pipe '+F'
pipeLast --> pipe 'P|'
pipeLast f --> pipe 'F|', f
pipeEnd --> pipe '-'
--------------------------------*/
pipe: procedure expose m.
parse arg opts, aO
ox = 1; oc = substr(opts, ox, 1)
ax = m.pipe.0
px = ax -1
if oc == '-' then do
if px < 2 then
call err 'pipe pop empty'
call jClose m.pipe.ax.out
call jClose m.pipe.ax.in
ax = px
m.pipe.0 = ax
px = ax-1
ox = ox+1; oc = substr(opts, ox, 1)
end
if oc == '+' then do
px = ax
ax = ax+ 1
m.pipe.0 = ax
m.pipe.ax.in = jOpen(m.pipe.px.in, '<')
m.pipe.ax.out = jOpen(m.pipe.px.out, '>')
ox = ox+1; oc = substr(opts, ox, 1)
end
oOut = m.pipe.ax.out
if pos(oc, 'NYPFA') > 0 then do
call jClose oOut
if oc == 'Y' then
m.pipe.ax.out = jOpen(m.pipe.1.out, '>')
else if oc == 'P' then
m.pipe.ax.out = jOpen(m.pipe.px.out, '>')
else if oc == 'N' then
m.pipe.ax.out = jOpen(Cat(), '>')
else if oc == 'F' then
m.pipe.ax.out = jOpen(o2file(aO), '>')
else if oc == 'A' then
m.pipe.ax.out = jOpen(o2file(aO), '>>')
ox = ox+1; oc = substr(opts, ox, 1)
end
m.j.out = m.pipe.ax.out
if oc \== ' ' then do
call jClose m.pipe.ax.in
if substr(opts, ox+1) = '' & oc \== 's' then
ct = ''
else
ct = jOpen(Cat(), '>')
lx = 3
do forever
if oc == 's' then do
call jWrite ct, arg(lx)
lx = lx + 1
end
else do
if oc == 'p' then
i1 = m.pipe.px.in
else if oc == '|' then
i1 = oOut
else if oc == 'f' then do
i1 = arg(lx)
lx = lx + 1
end
else
call err 'implement' oc 'in pipe' opts
if ct \== '' then
call jWriteAll ct, o2File(i1)
end
ox = ox + 1
if substr(opts, ox, 1) == ' ' then
leave
else if ct == '' then
call err 'pipe loop but ct empty'
else
oc = substr(opts, ox, 1)
end
if ct == '' then
m.pipe.ax.in = jOpen(o2file(i1), '<')
else
m.pipe.ax.in = jOpen(jClose(ct), '<')
if lx > 3 & lx <> arg() + 1 then
call err 'pipe opts' opts 'but' arg() 'args not' (lx-1)
end
m.j.in = m.pipe.ax.in
return
endProcedure pipe
/*--- write all from rdr (rsp in) to out, not lazy ----------------*/
pipeWriteNow: procedure expose m.
parse arg rdr
call jWriteNow m.j.out, if(rdr == '', m.j.in, rdr)
return
endProcedure pipeWriteNow
/*--- write all from rdr (rsp in) to out, possibly lazy -----------*/
pipeWriteAll: procedure expose m.
parse arg rdr
call jWriteAll m.j.out, if(rdr == '', m.j.in, rdr)
return
endProcedure pipeWriteAll
pipePreSuf: procedure expose m.
parse arg le, ri
do while in()
call out le || m.in || ri
end
return
endProcedure pipePreSuf
vIsDefined: procedure expose m.
parse arg na
return '' \== vAdr(na, 'g')
endProcedure vIsDefined
vWith: procedure expose m.
parse arg fun, o
if fun == '-' then do
tBe = m.v_with.0
tos = tBe - 1
if tos < 0 then
call err 'pop empty withStack'
m.v_with.0 = tos
m.v_withMap = m.v_with.tos.map
return m.v_with.tBe.obj
end
else if fun \== '+' then
call err 'bad fun vWith('fun',' o')'
par = m.v_with.0
tos = par + 1
m.v_with.0 = tos
if symbol('m.v_with.tos.obj') == 'VAR' then
if objClass(o) == objClass(m.v_with.tos.obj) then do
m.v_with.tos.obj = o
m.v_withMap = m.v_with.tos.map
return
end
m.v_with.tos.obj = o
if par > 0 then
key = m.v_with.par.classes
else
key = ''
if o \== '' then
key = strip(key objClass(o))
m.v_with.tos.classes = key
if symbol('m.v_withManager.key') == 'VAR' then do
m.v_with.tos.map = m.v_withManager.key
m.v_withMap = m.v_withManager.key
return
end
m = mapNew()
m.v_with.tos.map = m
m.v_withMap = m
m.v_withManager.key = m
do kx=1 to words(key)
c1 = word(key, kx)
call vWithAdd m, kx, classMet(c1, 'oFlds')
call vWithAdd m, kx, classMet(c1, 'stms')
end
return
endProcedure vWith
vWithAdd: procedure expose m.
parse arg m, kx, ff
do fx=1 to m.ff.0
n1 = m.ff.fx
dx = pos('.', n1)
if dx > 1 then
n1 = left(n1, dx-1)
else if dx = 1 | n1 = '' then
iterate
call mPut m'.'n1, kx
end
return
endProcedure vWithAdd
vForWith: procedure expose m.
parse arg var
call vWith '-'
if \ vIn(var) then
return 0
call vWith '+', m.in
return 1
endProcedure vForWith
vGet: procedure expose m.
parse arg na
a = vAdr(na, 'g')
if a = '' then
call err 'undefined var' na
return m.a
endProcedure vGet
vPut: procedure expose m.
parse arg na, val
a = vAdr(na, 'p')
m.a = val
return val
endProcedure vPut
/*--- find the final address
return f || a with address a and
f = m -> mapGet(a), o -> obect m.a, s -> string m.a ---*/
vAdr: procedure expose m.
parse arg na, f
cx = 0
cx = verify(na, '&>', 'm')
if cx > 0 then
a = left(na, cx-1)
else do
a = na
cx = length(na)+1
end
nxt = 0
do forever
cy = verify(na, '&>', 'm', cx+1)
if cy > 0 then
fld = substr(na, cx+1, cy-cx-1)
else
fld = substr(na, cx+1)
if substr(na, cx, 1) == '>' then do
if nxt then
a = vAdrByM(a)
if fld \== '' then
a = a'.'fld
end
else do
if nxt then
a = vAdrByM(a)
mp = m.v_withMap
aL = a
if pos('.', a) > 0 then
aL = left(a, pos('.', a)-1)
if mp \== '' & symbol('m.mp.aL') == 'VAR' then do
wx = m.mp.aL
a = m.v_with.wx.obj'.'a
end
else if cx >= length(na) then
return mapAdr(v, a, f)
else
a = mapAdr(v, a, 'g')
if fld \== '' then
a = vAdrByM(a)'.'fld
end
if cy < 1 then do
if f == 'g' then
if symbol('m.a') \== 'VAR' then
return ''
return a
end
cx = cy
nxt = 1
end
endProcedure vAdr
vAdrByM:
parse arg axx
if axx = '' then
return err('null address at' substr(na, cx) 'in' na)
if symbol('m.axx') \== 'VAR' then
return err('undef address' axx 'at' substr(na, cx) 'in' na)
ayy = m.axx
if ayy == '' then
return err('null address at' substr(na, cx) 'in' na)
return ayy
endProcedure vAdrByM
vIn: procedure expose m.
parse arg na
if \ in() then
return 0
if na \== '' then
call vPut na, m.in
return 1
endProcedure vIn
vRead: procedure expose m. /* old name ????????????? */
parse arg na
say '||| please use vIn instead fo vIn'
return vIn(na)
vHasKey: procedure expose m.
parse arg na
return mapHasKey(v, na)
vRemove: procedure expose m.
parse arg na
return mapRemove(v, na)
/* copy pipe end *****************************************************/
}¢--- A540769.WK.REXX(PLOAD) cre=2009-12-01 mod=2016-08-12-21.40.36 A540769 ----
/* rexx ****************************************************************
synopsis: pLoad ¢d! ¢?! ¢idNr!
d: mit Debug output
?: diese Hilfe
id: numerischer Teil einer existierenden id
keine id: neue id erstellen
Funktion:
Defaults (global und user) laden
Optionen für id editieren
und dann Job für copy/unload/load erstellen und editieren
logfile schreiben in DSN.pLoad.INFO(LOG)
Konfiguration (global, user (DSN.pLoad.INFO(userId())) und id):
rexx code, der folgende Variabeln setzen soll
m.auftrag Auftraggeber etc
m.punchList = list of punchfiles to analyze (fully qualified)
m.volume = '' input punch and load are catalogued
else reside on this volume
m.resume = '' use resume clause from punch
= 'NO' use log no resume no replace
= 'YES' use log yes resume yes
m.owner = '' deduce owner from db2SubSys and catalog
else use the given owner
m.load = '' use load DSN from punch
else use the given DSN (fully qualified) as loadfile
(with variables &PA. &TS. &DB.)
m.db2SubSys db2 subsystem for load
m.mgmtClas sms class for generated datasets
m.jobcard.* stem for jobcards
m.orderTS = 0 first all copies unloads, afterwards all loads
(usefull with constraints, because of checkPen)
else utility task grouped together for each TS
************************************************************************
12. 8.2018 W. Keller: jes2 jobCard
************** end help ***********************************************/
/************* rest of history *****************************************
toDo: enforce no einfügen (und check anhängen?)
copy load stirbt mit b37 ==> manuell space Angaben einfügen
copy nach load resume anfügen
2 Phasen trennen: datasets reinkopieren (kumulieren)
: copy/load durchführe (+restore, +log?|)
==> genpügt: noCopy und noUtil Options
(2. Phase ab 1. benutzen)
scan stirbt bei einer template mit space (..) cyl am schluss
Funktion für unloads im RZ1 bzw. RR2, auf entsprechende Shares
und Vorbereitung einer id
7. 9.2011 W. Keller: templates fuer Utility statt jcl alloc
7. 9.2011 W. Keller: dsn <= 44 auf für maximal db, ts und parts
1.12.2009 W. Keller: inDDn nicht mehr nötig mit m.load <> ''
13.11.2009 W. Keller: orderTS Option funktioniert wieder
08.08.2008 W. Keller: orderTS Option eingefügt
16.05.2008 W. Keller: Warnung bei TS mit mehreren Tables
12.01.2007 W. Keller: support partitions
01.12.2006 W. Keller: fix volume and m.load
22.11.2006 W. Keller: neu erstellt
***********************************************************************/
parse upper arg args
call errReset 'h'
/* Info DSN spezifizieren - hier sind alle LOADS verzeichnet */
m.mainLib = 'DSN.pLoad.INFO' /* read configs from here| */
m.debug = 0 /* Debug Funktion ausschalten */
/* Programm Inputparameter (args) verarbeiten */
idN = '' /* idN = pload Nummer */
do wx = 1 to words(args) /* Anzahl Worte in args */
w = word(args, wx) /* w = Wort1,2 - wenn wx=1,2 */
if w = '?' then
return help()
else if w = 'D' then /* Anschalten Debug Funktion */
m.debug = 1
else if verify(w, '0123456789') = 0 then
idN = w /* Wort in '0123456789' - NOMATCH = Default */
else
call errHelp 'bad argument "'w'" in' args
end
/* interpret mainOpt/userOpt */
call interDsn m.mainLib'(pLoadOpt)' /* m.mainlib = DSN.PLOAD.INFO */
/* überprüfen ob userOpt member existiert */
/* Wenn ja, hat dieses Priorität 1 */
userOpt = m.mainLib"("userId()")"
if sysDsn("'"userOpt"'") = 'OK' then /* dsn,member vorhanden? */
call interDsn userOpt /* m.mainlib = DSN.PLOAD.INFO */
/* get next ploadid (idN) */
if idN = '' then
idN = log('nextId') /* get next ploadid from log */
call genId idN /* idN = ploadid ohne N */
/* edit the options dataset with the data to be loaded */
/* e.g. lib = DSN.PLOAD.N0187.SRC(OPTIONS) */
call adrIsp "edit dataset('"m.optDsn"')", 4
/* pssss..... warten.... */
/* pssss..... warten.... */
/* pssss..... warten.... */
/* User hat PF3 gedrückt, weiter gehts... */
/* interpret options dataset */
call interDsn m.optDsn /* m.optDsn = DSN.PLOAD.N0186.SRC(OPTIONS) */
/* überprüfen ob Punchfile im Options Member spezifiziert wurde */
if m.punchList = '' then /* m.punchlist aus MAINOPT Member */
call errHelp 'no punch files specified in m.punchList'
call init
m.volume = strip(m.volume) /* m.volume aus MAINOPT Member */
vol = ''
if m.volume <> '' then
vol = 'volume('m.volume')' /* default value aus mainopt */
/* member, anonsten BLANK */
/* Wenn orderts = 1, dann erst alle copy und unloads
und erst nachher loads,
wenn SONST wegen Referential Integrity TS check pending werden
geht weder copy noch unload */
if m.orderts \= 0 then
m.orderts = 1
do wx=1 to words(m.punchList) /* analyze all punchfiles */
/* 1.Punchfile, dann word = 1 */
/* 2.Punchfile, dann word = 2 */
w = word(m.punchList, wx) /* save current punshfile dsn in w */
call debug 'analyzing punchfile' w vol
/* if m.debug=1 - say xxxxx */
call analyzePunch w vol, m.treeLd, m.treePn
end
call checkOverride m.treeLd /* massage the analyzed input */
call createTables m.treeLd, m.treeTb
if m.debug then
call mShow m.treeRoot
/* generate jcl */
call jclGenStart m.treePn, m.treeTb
call jclGenCopyInput m.treePn, m.treeTb
punDsn = genSrcDsn('PUNCH')
call jclGenPunch m.treeTb, punDsn
call jclGenUtil punDsn, m.db2SubSys
jclDsn = genSrcDsn('JCL')
call writeJcl jclDsn
call log 'load' /* write the log */
call adrIsp "edit dataset('"jclDsn"')", 4
call finish
exit
/*---tree structure-----------------------------------------------------
tree
punch
punchfiles*
templates* template in this punchfile
load
load* each load statement in a punchfile
into* each into clause in the load
table
table* each db2 table
----------------------------------------------------------------------*/
/*--- initialisation -------------------------------------------------*/
init: procedure expose m.
call ooIni /* set m.oo.lastId= 1 */
m.treeRoot = mRoot("root", "root")
m.treePn = mAddK1(m.treeRoot, 'punch')
m.treeLd = mAddK1(m.treeRoot, 'load')
m.treeTb = mAddK1(m.treeRoot, 'table')
call adrSqlConnect m.db2SubSys
return
endProcedure init
/*--- Adress SQL -----------------------------------------------------*/
adrSql: /* no procedure, to keep variables sql... */
parse arg ggSqlStmt, ggRet, ggNo
if ggNo <> '1' then
ggSqlStmt = 'execSql' ggSqlStmt
address dsnRexx ggSqlStmt
/* say 'sqlCode' sqlCode 'rc' rc 'for' ggSqlStmt ggNo */
if rc = 0 then do
return 0
end
else if rc < 0 then do
if ggRet == '*' then nop
else if wordPos(sqlCode, ggRet) > 0 then nop
else
call err "sql rc" rc sqlmsg() ggNo
end
else if sqlWarn.0 ^== ' ' then do
say 'warning' sqlMsg() ggNo
end
return sqlCode
endSubroutine adrSql
/*--- SQL Connect ----------------------------------------------------*/
adrSqlConnect: procedure
parse arg ggSys, ggRetCon
if adrTSO("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" ggSys, ggRetCon ,1
return
endProcedure adrSqlConnect
/*--- SQL Disconnect -------------------------------------------------*/
adrSqlDisconnect: procedure
parse arg ggRet
call adrSql "disconnect ", ggRet, 1
return
endProcedure adrSqlDisconnect
/*--- Write SQLCA ----------------------------------------------------*/
sqlMsg: /* no procedure, to keep variables sql... */
ggW = ''
do ggX=0 to 10
if sqlWarn.ggx <> '' then
ggw = ggw ggx'='sqlWarn.ggx
end
ggXX = pos(':', ggSqlStmt)
ggVV = ''
if ggXX > 0 then do
ggVV = word(substr(ggSqlStmt, ggXX + 1), 1)
ggXX = verify(ggVV, ' ,:+-*/&%?|', 'm')
if ggXX > 0 then
ggVV = left(ggVV, ggXX-1)
ggVV = 'with' ggVV '=' value(ggVV)
end
return 'sqlCode' sqlCode 'state' sqlState 'warn' ggW ,
'errMc' strip(translate(sqlerrmc, ',', 'FF'x)) ,
'stmt = ' ggSqlStmt ggVV
endSubroutine sqlMsg
/*--- cleanup at end of program and disconnect from DB2 --------------*/
finish: procedure expose m.
call adrSqlDisconnect
return
endProcedure finish
/*--- generate a SRC datatset for the created ploadid ----------------*/
/*--- Members are PUNCH and OPTIONS ----------------*/
genId: procedure expose m.
parse arg iNum /* iNum = idN (ploadid ohne N) */
m.id = 'N'right(iNum, 4, 0) /* m.id = Nnnnn, e.g N0125 */
/* return punch dsn name but do not create it */
/* e.g. lib = DSN.PLOAD.N0187.SRC(PUNCH) */
puDsn = genSrcDsn("PUNCH")
/* format dsn from jcl format to tso format */
puSta = sysDsn(jcl2dsn(puDsn))
if puSta = 'OK' then do /* punch dataset existiert bereits */
say 'Job wurde bereits gestartet, und hat Daten erstellt'
say 'Weiterarbeit kann diese Daten überschreiben'
say 'enter WEITER, falls Sie das wollen'
parse upper pull ans
if ans ^== 'WEITER' then
call err 'Weiterarbeit abgebrochen'
end
else if puSta ^= 'DATASET NOT FOUND' & puSta ^= 'MEMBER NOT FOUND',
then do
call err 'bad sysDsn result' puSta 'for' puDsn
end
/* return options dsn name but do not create it */
/* e.g. lib = DSN.PLOAD.N0187.SRC */
lib = genSrcDsn()
/* e.g. lib = DSN.PLOAD.N0187.SRC(OPTIONS) */
m.optDsn = genSrcDsn('OPTIONS')
/* format dsn from jcl format to tso format */
libSta = sysdsn(jcl2dsn(m.optDsn))
if libSta = 'DATASET NOT FOUND' then do
if m.mgmtClas <> '' then /* m.mgmtClas aus MAINOPT Member */
mgCl = 'MGMTCLAS('m.mgmtClas')'
call adrTso 'alloc dd(ddCrea) new catalog dsn('jcl2Dsn(lib)')',
'dsntype(library) dsorg(po) recfm(f b) lrecl(80)' ,
'space(1, 10)' mgCl
call adrTso 'free dd(ddCrea)'
end
else if libSta ^= 'MEMBER NOT FOUND' & libSta ^= 'OK' then do
call err 'not supported sysdsn = ' libSta 'for scrLib' m.optDsn
end
/* create the options mbr for this id if it does not exist */
if libSta ^= 'OK' then
call writeOptions
return
endProcedure genId
/*--- write the options member: contains variables and help ----------*/
writeOptions: procedure expose m.
m.op.0 = 0
m.generated = date('s') time() 'by' userId()
vars = 'generated auftrag punchList volume' ,
'resume owner load db2SubSys orderTs'
wp = words(m.punchList)
do vx=1 to words(vars)
v = word(vars, vx)
if v <> 'punchList' | wp <= 1 then do
call mAdd op, left('m.'v, 14)'=' quote(value('m.'v), "'")
end
else do
li = left('m.punchList', 14)'='
do wx=1 to wp
call mAdd op, left(li, 15) ,
quote(word(m.punchList, wx),"'"), left(',', wx < wp)
li = ''
end
end
end
/* help is the leading commentblock */
call mAdd op
do lx=1 by 1
li = strip(sourceLine(lx), 't')
call mAdd op, li
if pos('*/', li) > 0 then
leave
end
/* write new OPTIONS member */
call writeDsn m.optDsn, m.op.
return
endProcedure writeOptions
/*--- interpret the given dsn ----------------------------------------*/
/* DSN.PLOAD.INFO(MAINOPT) */
/* DSN.PLOAD.INFO(userid()) */
/* DSN.PLOAD.INFO(OPTIONS) */
interDsn: procedure expose m.
parse arg dsn /* procedure input variable
in dsn ablegen */
call debug 'interpreting' dsn /* if m.debug=1 - say xxxxx */
call readDsn dsn, x. /* read dataset */
/* concat all the lines */
/* seperate them when a ; was found */
s = ''
do x=1 to x.0
l = strip(x.x)
if right(l, 1) == ',' then /* rexx continuation */
s = s left(l, length(l) - 1)
else
s = s l';' /* separate statements */
end
interpret s
call debug 'interpreted' dsn /* if m.debug=1 - say xxxxx */
return
endProcedure interDsn
/*--- get the next ploadid from DSN.PLOAD.INFO(LOG) -----------------*/
/*--write the next ploadid into DSN.PLOAD.INFO(LOG) -----------------*/
log: procedure expose m.
parse arg fun /* fun = 'nextId' or 'load' */
dsn = m.mainLib'(LOG)'
rr = sysDsn("'"dsn"'")
if rr == 'OK' then do
call readDsn dsn, l. /* read dataset */
zx = l.0 /* Anzahl lines in dsn */
end /* für fun = 'load' */
else if rr == 'MEMBER NOT FOUND' then
zx = 0
else
call err 'sysDsn('dsn') ==>' rr/* next ploadid */
/* next ploadid reservieren */
if fun = 'nextId' then do
if zx == 0 then do
cId = 1
end
else do
id = strip(left(l.zx, 8)) /* ploadid aus log member */
/* pos1-8, e.g. N0125 */
if left(id, 1) ^== 'N',
| verify(substr(id, 2), '0123456789') > 0 then
/* | = ODER Verknüpfung */
call err 'illegal id "'id'" in line' zx 'of' dsn
cId = substr(id, 2) + 1
end
cId = 'N'right(cId, 4, '0')
/* max ploadid + 1 e.g. max=N0192, next=N0193 */
zx = zx + 1
/* max line dsn + 1 */
l.zx = left(cId, 8) date('s') left(time(), 5) 'newId'
/* l.zx = N0192 20081112 11:29 newId */
end
else if zx = 0 then do
call err 'log empty'
end
else if fun = 'load' then do /* log the current id */
/* find the current id in the log */
do ax = 1 by 1 to zx while strip(left(l.ax, 8)) < cId
end
do bx = ax by 1 to zx while strip(left(l.bx, 8)) = cId
end
le = left(cId, 8) date('s') left(time(), 5) left(m.auftrag, 20),
left(sysVar(sysNode) m.db2SubSys, 8)
/* shift the remaining entries */
tbRoot = m.treeTb
tSize = mSize(tbRoot)
sx = tSize-bx+ax
if sx > 0 then do
do qx=zx by -1 to bx /* shift right */
rx = qx+sx
l.rx = l.qx
end
end
else if sx < 0 then do /* shift left */
do qx=bx by 1 to zx
rx = qx+sx
l.rx = l.qx
end
end
zx = zx + sx
/* one log line for each table */
do tx=1 to tSize
tn = mAtSq(tbRoot, tx)
in = word(mVaAtK1(tn, 'intos'), 1)
owTb = mVaAtK1(tn, 'ow')'.'mVaAtK1(tn, 'tb')
if length(owTb) < 19 then
owTb = left(owTb, 19)
dbTs = mVaAtK1(tn, 'db')'.'mVaAtK1(tn, 'ts')
if length(dbTs) < 19 then
dbTS = left(dbTS, 19)
rx = ax + tx - 1
l.rx = le ,
left(mFirst('RESUME', '???', in, mPar(in)), 3) ,
owTb dbTs mVaAtK1(tn, 'parts')
end
end
else do /* fun <> 'nextId' or 'load' */
call err 'bad log fun' fun
end
/* write new ploadid in LOG member */
call writeDsn dsn, l., zx /* DSN.pLoad.INFO(LOG) L. 163 */
return substr(cId, 2) /* return next ploadid ohne N */
endProcedure log
/*--- analyze a punchfile ----------------------------------------------
puDsn: spec for input dsn to analyze
ldRoot: parentNode of node for each load
puRoot: parent node for each punchFile ---------------------*//
analyzePunch: procedure expose m.
parse arg puDsn, ldRoot, puRoot
/* w vol, m.treeLd, m.treePn */
pu = readDsnOpen(ooNew(), puDsn) /* open (alloc) punchfile */
/* ooNew() = increment m.oo.lastId (initialised by ooInit proc.) */
/* ooNew() = save punchfile in tree structure. */
co = treeCopyOpen(ooNew(), pu, '??', 0)
sc = scanUtilReader(ooNew(), co)
tmpl = mAddKy(puRoot, 'punch', puDsn)
do forever
if utilNext == 'TEMPLATE' then do
utilNext = analyzeTemplate(sc, tmpl)
end
else if utilNext == 'LOAD' then do
ch = mAddKy(ldRoot, 'load', tmpl)
utilNext = analyzeLoad(sc, co, ch, tmpl)
end
else do
u = scanUtil(sc)
if u == 'u' then
utilNext = m.val
else if u == '' then
leave
end
end
call ooReadClose pu
return
endProcedure analyzePunch
/*--- analyze template -----------------------------------------------*/
analyzeTemplate: procedure expose m.
parse arg sc, nd
if 'u' = scanUtil(sc) then
return m.val
else if m.utilType ^= 'n' then
call scanErr sc, 'template name expected'
na = m.tok
ch = mAddK1(nd, na, 'template')
do forever
if 'u' == scanUtil(sc) | m.utilType = '' then do
return m.val
end
else if m.utilType == 'n' & m.scan.sc.utilBrackets = 0 then do
parm = m.val
if wordPos(parm, 'DSN VOLUME') > 0 then
call mAddK1 ch, parm, scanUtilValue(sc)
else if parm = 'VOLUMES' then
call mAddK1 ch, 'VOLUME', scanUtilValue(sc)
else
call debug 'ignoring' parm scanUtilValue(sc)
/* if m.debug=1 - say xxxxx */
end
else do
call debug 'template chunck' m.utilType m.tok
/* if m.debug=1 - say xxxxx */
end
end
endProcedure analyzeTemplate
/*--- analyze load ---------------------------------------------------*/
analyzeLoad: procedure expose m.
parse arg sc, cc, ldNd, tmplNd
if scanUtil(sc) ^== 'n' & m.val ^== 'DATA' then
call scanErr sc, 'load data expected'
nd = ldNd
/* the load into syntax is too complex to analyze completly
instead, we use treeCopy to copy all unAnalyzed text */
call treeCopyDest cc, nd
call treeCopyOn cc, m.scan.sc.pos
do while 'u' ^== scanUtil(sc) & m.utilType ^== ''
if m.utilType ^= 'n' | m.scan.sc.utilBrackets ^= 0 then
iterate
opt = m.val
if wordPos(m.val, 'INDDN RESUME SHRLEVEL REPLACE COPYDDN' ,
'LOG INTO PART') < 1 then
iterate
call treeCopyOff cc, m.scan.sc.pos - length(m.tok)
if opt == 'INTO' then do
if scanUtil(sc) ^== 'n' | m.val ^== 'TABLE' then
call scanErr sc, 'into table expected'
if scanUtil(sc) ^== 'n' & m.utilType ^== '"' then
call scanErr sc, 'table name expected'
nd = mAddKy(ldNd, opt, '')
call mAddK1 nd, 'ow', strip(m.val)
if scanUtil(sc) ^== '.' then
call scanErr sc, '.table expected'
if scanUtil(sc)^=='n' & m.utilType^=='"' then
call scanErr sc, 'table name expected'
call mAddK1 nd, 'tb', strip(m.val)
call treeCopyDest cc, nd
end
else if opt == 'INDDN' then do
dd = scanUtilValue(sc)
ddNd = mAtK1(tmplNd, dd)
if ddNd = '' & m.load = '' then
call err 'template not found for inDDn' dd
call mAddK1 nd, 'INDDN', ddNd
end
else if opt == 'REPLACE' then do
call mAddK1 nd, opt, 1
end
else do
call mAddK1 nd, opt, scanUtilValue(sc)
end
call treeCopyOn cc, m.scan.sc.pos
end
call treeCopyOff cc, m.scan.sc.pos - length(m.tok)
return m.val
endProcedure analyzeLoad
/*--- check loads and override values --------------------------------*/
checkOverride: procedure expose m.
parse arg ldRoot
rs = translate(m.resume)
do lx=1 to mSize(ldRoot) /* for each load */
ld = mAtSq(ldRoot, lx)
loDdn = overrideLoad(mAtK1(ld, 'INDDN'))
if rs <> '' then
call mPut ld, 'RESUME', rs
do ix=1 to mSize(ld) /* for each into */
in = mAtSq(ld, ix)
if mKy(in) <> 'INTO' then
iterate
nd = mAtK1(in, 'PART')
if nd = '' then
nd = mAddK1(in, 'PART', '*')
part = m.nd
info = mVaAtK1(in, 'ow')'.'mVaAtK1(in, 'tb') 'part' part
if part == '*' then
nop
else if ^ datatype(part, 'n') | length(part) > 5 then
call scanErr sc, 'bad partition' part 'for' info
else
part = right(part, 5, 0)
m.nd = part
inDdn = overrideLoad(mAtK1(in, 'INDDN'))
if inDDn = '' then do
if loDDn = '' then do
if m.load = '' then
call err 'no inDDN for' info
loDdn = overrideLoad(mAddK1(ld, 'INDDN'))
end
DDn = loDDn
end
else do
if loDDn <> '' then
call err 'inDDn twice specified for' info
ddn = inDDn
end
if m.volume <> '' & mAtK1(ddn, 'VOLUME') = '' then
call mAddK1 in, 'VOLUME', m.volume
if rs <> '' then
call mPut in, 'RESUME', rs
end /* for each into */
end /* for each load */
return
endProcedure checkOverride
/*--- override or modify the load pointed to by nd -------------------*/
overrideLoad: procedure expose m.
parse arg nd
if nd == '' then
return nd
if m.load <> '' then do
if symbol('m.loadNd') <> 'VAR' then do
m.loadNd = mAddK1(m.treeRoot, 'overLoad')
call ds2Tree m.load, m.loadNd
end
m.nd = m.loadNd
end
if m.volume <> '' then
call mPut m.nd, 'VOLUME', m.volume
return nd
endProcedure overrideLoad
/*--- create tables: find destination creator and ts in catalogue
create tree for destination table and
link it to all into nodes -----------------------*/
createTables: procedure expose m.
parse arg ldRoot, tbRoot
do lx=1 to mSize(ldRoot)
ld = mAtSq(ldRoot, lx)
do ix=1 to mSize(ld)
in = mAtSq(ld, ix)
if mKy(in) <> 'INTO' then
iterate
oOw = mVaAtK1(in, 'ow')
oTb = mVaAtK1(in, 'tb')
if symbol('old.oOw.oTb') = 'VAR' then do
nd = old.oOw.oTb
call debug 'found' nd 'for old table' oOw'.'oTb
/* if m.debug=1 - say xxxxx */
end
else do /* search table in db2 catalog */
parse value queryTable(oOw, oTb) ,
with nOw'.'nTb':'db'.'ts
nd = mAtK1(tbRoot, nOw'.'nTb)
if nd <> '' then do
call debug 'found' nd 'for new table' nOw'.'nTb
/* if m.debug=1 - say xxxxx */
end
else do /* create node for table */
nd = mAddK1(tbRoot, nOw'.'nTb)
call mAddK1 nd, 'ow', nOw
call mAddK1 nd, 'tb', nTb
call mAddK1 nd, 'db', db
call mAddK1 nd, 'ts', ts
call mAddK1 nd, 'parts'
call debug 'created' nd 'for new table' nOw'.'nTb
/* if m.debug=1 - say xxxxx */
end
old.oOw.oTb = nd
call debug 'map old tb' oOw'.'oTb 'to' nOw'.'nTb 'nd' nd
/* if m.debug=1 - say xxxxx */
end
m.in = nd
pp = mVaAtK1(in, 'PART')
op = mVaAtK1(nd, 'parts')
if op = '' then do
np = pp
ni = in
if pp = '*' then
call mAddK1 nd, 'tsPa', 'TS'
else
call mAddK1 nd, 'tsPa', 'PA'
end
else if pp = '*' | op = '*' then
call err 'part * not alone in tb' nOw'.'nTb
else if wordPos(pp, op) > 0 then
call err 'part' pp 'duplicate n tb' nOw'.'nTb
else do /* add new partition into sorted list */
do wx=1 to words(op) while pp > word(op, wx)
end
np = subword(op, 1, wx-1) pp subword(op, wx)
oi = mVaAtK1(nd, 'intos')
ni = subword(oi, 1, wx-1) in subword(oi, wx)
end
call mPut nd, 'parts', np
call mPut nd, 'intos', ni
end
end
return
endProcedure createTables
/*--- query the db2 catalog for creator, db, ts etc.
of the tables to load --------------------------------------*/
queryTable: procedure expose m.
parse upper arg ow, tb
sql = "select t.name, t.creator, tsName, t.dbname, s.nTables" ,
"from sysibm.systables t, sysibm.systablespace s" ,
"where t.type = 'T'" ,
"and s.dbName = t.dbName and s.name = t.tsName" ,
"and t.name = '"strip(tb)"' and t.creator"
if m.owner <> '' then do /* override owner */
sql = sql "= '"strip(m.owner)"'"
end
else if left(ow, 3) == 'OA1' then do /* translate OA1* owners */
o = substr(strip(m.db2SubSys), 3, 1)
if o = 'O' | sysvar(sysnode) <> 'RZ1' then
o = 'P'
nn = overlay(o, ow, 4)
if nn = 'OA1P' then
sql = sql "in ('OA1P', 'ODV', 'IMF')"
else
sql = sql "= '"strip(nn)"'"
end
else do /* user owner as is */
sql = sql "= '"strip(ow)"'"
end
/* execute sql and fetch row */
call adrSql 'prepare s1 from :sql'
call adrSql "declare c1 cursor for s1"
call adrSql 'open c1'
cnt = 0
do forever
call adrSql 'fetch c1 into :tb, :cr, :ts, :db, :tbCnt'
if sqlCode = 100 then
leave
cnt = cnt + 1
if cnt > 1 then
call err 'fetched more than 1 row for table' ow'.'tb ':'sql
end
if cnt = 0 then
call err 'table' ow'.'tb 'not found in catalog:' sql
else if tbCnt <> 1 then do
say 'ts' db'.'ts 'hat' tbCnt 'Tabellen'
say 'pLoad kann mit RESUME=NO Daten ueberschreiben'
say 'trotzdem weitermache (w=weiter)?'
parse upper pull a
if ^ abbrev(a, 'W') then
call err 'nicht weiter'
end
call adrSql 'close c1'
return strip(cr)'.'strip(tb)':'strip(db)'.'strip(ts)
endProcedure queryTable
/*--- write the generated jcl ----------------------------------------*/
writeJcl: procedure expose m.
parse arg dsn
x = dsnAlloc(dsn, 'SHR', jclGen)
dd = word(x, 1)
call writeDDBegin dd
call writeDD dd, 'M.JOBCARD.'
do j = 1 to m.jclCard.0
call debug 'jclCard j' M.JCLCARD.j.0
/* if m.debug=1 - say xxxxx */
call writeDD dd, 'M.JCLCARD.'j'.'
end
call writeDDEnd dd
interpret subword(x, 2)
return
endProcedure writeJCL
/*--- generate the JCL -----------------------------------------------*/
jclGenStart: procedure expose m.
parse arg pnRoot, tbRoot
call jclIni
/* show our infos in comment */
call jcl '10'copies('*', 69)
parse source . . ggS3 .
call jcl '10* load job generated by' ggS3 ,
'in' sysvar(sysnode) 'for' m.db2SubSys 'by' userid()
call jcl '10* id' m.id 'at' date('s') time()
do px=1 to mSize(pnRoot) /* show input punch */
pn = mAtSq(pnRoot, px)
call jcl '1* punch ' m.pn
end
do tx=1 to mSize(tbRoot) /* show output tables */
tn = mAtSq(tbRoot, tx)
call jcl '1* load ' ,
mVaAtK1(tn, 'ow')'.'mVaAtK1(tn, 'tb') ,
'in' mVaAtK1(tn, 'db')'.'mVaAtK1(tn, 'ts')
p = mVaAtK1(tn, 'parts')
if p <> '*' then
call jcl '1* ' words(p) 'partitions between' word(p, 1),
'and' word(p, words(p))
intos = mVaAtK1(tn, 'intos')
do ix=1 to words(intos) /* show input tables and dsns */
in = word(intos, ix)
owTb = mVaAtK1(in, 'ow')'.'mVaAtK1(in, 'tb')
if i.owTb == 1 then
iterate
i.owTb = 1
if length(owTb) < 16 then
owTb = left(owTb, 16)
tmpl = mFirst('INDDN', , in, mPar(in))
call jcl '1* from' owTb mVaAtK1(tmpl, 'DSN')
end
drop i.
end
call jcl '10'copies('*', 69) /* end of info comment */
call jcl '1* alle Dataset löschen, die wir nachher neu erstellen'
call jcl '1'jclExec() 'PGM=IEFBR14'
return
endProcedure jclGenStart
/*--- copy all input dsns to our Prefix ------------------------------*/
jclGenCopyInput: procedure expose m.
parse arg puRoot, tbRoot
do px=1 to mSize(puRoot) /* punch files */
pn = mAtSq(puRoot, px)
call jcl '2* Originales Punchfile Kopieren'
call jclCopy ds2Tree(m.pn, m.jclNdFr) ,
, ds2Tree(genSrcDsn('OPUNCH', px), m.jclNdTo)
end
/* load input dsns */
m.dsnLoadTS = genDsn('&DB..&TS.', 'LOA')
m.dsnLoadPA = genDsn('&DB..&TS..P&PA.', 'LOA')
do tx=1 to mSize(tbRoot)
tn = mAtSq(tbRoot, tx)
intos = mVaAtK1(tn, 'intos')
do ix=1 to words(intos)
in = word(intos, ix)
ln = mPar(in)
if mAtK1(in, 'INDDN') <> '' then
dn = mVaAtK1(in, 'INDDN')
else
dn = mVaAtK1(ln, 'INDDN')
dnDsn = mVaAtK1(dn, 'DSN')
chDsn = expDsn(in, dnDsn)
if dnDsn <> chDsn then do
dn = mAddTree(mRemCh(m.jclNdFr), dn)
call mPut dn, 'DSN', chDsn
end
vv = 'DSNLOAD'mVaAtK1(tn, 'tsPa')
newLo = expDsn(in, m.vv)
call jcl '2* Originales Loadfile Kopieren'
call jclCopy dn, dsNew2Tree(newLo, m.jclNdTo)
end
end
return
endProcedure jclGenCopyInput
/*--- generate the db2 utility statements for copy & unload ----------*/
jclGenPunch: procedure expose m.
parse arg tbRoot, puDsn
if m.mgmtClas == '' then
m.mgmtClasCl = ''
else
m.mgmtClasCl = 'MGMTCLAS('m.mgmtClas')'
call jcl '2* Neues Punchfile Kopieren'
call jcl '2'jclExec() 'PGM=IEBGENER'
call jcl '20SYSPRINT DD SYSOUT=*'
call jcldd 2, 's', 'SYSUT2', ds2Tree(puDsn, m.jclNdTo)
call jcl '20SYSUT1 DD *'
call jcl '2 TEMPLATE TMLOADTS'
call jcl "2 DSN('"m.dsnLoadTS"')"
call jcl "2 DISP(SHR,KEEP,KEEP)"
call jcl '2 TEMPLATE TMLOADPA'
call jcl "2 DSN('"m.dsnLoadPA"')"
call jcl "2 DISP(SHR,KEEP,KEEP)"
xx = overlay(".UNLO", m.dsnLoadTS, lastPos(".", m.dsnLoadTS))
call jcl '2 TEMPLATE TMULTS'
call jcl "2 DSN('"xx"')"
call jcl '2 DATACLAS (NULL12) MGMTCLAS(COM#A045)'
call jcl '2 SPACE (10,250) CYL'
xx = overlay(".UNL", m.dsnLoadPA, lastPos(".", m.dsnLoadPA))
call jcl '2 TEMPLATE TMULPA'
call jcl "2 DSN('"xx"')"
call jcl '2 DATACLAS (NULL12) MGMTCLAS(COM#A045)'
call jcl '2 SPACE (10,250) CYL'
xx = overlay(".UNPU", m.dsnLoadTS, lastPos(".", m.dsnLoadTS))
call jcl '2 TEMPLATE TMULPUN'
call jcl "2 DSN('"xx"')"
call jcl '2 DATACLAS (NULL12) MGMTCLAS(COM#A045)'
call jcl '2 SPACE (1,10) CYL'
do tx=1 to mSize(tbRoot)
tn = mAtSq(tbRoot, tx)
intos = mVaAtK1(tn, 'intos')
call jclGenPunchCopyUnload tn, tx
call jclGenPunchInto word(intos, 1), 0, tn
do ix=1 to words(intos)
in = word(intos, ix)
call jclGenPunchInto in, ix, tn
end
end
return
endProcedure jclGenPunch
/*--- generate utility copy and unload statement for table tn --------*/
jclGenPunchCopyUnload: procedure expose m.
parse arg tn, tx
parts = mVaAtK1(tn, 'parts')
paMin = word(parts, 1)
paMax = word(parts, words(parts))
dbTs = mVaAtK1(tn, 'db')'.'mVaAtK1(tn, 'ts')
if parts == '*' then do
call jcl '2 COPY TABLESPACE' dbTS 'FULL YES'
end
else do
call jcl '2 LISTDEF COLI'tx
call jcl '2 INCLUDE TABLESPACE' dbTs 'PARTLEVEL'
call jcl '2 COPY LIST COLI'tx 'FULL YES PARALLEL'
end
call jcl '2 COPYDDN (TCOPYD) SHRLEVEL REFERENCE'
/* unload before */
call jcl '2 UNLOAD TABLESPACE' dbTS
if parts = '*' then
nop
else if paMin == paMax then
call jcl '2 PART' paMin
else
call jcl '2 PART' paMin ':' paMax
call jcl '2 FROM TABLE' mVaAtK1(tn, 'ow') ,
|| '.'mVaAtK1(tn, 'tb')
call jcl '2 PUNCHDDN TMULPUN UNLDDN TMUL'mVaAtK1(tn,'tsPa')
call jcl '2 SHRLEVEL REFERENCE'
return
endProcedure jclGenPunchCopyUnload
/*--- generate the db2 utility statements for 1 load or into ---------*/
jclGenPunchInto: procedure expose m.
parse arg in, ix, tn
pa = mVaAtK1(in, 'PART')
ln = mPar(in)
rs = mFirst('RESUME', 'NO', in, ln)
if rs = 'NO' then do
rsSp = 'RESUME NO REPLACE COPYDDN TCOPYD'
end
else do
rsSp = 'RESUME YES'
sh = mFirst('SHRLEVEL', '', in, ln)
if sh <> '' then
rsSp = rsSp 'SHRLEVEL' sh
end
if ix == 0 then do
if pa == '*' then do
call jcl '3 LOAD DATA INDDN TMLOADTS'
call jcl '3 ' rsSp 'LOG' rs
if rs == 'NO' then
call jcl '3 STATISTICS TABLE(ALL)' ,
'INDEX(ALL) UPDATE ALL'
end
else do
call jcl '3 LOAD DATA LOG' rs
end
jn = mPar(in)
call jcl '3 SORTDEVT DISK'
call jcl '3 WORKDDN(TSYUTD,TSOUTD)'
call jcl '3 ERRDDN TERRD MAPDDN TMAPD'
end
else do
call jcl '3 INTO TABLE' mVaAtK1(tn,'ow')'.'mVaAtK1(tn,'tb')
if pa <> '*' then do
call jcl '3 PART' pa
call jcl '3 ' rsSp
call jcl '3 INDDN TMLOADPA'
end
jn = in
end
do cx=1 to mSize(jn)
cn = mAtSq(jn, cx)
key = mKy(cn)
if key = '' then
call jcl '3 'm.cn
end
return
endProcedure jclGenPunchInto
/*--- jcl to run the db2 utility -------------------------------------*/
jclGenUtil: procedure expose m.
parse arg pun, dbSys
call jcl '4* db2 utility macht die Arbeit'
call jcl '42IF RC=0 THEN'
call jcl '4'jclExec() "PGM=DSNUTILB,PARM='"dbSys","userid()".UN.LO'"
call jcl '40SYSPRINT DD SYSOUT=*'
call jcl '40UTPRINT DD SYSOUT=*'
call jcl '40SYSTEMPL DD DISP=SHR,DSN='dbSys'.DBAA.LISTDEF(TEMPL)'
call jcl '40SYSIN DD DISP=SHR,DSN='pun
call jcl '42ENDIF'
return
endProcedure jclGenUtil
/*--- generate DSN for this id, with the given llq and index ---------*/
genDSN: procedure expose m.
parse arg dbTs, leLlq, lx
llq = leLLq || lx
if length(llq) > 8 then
llq = left(leLlq, 8 - length(lx)) || lx
if dbTs = '' then
return m.dsnPref || '.'m.id'.'llq
else
return m.dsnPref || '.'m.id'.'dbTs'.'llq
endProcedure genDSN
/*--- generate DSN for the src DS of the id, with member and index ---*/
genSrcDsn: procedure expose m.
parse arg mbr, lx /* mbr = PUNCH oder OPTIONS */
dsn = m.dsnPref'.'m.id'.SRC' /* e.g.dsn = DSN.PLOAD.N0181.SRC */
/* m.dsnpref aus MAINOPT Member */
if mbr = '' then
return dsn /* e.g.dsn = DSN.PLOAD.N0181.SRC */
m = mbr || lx
if length(m) > 8 then
m = left(mbr, 8 - length(lx)) || lx
return dsn'('m')' /* DSN.PLOAD.N0185.SRC(PUNCH) */
/* DSN.PLOAD.N0185.SRC(OPTIONS) */
endProcedure genSrcDsn
/*--- expand variables in dsn from the into node in ------------------*/
expDsn: procedure expose m.
parse arg in, dsn
do forever
px = pos('&', dsn)
if px = 0 then do
if length(dsn) > 44 then
call err 'dsn too long' dsn
return dsn
end
dx = pos('.', dsn, px+1)
if dx <= px then
call err 'no . after & in' dsn
k = translate(substr(dsn, px+1, dx-px-1))
if k = 'DB' then
v = mVaAtK1(m.in, 'db')
else if k = 'PART' | k = 'PA' then
v = mVaAtK1(in, 'PART')
else if k = 'TS' | k = 'SN' then
v = mVaAtK1(m.in, 'ts')
else
call err 'bad variable' k 'in' dsn
dsn = left(dsn, px-1) || v || substr(dsn,dx+1)
end
endProcedure expDsn
/*--- transform the dataset spec into a tree at node nd --------------*/
ds2tree: procedure expose m.
parse arg spec, nd
call mRemCh nd
upper spec
dsn = ''
do ix=1 by 1
w = word(spec, ix)
if w = '' then
leave
if abbrev(w, 'DSN(') then
dsn = substr(w, 5, length(w) - 5)
else if abbrev(w, 'VOLUME(') then
call mAddK1 nd, 'VOLUME', substr(w, 8, length(w) - 8)
else if dsn == '' then
dsn = w
end
if dsn ^= '' then
call mAddK1 nd, 'DSN', dsn
return nd
endProcedure ds2Tree
/*--- transform the spec for a new DS into a tree at node nd ---------*/
dsNew2tree: procedure expose m.
parse arg spec, nd
x = ds2Tree(spec, nd)
if m.mgmtClas <> '' then
call mPut x, 'MGMTCLAS', m.mgmtClas
return x
endProcedure dsNew2tree
/*--- jcl to copy a sequential DS ------------------------------------*/
jclCopy: procedure expose m.
parse arg fr, to
call jcl '2'jclExec() 'PGM=IEBGENER'
call jcl '20SYSPRINT DD SYSOUT=*'
call jcldd 2, 'o', 'SYSUT1', fr
if pos('(', mVaAtK1(to, 'DSN')) > 0 then
call jcldd 2, 's', 'SYSUT2', to
else
call jcldd 2,'nr', 'SYSUT2', to, fr
return
endProcedure jclCopy
/*--- generate a jcl dd statement
opt: n=new, s=shr, r=remove in first step
dd: ddname
nd: tree representation dataset spec
like: tree representation of like dataset ----------------------*/
jclDD: procedure expose m.
parse arg j, opt, dd, nd, like
new = pos('n', opt) > 0
li=left('0'dd, 12)'DD'
if new then
li = li 'DISP=(NEW,CATLG,DELETE)'
else if pos('s', opt) > 0 then
li = li 'DISP=SHR'
else
li = li 'DISP=OLD'
do cx=1 by 1 to m.nd.0
ch = nd'.'cx
va = m.ch
ky = mKy(ch)
if wordPos(ky, 'DSN MGMTCLAS') > 0 then
li = jclDDClause(j, li, ky'='va)
else if ky == 'VOLUME' then
li = jclDDClause(j, li, 'VOL=SER=('va'),UNIT=DISK')
else
call err 'bad dd attribute' ky'='va
end
if like == '' then do
end
else if like == 'fb80' then do
li = jclDDClause(j, li, 'RECFM=FB,LRECL=80')
end
else do
if '' == mAtK1(like, 'VOLUME') then do
li = jclDDClause(j, li, 'LIKE='mVaAtK1(like, 'DSN'))
end
else do
aa = jcl2dsn(mVaAtK1(like, 'DSN')) ,
'VOLUME('mVaAtK1(like, 'VOLUME')')'
lRc = listDsi(aa)
if lRc <> 0 then
call err 'rc' lRc from 'listDsi' aa
if sysUnits = 'CYLINDER' then
u = 'CYL'
else if sysUnits = 'TRACK' | sysUnits = 'BLOCK' then
u = left(sysUnits, 2) || 'K'
else
call err 'bad sysunits from listDsi:' sysUnits
li = jclDDClause(j, li, 'SPACE=('u',('sysPrimary',' ,
|| sysSeconds'))')
li = jclDDClause(j, li, 'RECFM='sysRecFm)
end
end
call jcl j || li
if new & pos('r', opt) > 0 then
call jclRemove nd
return
endProcedure jclDD
/*--- add a DS to the remove step ------------------------------------*/
jclRemove: procedure expose m.
parse arg nd
m.jclRemove = m.jclRemove + 1
li = left('0RM'm.jclRemove, 12)'DD DISP=(MOD,DELETE,DELETE)'
li = jclDDClause(1, li, 'DSN='mVaAtK1(nd, 'DSN'))
call jcl '1'li
return
endProcedure jclRemove
/*--- add one clause to a jcl dd statement
if the line overflows write it out
return rest of line ---------------------------------------*/
jclDDClause: procedure expose m.
parse arg j, li, cl
if left(li, 1) = '6' then
a = 15
else
a = 1
if a + length(li) + length(cl) < 70 then
return li','cl
call jcl j || li','
return '6'cl
endProcedure jclDDClause
/*--- generate an exec statement -------------------------------------*/
jclExec: procedure expose m.
m.jclStep = m.jclStep + 1
return left('0S'm.jclStep, 10)'EXEC'
endProcedure jclExec
/*--- initialize jcl generator ---------------------------------------*/
jclIni: procedure expose m.
m.jclCard.0 = 9
do x=1 to m.jclCard.0
m.jclCard.x.0 = 0
end
m.jclRemove=0
m.jclStep = 0
m.jclPref.0 = '//'
m.jclPref.2 = left('//', 11)
m.jclPref.4 = left('//', 13)
m.jclPref.6 = left('//', 15)
xx = ' '
m.jclPref.xx = ''
xx = '*'
m.jclPref.xx = '//*'
m.jclNdFr = mRoot()
m.jclNdTo = mRoot()
return
endProcedure jclIni
/*--- output one jcl line:
j (char 1): which stem
t (char 2): prefix
m (char 3 to end): message ----------------------------------*/
jcl: procedure expose m.
parse arg j 2 t 3 m
if m.orderTS & j > 2 then
j = 2
x = m.jclCard.j.0 + 1
m.jclCard.j.0 = x
if m.debug then
if symbol('m.jclPref.t') <> 'VAR' then
call err undefined jclPref for t 'in' j || t || m
m.jclCard.j.x = m.jclPref.t || strip(m, 't')
if m.debug then
say 'jcl'j m.jclCard.j.x
return
endProcedure jcl
/*--- add one line text to the stem m.st -----------------------------*/
/*--- copy a DS in tso -----------------------------------------------*/
copyDS: procedure
parse arg fj fa, tj ta
say 'copyDs from' fj fa 'to' tj ta
call adrTso 'free dd(sysut1)', '*'
call adrTso 'alloc dd(sysut1) shr dsn('jcl2dsn(fj)')' fa
call adrTso 'free dd(sysut2)', '*'
call adrTso 'delete' jcl2dsn(tj), '*'
call adrTso 'alloc dd(sysut2) new catalog refdd(sysut1)' ,
'dsn('jcl2dsn(tj)')' ta
call adrTso 'alloc dd(sysin) dummy reuse'
call adrTso 'alloc dd(sysprint) sysout(T) reuse'
/* call iebGener */
CALL ADRTSO 'CALL *(IEBGENER)', '*'
say 'iebGener rc' rc 'result' result
call adrTso 'free dd(sysin sysprint sysut1 sysut2)'
return
endProcedure copyDS
/* treeCopy : make a copy of a reader to a tree ***********************/
treeCopyLine: procedure expose m.
parse arg m, nx
if ^m.treeCopy.m.read then
return
if nx > length(m.treeCopy.m.line) then
qx = length(m.treeCopy.m.line)
else
qx = nx - 1
if m.treeCopy.m.on then do
le = left(m.treeCopy.m.line, qx)
if le <> '' then
call mAddKy m.treeCopy.m.dest, , le
end
m.treeCopy.m.line = overlay('', m.treeCopy.m.line, 1, qx)
return
endProcedure treeCopyLine
treeCopyDest: procedure expose m.
parse arg m, m.treeCopy.m.dest
return
endProcedure treeCopyDest
/*--- start copying at character nx of current line ------------------*/
treeCopyOn: procedure expose m.
parse arg m, nx
if m.treeCopy.m.on then
return
call treeCopyLine m, nx
m.treeCopy.m.on = 1
return
endProcedure treeCopyOn
/*--- stop copying at character nx of current line -------------------*/
treeCopyOff: procedure expose m.
parse arg m, nx
if ^ m.treeCopy.m.on then
return
call treeCopyLine m, nx
m.treeCopy.m.on = 0
return
endProcedure treeCopyOff
treeCopyRead: procedure expose m.
parse arg m, rdr, var
call treeCopyLine m, 1 + length(m.treeCopy.m.line)
m.treeCopy.m.read = ooRead(rdr, var)
m.treeCopy.m.line = m.var
return m.treeCopy.m.read
endProcedure treeCopyRead
treeCopyOpen: procedure expose m.
parse arg m, rdr, m.treeCopy.m.dest, isOn
call ooDefRead m, 'res = treeCopyRead("'m'", "'rdr'", var);'
m.treeCopy.m.read = 0
m.treeCopy.m.on = isOn = 1
return m
endProcedure treeCopyOpen
/* copy scanUtil begin *************************************************
scan db2 utility input statements using scan and a reader
**********************************************************************/
/*--- initialize with reader inRdr ----------------------------------*/
scanUtilReader: procedure expose m.
parse arg m, inRdr
call scanReader m, inRdr
call scanOptions sc, , , '--'
m.scan.m.utilBrackets = 0
return m
endProcedure scanUtilReader
/*--- scan next token and put its type in m.utilType:
'u' a utility name
'n' a name
'"' a quoted name
"'" an apostroph'd string
'.' a .
',' a ,
'v' a value
'' at end
---------------------------------------------------------------*/
scanUtil: procedure expose m.
parse arg sc
call scanSpaceNl sc
ty = '?'
if scanLit(sc, '(') then do
m.scan.sc.utilBrackets = m.scan.sc.utilBrackets + 1
end
else if scanLIT(sc, ')') then do
m.scan.sc.utilBrackets = m.scan.sc.utilBrackets - 1
if m.scan.sc.utilBrackets < 0 then
call scanErr sc, 'unmatched closing bracket )'
end
else if scanLit(sc, ',') then do
end
else if scanLit(sc, '.') then do
end
else if scanString(sc, "'") then do
end
else if scanString(sc, '"') then do
end
else if scanName(sc) then do
m.val = translate(m.tok)
if m.scan.sc.utilBrackets > 0 then
ty = 'n'
else if 0 < wordPos(m.val, 'BACKUP CATENFM CATMAINT CHECK' ,
'COPY COPYTOCOPY DIAGNOSE EXEC LISTDEF LOAD' ,
'MERGECOPY MODIFY OPTIONS QUIESCE REBUILD' ,
'RECOVER REORG REPAIR REPORT RESTORE' ,
'RUNSTATS STOSPACE TEMPLATE UNLOAD') then
ty = 'u'
else
ty = 'n'
end
else if scanVerify(sc, ' (),''"', 'm') then do
ty = 'v'
m.val = translate(m.tok)
end
else if ^scanAtEnd(sc) then do
call scanErr sc, 'scanUtil stopped before end'
end
else do
/* say 'scanUtil return atEnd' */
ty = ''
m.val = ''
end
if ty == '?' then
m.utilType = left(m.tok, 1)
else
m.utilType = ty
return m.utilType
endProcedure scanUtil
/*--- scan a value or a bracketed list of values ---------------------*/
scanUtilValue: procedure expose m.
parse arg sc
if '(' ^== scanUtil(sc) then
return scanUtilValueOne(sc)
v = ''
brx = m.scan.sc.utilBrackets
do forever
call scanUtil sc
one = scanUtilValueOne(sc)
if one == '' then
call scanErr sc, 'eof in brackets'
else if brx > m.scan.sc.utilBrackets then
return v
v = v || one
end
endProcedure scanUtilValue
scanUtilValueOne: procedure expose m.
parse arg sc
if utilType == '' then
return ''
else if m.utilType == 'u' then
call scanErr sc, 'util in scanUtilValueOne'
else if pos(m.utilType, 'nv''"') > 0 then
return m.val
else
return m.tok
endProcedure scanUtilValueOne
/* copy scanUtil end **************************************************/
/* 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
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(*)'
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')'
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 *************************************************/
/**********************************************************************
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 = adrTso('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
/* copy adrSql end *************************************************/
/* copy scan begin ****************************************************
Scan: scan an input:
scanLine(m,ln) : begin scanning a single line
scanStem(m,ln) : begin scanning all lines in a stem
scanAtEOL(m) : returns whether we reached end of line
scanAtEnd(m) : returns whether we reached end of input
scanLit(m,lit) : scan Literal lit if present or return 0
scanChar(m,n) : scan next n characters
scanName(m) : scan a name
scanNum(m) : scan integer (without sign)
scanString(m,q): scan a String with quote q. (with doubble = 1)
scanVerify(m,c,o): verify(...,c,o,...)
scanKeyValue(m): scan a key = value clause (with spaces)
scanWord(m,u) : scan a space delimited word or a string,
if u=1 then uppercase non-strings
scanErr(m, txt): error with current scan location
m is an adress, to store our state
if a scan function succeeds, the scan posititon is moved
returns: true if scanned, false otherwise
m.tok ==> last token
m.val ==> last value for scanString/Word/KeyValue
m.key ==> key for scanKeyValue
m.scan.m.pos ==> scan position
m.scan.m.src ==> scan source
***********************************************************************/
/*--- begin scanning a single line -----------------------------------*/
scanLine: procedure expose m.
parse arg m, m.scan.m.src
call scanStart m
return
endProcedure scanLine
/*--- begin scanning the lines of a stem -----------------------------*/
scanReader: procedure expose m.
parse arg m, inRdr
call scanStart m, inRdr
m.scan.m.src = ''
m.scan.m.atEnd = ^ scanNL(m, 1)
return m
endProcedure scanReader
/*--- switch to next line if atEOF or argument unCond=1 --------------*/
scanNL: procedure expose m.
parse arg m, unCond
if unCond == 1 then
m.scan.m.pos = 1 + length(m.scan.m.src)
else if m.scan.m.pos <= length(m.scan.m.src) then
return 0
if m.scan.m.reader = '' then
return 0
else if ^ ooRead(m.scan.m.reader, 'SCAN.'m'.SRC') then do
m.scan.m.atEnd = 1
return 0
end
m.scan.m.pos = 1
m.scan.m.tok = ''
return 1
endProcedure scanNL
/*--- initialize scanner for m --------------------------------------*/
scanStart: procedure expose m.
parse arg m, m.scan.m.reader
m.scan.m.pos = 1
m.tok = ''
m.val = ''
m.key = ''
if symbol('m.scan.m.Name') ^== 'VAR' then do
m.scan.LC = 'abcdefghijklmnopqurstuvwxyz'
m.scan.UC = 'ABCDEFGHIJKLMNOPQURSTUVWXYZ'
m.scan.Alpha = m.scan.LC || m.scan.UC
m.scan.AlNum = '0123456789' || m.scan.ALPHA
m.scan.m.Name1 = m.scan.ALPHA
m.scan.m.Name = m.scan.ALNUM
m.scan.m.comment = ''
end
return
endProcedure scanStart
/*--- set options name characters, comment characters ----------------*/
scanOptions: procedure expose m.
parse arg m, nameOne, namePlus, comm
if symbol('m.scan.m.Name') ^== 'VAR' then
call scanStart
if nameOne ^== '' then
m.scan.m.Name1 = nameOne
if nameOne ^= '' | namePlus ^== '' then
m.scan.m.name = m.scan.m.name1 || namePlus
m.scan.m.comment = comm
return
endProcedure scanBegin
/*--- return true/false whether we are at the end of the line --------*/
scanAtEOL: procedure expose m.
parse arg m
return m.scan.m.pos > length(m.scan.m.src)
endProcedure scanAtEOL
/*--- return true/false whether we are at the end of the input -------*/
scanAtEnd: procedure expose m.
parse arg m
if m.scan.m.pos <= length(m.scan.m.src) then
return 0
if m.scan.m.reader = '' then
return 1
else
return m.scan.m.atEnd
endProcedure scanAtEnd
/*--- scan len characters --------------------------------------------*/
scanChar: procedure expose m.
parse arg m, len
nx = 1 + length(m.scan.m.src)
if len ^== '' then
if nx > m.scan.m.pos + len then
nx = m.scan.m.pos + len
m.tok = substr(m.scan.m.src, m.scan.m.pos, nx - m.scan.m.pos)
if nx = m.scan.m.pos then
return 0
m.scan.m.pos = nx
return 1
endProcedure scanChar
/*--- scan the literal lit ------------------------------------------*/
scanLit: procedure expose m.
parse arg m, lit
if ^ abbrev(substr(m.scan.m.src, m.scan.m.pos), lit) then
return 0
m.scan.m.pos = m.scan.m.pos + length(lit)
m.tok = lit
return 1
endProcedure scanLit
/*--- scan a string with quote char qu -------------------------------*/
scanString: procedure expose m.
parse arg m, qu
m.val = ''
if qu = '' then
qu = "'"
if substr(m.scan.m.src, m.scan.m.pos, 1) ^== qu then
return 0
bx = m.scan.m.pos
qx = m.scan.m.pos + 1
do forever
px = pos(qu, m.scan.m.src, qx)
if px < 1 then
call scanErr m, 'ending Apostroph('qu') missing'
m.val = m.val || substr(m.scan.m.src, qx, px-qx)
if px >= length(m.scan.m.src) then
leave
else if substr(m.scan.m.src, px+1, 1) <> qu then
leave
qx = px+2
m.val = m.val || qu
end
m.tok = substr(m.scan.m.src, bx, px+1-bx)
m.scan.m.pos = px+1
return 1
endProcedure scanString
/*--- scan a Name, first char in *.name1, rest in *.name -------------*/
scanName: procedure expose m.
parse arg m
if pos(substr(m.scan.m.src, m.scan.m.pos, 1),
, m.scan.m.Name1) <= 0 then
return 0
bx = m.scan.m.pos
m.scan.m.pos = bx + 1
call scanVerify m, m.scan.m.Name
m.tok = substr(m.scan.m.src, bx, m.scan.m.pos - bx)
return 1
endProcedure scanName
/*--- scan with verify, vOpt is passed to verify ---------------------*/
scanVerify: procedure expose m.
parse arg m, alpha, vOpt
if vOpt == '' then /* empty string does not take default| */
nx = verify(m.scan.m.src, alpha, , m.scan.m.pos)
else
nx = verify(m.scan.m.src, alpha, vOpt, m.scan.m.pos)
if nx = 0 then
nx = length(m.scan.m.src) + 1
m.tok = substr(m.scan.m.src, m.scan.m.Pos, nx - m.scan.m.Pos)
if nx <= m.scan.m.pos then
return 0
m.scan.m.pos = nx
return 1
endProcedure scanVerify
/*--- scan a number --------------------------------------------------*/
scanNum: procedure expose m.
parse arg m
if ^ scanVerify(m, '0123456789') then
return 0
else if pos(substr(m.scan.m.src, m.scan.m.pos, 1), m.scan.m.name1) ,
> 0 then
call scanErr m, 'illegal number end'
return 1
endProcedure scanNum
/*--- scan a word and put value into *.val
a word is either delimited by space or stopper
or a string (with single or double quotes -------*/
scanWord: procedure expose m.
parse arg m, stopper
if scanString(m, "'") then return 1
if scanString(m, """") then return 1
if ^scanVerify(m, ' 'stopper, 'm') then return 0
m.val = m.tok
return 1
endProcedure scanWord
scanBack: procedure expose m.
parse arg m, tok
if m.scan.m.pos <= length(tok) then
call scanErr sc, 'cannot back "'tok'" length'
cx = m.scan.m.pos - length(tok)
if substr(m.scan.m.src, cx, length(tok)) ^== tok then
call scanErr sc, 'cannot back "'tok'" value'
m.scan.m.pos = cx
return
endProcedure scanBack
/*--- scan a key = word phrase
put key into *.key and word into val -------*/
scanKeyValue: procedure expose m.
parse arg m, def
if ^ scanName(scanSkip(m)) then
return 0
m.key = m.tok
if ^ scanLit(scanSkip(m), '=') then do
m.val = def
m.tok = ' no='
end
else if ^scanWord(scanSkip(m)) then
call scanErr(m, 'word expected after' m.key '=')
return 1
endProcedure scanKeyValue
/*--- emit an error with current scan pos ----------------------------*/
scanErr: procedure expose m.
parse arg m, txt
say 'scanErr' txt
say ' last token' m.tok
say ' charPos' m.scan.m.Pos':',
strip(substr(m.scan.m.src, m.scan.m.Pos), 't')
say ' in line:' strip(m.scan.m.src, 't')
call err 'scanErr' txt
endProcedure scanErr
/*--- skip over spaces, nl and comments (if option set) --------------*/
scanSpaceNL: procedure expose m.
parse arg m
lastTok = m.tok
res = 0
cc = m.scan.m.comment
do forever
if scanVerify(m, ' ') then nop
else if scanNL(m) then nop
else if cc == '' then leave
else if ^ scanLit(m, cc) then leave
else if ^scanNL(m, 1) then leave
res = 1
end
m.tok = lastTok
return res
endProcedure scanSpaceNL
/*--- skip over space, nl and comments and return m -----------------*/
scanSkip: procedure expose m.
parse arg m
call scanSpaceNl m
return m
endProcedure scanSkip
/* copy scan end ****************************************************/
/* copy ooDiv begin ****************************************************
***********************************************************************/
/* File einlesen, z.B. PUNCHFILE */
readDsnOpen: procedure expose m.
parse arg oid, spec
/* oid = ooNew(), spec = punchfile(volume) */
x = dsnAlloc(spec, 'SHR', 'RE'oid)
/* dsnAlloc = Procedure zum anlegen/öffnen von datasets */
/* x = RE2 call adrTso "free dd(RE2)"; */
dd = word(x, 1)
/* dd = RE2 */
return ooDefReadStem(oid, 'res = readDD('dd', "M."stem".")',
, 'call readDDEnd' dd';' subword(x, 2))
endProcedure readDsnOpen
/* copy ooDiv end ***************************************************/
/* copy oo begin ******************************************************/
/* m.oo.lastid = 1 */
ooIni: procedure expose m.
m.oo.lastId = 1
return
endProcedure ooIni
/* m.oo.lastid inkrementieren */
/* m.oo.lastid = neue adresse (objekt) erstellen */
ooNew: procedure expose m.
m.oo.lastId = m.oo.lastId + 1
return m.oo.lastId
endProcedure newoo
ooFree: procedure expose m.
parse arg id
return
endProcedure ooFree
/* nächste Zeile einlesen */
ooRead: procedure expose m.
parse arg oid, var
res = '?'
interpret m.oo.oid.read
return res
endProcedure ooRead
ooReadClose: procedure expose m.
parse arg oid
stem = ''
interpret m.oo.oid.readClose
m.oo.oid.read = 'res=0'
m.oo.oid.readClose = ''
return
endProcedure ooReadClose
ooDefRead: procedure expose m.
parse arg oid, m.oo.oid.read, m.oo.oid.readClose
return oid
endProcedure ooDefRead
ooDefReadStem: procedure expose m.
parse arg oid, m.oo.oid.readStem, close
m.oo.oid.0 = 0
m.oo.oid.readStemCx = 0
return ooDefRead(oid, 'res = ooReadStem2Ln("'oid'", var);', close)
endProcedure ooDefReadStem
ooReadStem2Ln: procedure expose m.
parse arg oid, v
cx = m.oo.oid.readStemCx
if cx >= m.oo.oid.0 then do
res = '?'
stem = 'OO.'oid
m.stem.0 = 0
m.oo.oid.stCx = 0
interpret m.oo.oid.readStem
if ^ res then
return 0
else if m.stem.0 < 1 then
call err 'stem.0='m.stem.0 'after 1 from' m.oo.oid.readStem
cx = 0
end
cx = cx + 1
m.v = m.oo.oid.cx
m.oo.oid.readStemCx = cx
return 1
endProcedure ooReadStem2Ln
ooReadStemOpen: procedure expose m.
parse arg oid, stem
call ooDefReadStem oid, 'res = 0;'
do ix=0 by 1 to m.stem.0
m.oo.oid.ix = m.stem.ix
end
m.oo.oid.0 = m.stem.0
return oid
endProcedure ooReadStemOpen
ooReadArgsOpen: procedure expose m.
parse arg oid, ox
call ooDefReadStem oid, 'res = 0;'
if ox = '' then
ox = m.oo.oid.0
else
ox = ox - 1
do ax=3 by 1 to arg()
ox = ox + 1
m.oo.oud.ox = arg(ax)
end
m.oo.oid.0 = ox
return oid
endProcedure ooReadArgsOpen
ooArgs2Stem: procedure expose m.
parse arg stem, ox
if ox = '' then
ox = m.stem.0
else
ox = ox - 1
do ax=3 by 1 to arg()
ox = ox + 1
m.stem.ox = arg(ax)
end
m.stem.0 = ox
return stem
endProcedure ooArgs2Stem
/* copy oo 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
/*--- 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: readDD*, readDDEnd
write: writeBegin, writeDD*, writeEnd
readDD returns true if data read, false at eof
***********************************************************************/
/*--- 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 (member) ----------------------------------*/
dsnAlloc: procedure expose m.
parse upper arg spec, disp, dd
m.dsnAlloc.dsn = ''
if left(spec, 1) = '=' then
return strip(substr(spec, 1))
addPref = pos('~', spec) > 0
if addPref then
spec = strip(spec, 'b', '~')
do wx=1 to 3
w = word(spec, wx)
if w = '' then
leave
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 m.dsnAlloc.dsn = '' then
m.dsnAlloc.dsn = dsn2jcl(w, addPref)
else
leave
end
if dd = '' then
dd = 'DD' || ooNew()
if disp = '' | (disp = 'OLD' & pos('(', dsn) > 0) then
disp = 'SHR'
if m.dsnAlloc.dsn <> '' then
disp = disp "dsn('"m.dsnAlloc.dsn"')"
call adrTso 'alloc dd('dd')' disp subword(spec, wx)
return dd 'call adrTso "free dd('dd')";'
endProcedure dsnAlloc
/*--- read dsn, e.g. DSN.PLOAD.INFO(MAINOPT) -------------------------*/
readDSN:
parse arg ggDsnSpec, ggSt
/* DSN.PLOAD.INFO(MAINOPT), ggSt = X.
DSN.PLOAD.INFO(LOG) , ggSt = L. */
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
/* dsnAlloc = Procedure zum anlegen/öffnen von datasets */
/* ggAlloc = READDSN call adrTso "free dd(READDSN)"; */
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
/* READDSN */ /* X. or L. */
interpret subword(ggAlloc, 2) /* interpret = Befehl ausführen
subword = Wörter ab Pos2
von ggAlloc */
/* ggAlloc,2 = call adrTso "free dd(READDSN)"; */
return
endSubroutine readDsn
/*--- write dsn, e.g. DSN.PLOAD.INFO(LOG) ----------------------------*/
/*--- write dsn, e.g. DSN.PLOAD.INFO(OPTIONS) ------------------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
/* DSN.PLOAD.INFO(LOG) , ggSt = L., ggCnt = maxline + 1
DSN.PLOAD.INFO(OPTIONS), ggSt = m.op, ggCnt = ''
ggsay = wie m.debug = 1 */
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
/* dsnAlloc = Procedure zum anlegen/öffnen von datasets */
/* ggAlloc = READDSN call adrTso "free dd(READDSN)"; */
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'finis)' /* READDSN */
/* L. or m.op */
interpret subword(ggAlloc, 2) /* interpret = Befehl ausführen
subword = Wörter ab Pos2
von ggAlloc */
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
/* copy adrTso end ****************************************************/
/* copy m begin ********************************************************
stem and tree handling
***********************************************************************/
/*--- return Ky of m ------------------------------------------------*/
mKy: procedure expose m.
parse arg m
return m.mKey.m
endProcedure mKy
/*--- return number of children of node m or 0 -----------------------*/
mSize: procedure expose m.
parse arg m
if symbol('m.m.0') == 'VAR' then
return m.m.0
else
return 0
endProcedure mSize
/*--- return parent of node m or '' ----------------------------------*/
mPar: procedure expose m.
parse arg m
dx = lastPos('.', m)
if dx <= 1 then
return ''
else
return left(m, dx - 1)
endProcedure mPar
/*--- create a new tree root -----------------------------------------*/
mRoot: procedure expose m.
parse arg m, Ky, val /* m = ROOT, Ky = ROOT */
if m == '' then
m = 'mRoot.' || mIncD('mRoot.0')
m.m = val
m.mKey.m = Ky
m.m.0 = 0
return m
endProcedure mRoot
/*--- increase m.m and return it (also if undefined) -----------------*/
mIncD: procedure expose m.
parse arg m, delta /* m = ROOT, delta = '' */
if symbol('m.m') <> 'VAR' then
m.m = 0
return mInc(m)
endProcedure mIncD
/*--- increase m.m and return it (fail if undefined) -----------------*/
mInc: procedure expose m.
parse arg m, delta
if delta = '' then
m.m = m.m + 1
else
m.m = m.m + delta
return m.m
endProcedure mInc
/*--- add one or several values to stem m.m --------------------------*/
mAdd: procedure expose m.
parse arg m
ix = mSize(m)
do ax = 2 to arg()
ix = ix + 1
m.m.ix = arg(ax)
end
m.m.0 = ix
return m'.'ix
endProcedure mAdd
/*--- add to m.dst.* a (sub)sequence of m.src.* ----------------------*/
mAddSeq: procedure expose m.
parse arg dst, src, begX, endX
if begX = '' then
begX = 1
if endX = '' then
endX = mSize(src)
dx = mSize(dst)
do sx = begX to endX
dx = dx + 1
m.dst.dx = m.src.sx
end
m.dst.0 = dx
return dst
endProcedure mAddSeq
/*--- add one value to the stem m.m ----------------------------------*/
mAddNd: procedure expose m.
parse arg m
ix = mSize(m)
do ax = 2 to arg()
ix = ix + 1
m.m.ix = arg(ax)
m.m.ix.0 = 0
end
m.m.0 = ix
return m'.'ix
endProcedure mAddNd
/*--- add one Ky value pair to stem m.m -----------------------------*/
mAddKy: procedure expose m.
parse arg m, Ky, val
nn = mAddNd(m, val)
m.mKey.nn = Ky
return nn
endProcedure mAddKy
/*--- add one indexable Ky value pair to stem m.m -------------------*/
mAddK1: procedure expose m.
parse arg m, ky, val
if symbol('m.mIndex.m.mKey.ky') == 'VAR' then
call err 'duplicate Ky' ky 'for node' m
nn = mAddNd(m, val)
m.mKey.nn = ky
m.mIndex.m.mKey.ky = nn
return nn
endProcedure mAddK1
/*--- put value at Ky if it exists otherwise add the node -----------*/
mPut: procedure expose m.
parse arg m, Ky, val
if symbol('m.mIndex.m.mKey.Ky') == 'VAR' then do
ch = m.mIndex.m.mKey.Ky
m.ch = val
return ch
end
else do
return mAddK1(m, Ky, val)
end
return
endProcedure mPut
/*--- return the child of m at the given Ky, '' if not exists -------*/
mAtK1: procedure expose m.
parse arg m, ky
if symbol('m.mIndex.m.mKey.ky') == 'VAR' then
return m.mIndex.m.mKey.ky
else
return ''
endProcedure mAtK1
/*--- return the value of the child at Ky, fail if not exists -------*/
mVaAtK1: procedure expose m.
parse arg m, Ky
if symbol('m.mIndex.m.mKey.Ky') ^== 'VAR' then
call err 'no Ky' Ky 'at node' m
ch = m.mIndex.m.mKey.Ky
return m.ch
endProcedure mVaAtK1
/*--- return the value of the first defined ky in the list of nodes
def if ky isn't defined ---------------------------------------*/
mFirst: procedure expose m.
parse arg Ky, def
do ax=3 to arg()
m = arg(ax)
if symbol('m.mIndex.m.mKey.Ky') == 'VAR' then do
ch = m.mIndex.m.mKey.Ky
return m.ch
end
end
return def
endProcedure mFirst
/*--- return the child at sequenceNo seq of node m -------------------*/
mAtSq: procedure expose m.
parse arg m, seq
if symbol('m.m.seq') ^== 'VAR' then
return ''
else
return m'.'seq
endProcedure mAtSq
/*--- remove all or all after nwSz children --------------------------*/
mRemCh: procedure expose m.
parse arg pa, nwSz
if nwSz = '' then
nwSz = 0
do cx=nwSz+1 to mSize(pa)
ch = pa'.'cx
call mRemCh ch
ky = m.mKey.ch
drop m.mIndex.pa.mKey.ky m.mKey.ch m.ch m.ch.0
end
m.pa.0 = nwSz
return pa
endProcedure mRemCh
/*--- add to m.dst a (sub)tree of m.src.* ----------------------------*/
mAddTree: procedure expose m.
parse arg dst, src, begX, endX
if begX = '' then
begX = 1
if endX = '' then
endX = mSize(src)
do sx=begX to endX
sCh = src'.'sx
if symbol('m.mKey.sCh') ^= 'VAR' then do
dCh = mAddNd(dst, m.sCh)
end
else do
ky = m.mKey.sCh
if symbol('m.mIndex.src.mKey.ky') ^= 'VAR' then
dCh = mAddKy(dst, ky, m.sCh)
else
dCh = mAddK1(dst, ky, m.sCh)
end
call mAddTree dCh, sCh
end
return dst
endProcedure mAddTree
/*--- show from one node everything that is defined ------------------*/
mShowNd: procedure expose m.
parse arg m
pa = mPar(m)
t = 'node' m 'pa='pa
if symbol('m.m') == 'VAR' then
t = t 'va='m.m
if symbol('m.m.0') == 'VAR' then
t = t 'size='m.m.0
if symbol('m.mKey.m') == 'VAR' then do
ky = m.mKey.m
t = t 'ky='ky
if symbol('m.mIndex.pa.mKey.ky') == 'VAR' then
t = t 'index='m.mIndex.pa.mKey.ky
end
say t
return
endProcedure mShowNd
/*--- show the tree at m recursively ---------------------------------*/
mShow: procedure expose m.
parse arg m, lv
if lv = '' then
lv = 0
t = left('', lv)m
if symbol('m.mKey.m') == 'VAR' then do
ky = m.mKey.m
pa = mPar(m)
if symbol('m.mIndex.pa.mKey.ky') == 'VAR' then
t= t ky '>'
else
t= t ky '='
end
say t strip(m.m, 't')
do cx=1 to mSize(m)
call mShow mAtSq(m, cx), lv+1
end
return
endProcedure treeShow
/* copy m end *********************************************************/
/* copy err begin ******************************************************
messages, errorhandling,help
***********************************************************************/
errIni: procedure expose m.
if m.err.ini == 1 then
return
call outIni
m.err.ini = 1
m.err.handler = ''
m.err.cleanup = ';'
m.err.opt = ''
return
endProcedure errIni
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err.opt, m.err.handler
if pos('I', translate(m.err.opt)) > 0 then
if sysVar('sysISPF') = 'ACTIVE' then
call adrIsp 'control errors return'
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
call errIni
drop err handler cleanup opt call return
if ggOpt == '' & m.err.handler \== '' then do
if 1 then do /* no detection of recursive err call loop
--> will anyway fail by stack overflow */
interpret m.err.handler
end
else do
/* avoid recursive err call loop */
drop call return
if symbol('m.err.call') \== 'VAR' then
m.err.call = 1
else
m.err.call = m.err.call + 1
if m.err.call > 10 then do
say 'errHandler loop:' m.err.handler
end
else do
m.err.return = 1
call errInterpret m.err.handler
m.err.call = m.err.call - 1
if m.err.return then
return result
end
end
end
call outPush
call errSay ggTxt, 'e'
call errCleanup
if ggOpt == '' then
ggOpt = m.err.opt
ggOpt = translate(ggOpt)
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 then do
call errSay 'divide by zero to show stackHistory', 'e'
x = 1 / 0
end
call errSay 'exit(12)', 'e'
exit errSetRc(12)
endSubroutine err
errAddCleanup: procedure expose m.
parse arg code
if m.err.ini \== 1 then
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
if m.err.ini \== 1 then
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
cl = m.err.cleanup
if cl = ';' then
return
m.err.cleanup = ';'
call out 'err cleanup begin' cl
call errInterpret cl
call out 'err cleanup end' cl
return
endProcedure errCleanup
errInterpret: procedure expose m.
parse arg code
interpret code
m.err.return = 0
return
endProcedure errInterpret
/*--- assert that the passed rexx expression evaluates to true -------*/
assert:
interpret 'assertRes =' arg(1)
if \ assertRes then
call err 'assert failed' arg(1)':' arg(2)
return
endProcedure assert
/*--- output an errorMessage msg with pref pref
split message in lines at '/n' ---------------------------*/
errSay: procedure expose m.
parse arg msg, pref
parse source . . ggS3 . /* current rexx */
if pref == 'e' then
msg = 'fatal error in' ggS3':' msg
else if pref == 'w' then
msg = 'warning in' ggS3':' msg
else if pref \== '' then
msg = pref':' msg
return outNl(msg)
endProcedure errSay
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg, op
call errSay msg, 'e'
call help
call err msg, op
endProcedure errHelp
/*--- return the Operating System we are running on: TSO or LINUX ---*/
errOS: procedure expose m.
parse source os .
return os
endProcedure errOS
/*--- set rc for ispf: -------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared varible 3IspfRc
back as return code
----------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- output a trace message if m.tr is set -----------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
call out 'debug' msg
return
endProcedure debug
/*--- return current time and cpu usage ------------------------------*/
timing: procedure expose m.
return return time() 'ela='time('E') 'cpu='sysvar('syscpu'),
'su='sysvar('syssrv')
timingTest: procedure expose m.
say 'begin' timing() sysvar('sysnode')
do 30000000
end
say 'end ' timing()
return
/*--- display the first comment block of the source as help ----------*/
help: procedure expose m.
parse source . . s3 .
call out right(' help for rexx' s3, 79, '*')
do lx=1 by 1
if pos('/*', sourceLine(lx)) > 0 then
leave
else if lx > 10 then do
call out '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
call out li
end
call out right(' end help for rexx' s3, 79, '*')
return 4
endProcedure help
/*--- output all lines (separated by '\n') of all args --------------*/
outNl: procedure expose m.
do ax=1 to max(1, arg())
msg = arg(ax)
sx = 0
bx = -1
do lx=1 until bx >= length(msg)
ex = pos('\n', msg, bx+2)
if ex < 1 then
ex = length(msg)+1
call out substr(msg, bx+2, ex-bx-2)
bx = ex
end
end
return 0
endProcedure outNl
/*--- 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
/*--- if function ----------------------------------------------------*/
if: procedure expose m.
parse arg co, ifTrue, ifFalse
if co then
return ifTrue
else
return ifFalse
endProcedure if
/* copy err end *****************************************************/
/* copy out begin ******************************************************
out interface with simplistic implementation
***********************************************************************/
outIni: procedure expose m.
parse arg msg
if symbol('m.out.ini') == 1 then
return
m.out.dst = ''
return
endProcedure outIni
/*--- output a message to the current destination -------------------*/
out: procedure expose m.
parse arg msg
if m.out.ini \== 1 then
call outIni
if m.out.dst == '' then do
say msg
end
else do
st = m.out.dst
sx = m.st.0 + 1
m.st.0 = sx
m.st.sx = msg
end
return 0
endProcedure out
/*--- push an out destination ---------------------------------------*/
outPush: procedure expose m.
parse arg m.out.dst
return
endProcedure outPush
/* copy out end *****************************************************/
}¢--- A540769.WK.REXX(PLOADW) cre=2009-11-13 mod=2009-11-13-15.43.52 A540769 ---
/* rexx ****************************************************************
synopsis: pLoad ¢d! ¢?! ¢idNr!
d: mit Debug output
?: diese Hilfe
id: numerischer Teil einer existierenden id
keine id: neue id erstellen
Funktion:
Defaults (global und user) laden
Optionen für id editieren
und dann Job für copy/unload/load erstellen und editieren
logfile schreiben in DSN.pLoad.INFO(LOG)
Konfiguration (global, user (DSN.pLoad.INFO(userId())) und id):
rexx code, der folgende Variabeln setzen soll
m.auftrag Auftraggeber etc
m.punchList = list of punchfiles to analyze (fully qualified)
m.volume = '' input punch and load are catalogued
else reside on this volume
m.resume = '' use resume clause from punch
= 'NO' use log no resume no replace
= 'YES' use log yes resume yes
m.owner = '' deduce owner from db2SubSys and catalog
else use the given owner
m.load = '' use load DSN from punch
else use the given DSN (fully qualified) as loadfile
(with variables &PA. &TS. &DB.)
m.db2SubSys db2 subsystem for load
m.mgmtClas sms class for generated datasets
m.jobcard.* stem for jobcards
m.orderTS = 0 first all copies unloads, afterwards all loads
(usefull with constraints, because of checkPen)
else utility task grouped together for each TS
************************************************************************
08.08.2008 W. Keller: orderTS Option eingefügt
************** end help ***********************************************/
/************* rest of history *****************************************
toDo: enforce no einfügen (und check anhängen?)
copy load stirbt mit b37 ==> manuell space Angaben einfügen
load überschreiben ohne inDDN erlauben|
copy nach load resume anfügen
2 Phasen trennen: datasets reinkopieren (kumulieren)
: copy/load durchführe (+restore, +log?|)
==> genpügt: noCopy und noUtil Options
(2. Phase ab 1. benutzen)
scan stirbt bei einer template mit space (..) cyl am schluss
Funktion für unloads im RZ1 bzw. RR2, auf entsprechende Shares
und Vorbereitung einer id
16.05.2008 W. Keller: Warnung bei TS mit mehreren Tables
12.01.2007 W. Keller: support partitions
01.12.2006 W. Keller: fix volume and m.load
22.11.2006 W. Keller: neu erstellt
***********************************************************************/
parse upper arg args
m.testFast = 0 /* args = '' & userId() = 'A540769' */
if m.testFast then
args = 108
m.mainLib = 'DSN.pLoad.INFO' /* read configs from here| */
m.debug = 0
idN = '' /* parse arguments */
do wx = 1 to words(args)
w = word(args, wx)
if w = '?' then
call help
else if w = 'D' then
m.debug = 1
else if verify(w, '0123456789') = 0 then
idN = w
else
call errHelp 'bad argument "'w'" in' args
end
/* interpret main/userOption */
call interDsn m.mainLib'(mainOpt)'
userOpt = m.mainLib"("userId()")"
if sysDsn("'"userOpt"'") = 'OK' then
call interDsn userOpt
if idN = '' then /* check/create id options */
idN = log('nextId')
call genId idN
if ^ m.testFast then
call adrIsp "edit dataset('"m.optDsn"')", 4
call interDsn m.optDsn
if m.punchList = '' then
call errHelp 'no punch files specified in m.punchList'
call init
m.volume = strip(m.volume)
vol = ''
if m.volume <> '' then
vol = 'volume('m.volume')'
m.orderTS = m.orderTS <> 0
do wx=1 to words(m.punchList) /* analyze all punchfiles */
w = word(m.punchList, wx)
call debug 'analyzing punchfile' w vol
call analyzePunch w vol, m.treeLd, m.treePn
end
call checkOverride m.treeLd /* massage the analyzed input */
call createTables m.treeLd, m.treeTb
if m.debug then
call mShow m.treeRoot
/* generate jcl */
call jclGenStart m.treePn, m.treeTb
call jclGenCopyInput m.treePn, m.treeTb
punDsn = genSrcDsn('PUNCH')
call jclGenPunch m.treeTb, punDsn
call jclGenUtil punDsn, m.db2SubSys
jclDsn = genSrcDsn('JCL')
call writeJcl jclDsn
call log 'load' /* write the log */
call adrIsp "edit dataset('"jclDsn"')", 4
call finish
exit
/*---tree structure-----------------------------------------------------
tree
punch
punchfiles*
templates* template in this punchfile
load
load* each load statement in a punchfile
into* each into clause in the load
table
table* each db2 table
----------------------------------------------------------------------*/
/*--- initialisation -------------------------------------------------*/
init: procedure expose m.
call ooIni
m.treeRoot = mRoot("root", "root")
m.treePn = mAddK1(m.treeRoot, 'punch')
m.treeLd = mAddK1(m.treeRoot, 'load')
m.treeTb = mAddK1(m.treeRoot, 'table')
call adrSqlConnect m.db2SubSys
return
endProcedure init
/*--- cleanup at end of program --------------------------------------*/
finish: procedure expose m.
call adrSqlDisconnect
return
endProcedure finish
/*--- debug output if m.debug is set ---------------------------------*/
debug: procedure expose m.
if m.debug then
say 'debug' arg(1)
return
endProcedure debug
/*--- error message an suicide ---------------------------------------*/
err:
parse arg ggMsg
call errA ggMsg, 1
endSubroutine err
/*--- generate an id -------------------------------------------------*/
genId: procedure expose m.
parse arg iNum
m.id = 'N'right(iNum, 4, 0)
/* if punch is present, warn the user
because db2 utility probably was started already */
puDsn = genSrcDsn("PUNCH")
puSta = sysDsn(jcl2dsn(puDsn))
if puSta = 'OK' then do
say 'Job wurde bereits gestartet, und hat Daten erstellt'
say 'Weiterarbeit kann diese Daten überschreiben'
say 'enter WEITER, falls Sie das wollen'
if m.testFast then do
say 'weiter wegen m.testFast'
end
else do
parse upper pull ans
if ans ^== 'WEITER' then
call err 'Weiterarbeit abgebrochen'
end
end
else if puSta ^= 'DATASET NOT FOUND' & puSta ^= 'MEMBER NOT FOUND',
then do
call err 'bad sysDsn result' puSta 'for' puDsn
end
/* create the src dataset for this id, if it does not exist */
lib = genSrcDsn()
m.optDsn = genSrcDsn('OPTIONS')
libSta = sysdsn(jcl2dsn(m.optDsn))
if libSta = 'DATASET NOT FOUND' then do
if m.mgmtClas <> '' then
mgCl = 'MGMTCLAS('m.mgmtClas')'
call adrTso 'alloc dd(ddCrea) new catalog dsn('jcl2Dsn(lib)')',
'dsntype(library) dsorg(po) recfm(f b) lrecl(80)' ,
'space(1, 10)' mgCl
call adrTso 'free dd(ddCrea)'
end
else if libSta ^= 'MEMBER NOT FOUND' & libSta ^= 'OK' then do
call err 'not supported sysdsn = ' libSta 'for scrLib' m.optDsn
end
/* create the options mbr for this id if it does not exist */
if libSta ^= 'OK' then
call writeOptions
return
endProcedure genId
/*--- write the options member: contents of variables and help -------*/
writeOptions: procedure expose m.
m.op.0 = 0
m.generated = date('s') time() 'by' userId()
vars = 'generated auftrag punchList volume' ,
'resume owner load db2SubSys orderTS'
wp = words(m.punchList)
do vx=1 to words(vars)
v = word(vars, vx)
if v <> 'punchList' | wp <= 1 then do
call mAdd op, left('m.'v, 14)'=' quote(value('m.'v), "'")
end
else do
li = left('m.punchList', 14)'='
do wx=1 to wp
call stAdd op, left(li, 15) ,
quote(word(m.punchList, wx),"'"), left(',', wx < wp)
li = ''
end
end
end
/* help is the leading commentblock */
call mAdd op
do lx=1 by 1
li = strip(sourceLine(lx), 't')
call mAdd op, li
if pos('*/', li) > 0 then
leave
end
call writeDsn m.optDsn, m.op.
m.srcOpt = 1
return
endProcedure writeOptions
/*--- interpret the given dsn ----------------------------------------*/
interDsn: procedure expose m.
parse arg dsn
call debug 'interpreting' dsn
call readDsn dsn, x.
/* concat all the lines */
s = ''
do x=1 to x.0
l = strip(x.x)
if right(l, 1) == ',' then /* rexx continuation */
s = s left(l, length(l) - 1)
else
s = s l';' /* separate statements */
end
interpret s
call debug 'interpreted' dsn
return
endProcedure interDsn
/*--- handle the log file --------------------------------------------*/
log: procedure expose m.
parse arg fun
dsn = m.mainLib'(LOG)'
call readDsn dsn, l.
zx = l.0
cId = m.id
if fun = 'nextId' then do /* reserve the next id */
id = strip(left(l.zx, 8))
if left(id, 1) ^== 'N',
| verify(substr(id, 2), '0123456789') > 0 then
call err 'illegal id "'id'" in line' zx 'of' dsn
cId = 'N'right(1 + substr(id, 2), 4, '0')
zx = zx + 1
l.zx = left(cId, 8) date('s') left(time(), 5) 'newId'
end
else if fun = 'load' then do /* log the current id */
/* find the current id in the log */
do ax = 1 by 1 to zx while strip(left(l.ax, 8)) < cId
end
do bx = ax by 1 to zx while strip(left(l.bx, 8)) = cId
end
le = left(cId, 8) date('s') left(time(), 5) left(m.auftrag, 20),
left(sysVar(sysNode) m.db2SubSys, 8)
/* shift the remaining entries */
tbRoot = m.treeTb
tSize = mSize(tbRoot)
sx = tSize-bx+ax
if sx > 0 then do
do qx=zx by -1 to bx /* shift right */
rx = qx+sx
l.rx = l.qx
end
end
else if sx < 0 then do /* shift left */
do qx=bx by 1 to zx
rx = qx+sx
l.rx = l.qx
end
end
zx = zx + sx
/* one log line for each table */
do tx=1 to tSize
tn = mAtSq(tbRoot, tx)
in = word(mVaAtK1(tn, 'intos'), 1)
owTb = mVaAtK1(tn, 'ow')'.'mVaAtK1(tn, 'tb')
if length(owTb) < 19 then
owTb = left(owTb, 19)
dbTs = mVaAtK1(tn, 'db')'.'mVaAtK1(tn, 'ts')
if length(dbTs) < 19 then
dbTS = left(dbTS, 19)
rx = ax + tx - 1
l.rx = le ,
left(mFirst('RESUME', '???', in, mPar(in)), 3) ,
owTb dbTs mVaAtK1(tn, 'parts')
end
end
else do
call err 'bad log fun' fun
end
call writeDsn dsn, l., zx
return substr(cId, 2)
endProcedure log
/*--- analyze a punchfile ----------------------------------------------
puDsn: spec for input dsn to analyze
ldRoot: parentNode of node for each load
puRoot: parent node for each punchFile ---------------------*//
analyzePunch: procedure expose m.
parse arg puDsn, ldRoot, puRoot
pu = readDsnOpen(ooNew(), puDsn)
co = treeCopyOpen(ooNew(), pu, '??', 0)
sc = scanUtilReader(ooNew(), co)
tmpl = mAddKy(puRoot, 'punch', puDsn)
do forever
if utilNext == 'TEMPLATE' then do
utilNext = analyzeTemplate(sc, tmpl)
end
else if utilNext == 'LOAD' then do
ch = mAddKy(ldRoot, 'load', tmpl)
utilNext = analyzeLoad(sc, co, ch, tmpl)
end
else do
u = scanUtil(sc)
if u == 'u' then
utilNext = m.val
else if u == '' then
leave
end
end
call ooReadClose pu
return
endProcedure analyzePunch
/*--- analyze template -----------------------------------------------*/
analyzeTemplate: procedure expose m.
parse arg sc, nd
if 'u' = scanUtil(sc) then
return m.val
else if m.utilType ^= 'n' then
call scanErr sc, 'template name expected'
na = m.tok
ch = mAddK1(nd, na, 'template')
do forever
if 'u' == scanUtil(sc) | m.utilType = '' then do
return m.val
end
else if m.utilType == 'n' & m.scan.sc.utilBrackets = 0 then do
parm = m.val
if wordPos(parm, 'DSN VOLUME') > 0 then
call mAddK1 ch, parm, scanUtilValue(sc)
else if parm = 'VOLUMES' then
call mAddK1 ch, 'VOLUME', scanUtilValue(sc)
else
call debug 'ignoring' parm scanUtilValue(sc)
end
else do
call debug 'template chunck' m.utilType m.tok
end
end
endProcedure analyzeTemplate
/*--- analyze load ---------------------------------------------------*/
analyzeLoad: procedure expose m.
parse arg sc, cc, ldNd, tmplNd
if scanUtil(sc) ^== 'n' & m.val ^== 'DATA' then
call scanErr sc, 'load data expected'
nd = ldNd
/* the load into syntax is too complex to analyze completly
instead, we use treeCopy to copy all unAnalyzed text */
call treeCopyDest cc, nd
call treeCopyOn cc, m.scan.sc.pos
do while 'u' ^== scanUtil(sc) & m.utilType ^== ''
if m.utilType ^= 'n' | m.scan.sc.utilBrackets ^= 0 then
iterate
opt = m.val
if wordPos(m.val, 'INDDN RESUME SHRLEVEL REPLACE COPYDDN' ,
'LOG INTO PART') < 1 then
iterate
call treeCopyOff cc, m.scan.sc.pos - length(m.tok)
if opt == 'INTO' then do
if scanUtil(sc) ^== 'n' | m.val ^== 'TABLE' then
call scanErr sc, 'into table expected'
if scanUtil(sc) ^== 'n' & m.utilType ^== '"' then
call scanErr sc, 'table name expected'
nd = mAddKy(ldNd, opt, '')
call mAddK1 nd, 'ow', strip(m.val)
if scanUtil(sc) ^== '.' then
call scanErr sc, '.table expected'
if scanUtil(sc)^=='n' & m.utilType^=='"' then
call scanErr sc, 'table name expected'
call mAddK1 nd, 'tb', strip(m.val)
call treeCopyDest cc, nd
end
else if opt == 'INDDN' then do
dd = scanUtilValue(sc)
ddNd = mAtK1(tmplNd, dd)
if ddNd = '' & m.load = '' then
call err 'template not found for inDDn' dd
call mAddK1 nd, 'INDDN', ddNd
end
else if opt == 'REPLACE' then do
call mAddK1 nd, opt, 1
end
else do
call mAddK1 nd, opt, scanUtilValue(sc)
end
call treeCopyOn cc, m.scan.sc.pos
end
call treeCopyOff cc, m.scan.sc.pos - length(m.tok)
return m.val
endProcedure analyzeLoad
/*--- check loads and override values --------------------------------*/
checkOverride: procedure expose m.
parse arg ldRoot
rs = translate(m.resume)
do lx=1 to mSize(ldRoot) /* for each load */
ld = mAtSq(ldRoot, lx)
loDdn = overrideLoad(mAtK1(ld, 'INDDN'))
if rs <> '' then
call mPut ld, 'RESUME', rs
do ix=1 to mSize(ld) /* for each into */
in = mAtSq(ld, ix)
if mKy(in) <> 'INTO' then
iterate
nd = mAtK1(in, 'PART')
if nd = '' then
nd = mAddK1(in, 'PART', '*')
part = m.nd
info = mVaAtK1(in, 'ow')'.'mVaAtK1(in, 'tb') 'part' part
if part == '*' then
nop
else if ^ datatype(part, 'n') | length(part) > 5 then
call scanErr sc, 'bad partition' part 'for' info
else
part = right(part, 5, 0)
m.nd = part
inDdn = overrideLoad(mAtK1(in, 'INDDN'))
if inDDn = '' then do
if loDDn = '' then
call err 'no inDDN for' info
DDn = loDDn
end
else do
if loDDn <> '' then
call err 'inDDn twice specified for' info
ddn = inDDn
end
if m.volume <> '' & mAtK1(ddn, 'VOLUME') = '' then
call mAddK1 in, 'VOLUME', m.volume
if rs <> '' then
call mPut in, 'RESUME', rs
end /* for each into */
end /* for each load */
return
endProcedure checkOverride
/*--- override or modify the load pointed to by nd -------------------*/
overrideLoad: procedure expose m.
parse arg nd
if nd == '' then
return nd
if m.load <> '' then do
if symbol('m.loadNd') <> 'VAR' then do
m.loadNd = mAddK1(m.treeRoot, 'overLoad')
call ds2Tree m.load, m.loadNd
end
m.nd = m.loadNd
end
if m.volume <> '' then
call mPut m.nd, 'VOLUME', m.volume
return nd
endProcedure overrideLoad
/*--- create tables: find destination creator and ts in catalogue
create tree for destination table and
link it to all into nodes -----------------------*/
createTables: procedure expose m.
parse arg ldRoot, tbRoot
do lx=1 to mSize(ldRoot)
ld = mAtSq(ldRoot, lx)
do ix=1 to mSize(ld)
in = mAtSq(ld, ix)
if mKy(in) <> 'INTO' then
iterate
oOw = mVaAtK1(in, 'ow')
oTb = mVaAtK1(in, 'tb')
if symbol('old.oOw.oTb') = 'VAR' then do
nd = old.oOw.oTb
call debug 'found' nd 'for old table' oOw'.'oTb
end
else do /* search table in db2 catalog */
parse value queryTable(oOw, oTb) ,
with nOw'.'nTb':'db'.'ts
nd = mAtK1(tbRoot, nOw'.'nTb)
if nd <> '' then do
call debug 'found' nd 'for new table' nOw'.'nTb
end
else do /* create node for table */
nd = mAddK1(tbRoot, nOw'.'nTb)
call mAddK1 nd, 'ow', nOw
call mAddK1 nd, 'tb', nTb
call mAddK1 nd, 'db', db
call mAddK1 nd, 'ts', ts
call mAddK1 nd, 'parts'
call debug 'created' nd 'for new table' nOw'.'nTb
end
old.oOw.oTb = nd
call debug 'map old tb' oOw'.'oTb 'to' nOw'.'nTb 'nd' nd
end
m.in = nd
pp = mVaAtK1(in, 'PART')
op = mVaAtK1(nd, 'parts')
if op = '' then do
np = pp
ni = in
if pp = '*' then
call mAddK1 nd, 'tsPa', 'TS'
else
call mAddK1 nd, 'tsPa', 'PA'
end
else if pp = '*' | op = '*' then
call err 'part * not alone in tb' nOw'.'nTb
else if wordPos(pp, op) > 0 then
call err 'part' pp 'duplicate n tb' nOw'.'nTb
else do /* add new partition into sorted list */
do wx=1 to words(op) while pp > word(op, wx)
end
np = subword(op, 1, wx-1) pp subword(op, wx)
oi = mVaAtK1(nd, 'intos')
ni = subword(oi, 1, wx-1) in subword(oi, wx)
end
call mPut nd, 'parts', np
call mPut nd, 'intos', ni
end
end
return
endProcedure createTables
/*--- query the db2 catalog for creator, db, ts etc.
of the tables to load --------------------------------------*/
queryTable: procedure expose m.
parse upper arg ow, tb
sql = "select t.name, t.creator, tsName, t.dbname, s.nTables" ,
"from sysibm.systables t, sysibm.systablespace s" ,
"where t.type = 'T'" ,
"and s.dbName = t.dbName and s.name = t.tsName" ,
"and t.name = '"strip(tb)"' and t.creator"
if m.owner <> '' then do /* override owner */
sql = sql "= '"strip(m.owner)"'"
end
else if left(ow, 3) == 'OA1' then do /* translate OA1* owners */
o = substr(strip(m.db2SubSys), 3, 1)
if o = 'O' | sysvar(sysnode) <> 'RZ1' then
o = 'P'
nn = overlay(o, ow, 4)
if nn = 'OA1P' then
sql = sql "in ('OA1P', 'ODV', 'IMF')"
else
sql = sql "= '"strip(nn)"'"
end
else do /* user owner as is */
sql = sql "= '"strip(ow)"'"
end
/* execute sql and fetch row */
call adrSql 'prepare s1 from :sql'
call adrSql "declare c1 cursor for s1"
call adrSql 'open c1'
cnt = 0
do forever
call adrSql 'fetch c1 into :tb, :cr, :ts, :db, :tbCnt'
if sqlCode = 100 then
leave
cnt = cnt + 1
if cnt > 1 then
call err 'fetched more than 1 row for table' ow'.'tb ':'sql
end
if cnt = 0 then
call err 'table' ow'.'tb 'not found in catalog:' sql
else if tbCnt <> 1 then do
say 'ts' db'.'ts 'hat' tbCnt 'Tabellen'
say 'pLoad kann mit RESUME=NO Daten ueberschreiben'
say 'trotzdem weitermache (w=weiter)?'
parse upper pull a
if ^ abbrev(a, 'W') then
call err 'nicht weiter'
end
call adrSql 'close c1'
return strip(cr)'.'strip(tb)':'strip(db)'.'strip(ts)
endProcedure queryTable
/*--- write the generated jcl ----------------------------------------*/
writeJcl: procedure expose m.
parse arg dsn
x = dsnAlloc(dsn, 'SHR', jclGen)
dd = word(x, 1)
call writeDDBegin dd
call writeDD dd, 'M.JOBCARD.'
do j = 1 to m.jclCard.0
call debug 'jclCard j' M.JCLCARD.j.0
call writeDD dd, 'M.JCLCARD.'j'.'
end
call writeDDEnd dd
interpret subword(x, 2)
return
endProcedure writeJCL
/*--- generate the JCL -----------------------------------------------*/
jclGenStart: procedure expose m.
parse arg pnRoot, tbRoot
call jclIni
/* show our infos in comment */
call jcl '10'copies('*', 69)
parse source . . ggS3 .
call jcl '10* load job generated by' ggS3 ,
'in' sysvar(sysnode) 'for' m.db2SubSys 'by' userid()
call jcl '10* id' m.id 'at' date('s') time()
do px=1 to mSize(pnRoot) /* show input punch */
pn = mAtSq(pnRoot, px)
call jcl '1* punch ' m.pn
end
do tx=1 to mSize(tbRoot) /* show output tables */
tn = mAtSq(tbRoot, tx)
call jcl '1* load ' ,
mVaAtK1(tn, 'ow')'.'mVaAtK1(tn, 'tb') ,
'in' mVaAtK1(tn, 'db')'.'mVaAtK1(tn, 'ts')
p = mVaAtK1(tn, 'parts')
if p <> '*' then
call jcl '1* ' words(p) 'partitions between' word(p, 1),
'and' word(p, words(p))
intos = mVaAtK1(tn, 'intos')
do ix=1 to words(intos) /* show input tables and dsns */
in = word(intos, ix)
owTb = mVaAtK1(in, 'ow')'.'mVaAtK1(in, 'tb')
if i.owTb == 1 then
iterate
i.owTb = 1
if length(owTb) < 16 then
owTb = left(owTb, 16)
tmpl = mFirst('INDDN', , in, mPar(in))
call jcl '1* from' owTb mVaAtK1(tmpl, 'DSN')
end
drop i.
end
call jcl '10'copies('*', 69) /* end of info comment */
call jcl '1* alle Dataset löschen, die wir nachher neu erstellen'
call jcl '1'jclExec() 'PGM=IEFBR14'
return
endProcedure jclGenStart
/*--- copy all input dsns to our Prefix ------------------------------*/
jclGenCopyInput: procedure expose m.
parse arg puRoot, tbRoot
do px=1 to mSize(puRoot) /* punch files */
pn = mAtSq(puRoot, px)
call jcl '2* Originales Punchfile Kopieren'
call jclCopy ds2Tree(m.pn, m.jclNdFr) ,
, ds2Tree(genSrcDsn('OPUNCH', px), m.jclNdTo)
end
/* load input dsns */
m.dsnLoadTS = genDsn('&DB..&TS.', 'LOAD')
m.dsnLoadPA = genDsn('&DB..&TS..P&PA.', 'LOAD')
do tx=1 to mSize(tbRoot)
tn = mAtSq(tbRoot, tx)
intos = mVaAtK1(tn, 'intos')
do ix=1 to words(intos)
in = word(intos, ix)
ln = mPar(in)
if mAtK1(in, 'INDDN') <> '' then
dn = mVaAtK1(in, 'INDDN')
else
dn = mVaAtK1(ln, 'INDDN')
dnDsn = mVaAtK1(dn, 'DSN')
chDsn = expDsn(in, dnDsn)
if dnDsn <> chDsn then do
dn = mAddTree(mRemCh(m.jclNdFr), dn)
call mPut dn, 'DSN', chDsn
end
vv = 'DSNLOAD'mVaAtK1(tn, 'tsPa')
newLo = expDsn(in, m.vv)
call jcl '2* Originales Loadfile Kopieren'
call jclCopy dn, dsNew2Tree(newLo, m.jclNdTo)
end
end
return
endProcedure jclGenCopyInput
/*--- generate the db2 utility statements for copy & unload ----------*/
jclGenPunch: procedure expose m.
parse arg tbRoot, puDsn
if m.mgmtClas == '' then
m.mgmtClasCl = ''
else
m.mgmtClasCl = 'MGMTCLAS('m.mgmtClas')'
call jcl '2* Neues Punchfile Kopieren'
call jcl '2'jclExec() 'PGM=IEBGENER'
call jcl '20SYSPRINT DD SYSOUT=*'
call jcldd 2, 's', 'SYSUT2', ds2Tree(puDsn, m.jclNdTo)
call jcl '20SYSUT1 DD *'
/* add a second copy template,
to avoid duplicate on the copy before/after */
call jcl '2 TEMPLATE TCOPYQ'
call jcl '2 ' ,
"DSN('&SSID..&DB..&SN..Q&PART(2)..D&DATE(3)..T&TIME.')"
call jcl '2 DATACLAS (NULL12) MGMTCLAS(COM#A011)'
call jcl '2 SPACE (10,250) CYL'
call jcl '2 TEMPLATE TMLOADTS'
call jcl "2 DSN('"m.dsnLoadTS"')"
call jcl "2 DISP(SHR,KEEP,KEEP)"
call jcl '2 TEMPLATE TMLOADPA'
call jcl "2 DSN('"m.dsnLoadPA"')"
call jcl "2 DISP(SHR,KEEP,KEEP)"
xx = overlay(".UNLO", m.dsnLoadTS, lastPos(".", m.dsnLoadTS))
call jcl '2 TEMPLATE TMULTS'
call jcl "2 DSN('"xx"')"
call jcl '2 DATACLAS (NULL12) MGMTCLAS(COM#A011)'
call jcl '2 SPACE (10,250) CYL'
xx = overlay(".UNLO", m.dsnLoadPA, lastPos(".", m.dsnLoadPA))
call jcl '2 TEMPLATE TMULPA'
call jcl "2 DSN('"xx"')"
call jcl '2 DATACLAS (NULL12) MGMTCLAS(COM#A011)'
call jcl '2 SPACE (10,250) CYL'
xx = overlay(".UNPU", m.dsnLoadTS, lastPos(".", m.dsnLoadTS))
call jcl '2 TEMPLATE TMULPUN'
call jcl "2 DSN('"xx"')"
call jcl '2 DATACLAS (NULL12) MGMTCLAS(COM#A011)'
call jcl '2 SPACE (1,10) CYL'
do tx=1 to mSize(tbRoot)
tn = mAtSq(tbRoot, tx)
intos = mVaAtK1(tn, 'intos')
call jclGenPunchCopyUnload tn, tx
call jclGenPunchInto word(intos, 1), 0, tn
do ix=1 to words(intos)
in = word(intos, ix)
call jclGenPunchInto in, ix, tn
end
end
return
endProcedure jclGenPunch
/*--- generate utility copy and unload statement for table tn --------*/
jclGenPunchCopyUnload: procedure expose m.
parse arg tn, tx
parts = mVaAtK1(tn, 'parts')
paMin = word(parts, 1)
paMax = word(parts, words(parts))
dbTs = mVaAtK1(tn, 'db')'.'mVaAtK1(tn, 'ts')
if parts == '*' then do
call jcl '2 COPY TABLESPACE' dbTS 'FULL YES'
end
else do
call jcl '2 LISTDEF COLI'tx
call jcl '2 INCLUDE TABLESPACE' dbTs 'PARTLEVEL'
call jcl '2 COPY LIST COLI'tx 'FULL YES PARALLEL'
end
call jcl '2 COPYDDN (TCOPYQ) SHRLEVEL REFERENCE'
/* unload before */
call jcl '2 UNLOAD TABLESPACE' dbTS
if parts = '*' then
nop
else if paMin == paMax then
call jcl '2 PART' paMin
else
call jcl '2 PART' paMin ':' paMax
call jcl '2 FROM TABLE' mVaAtK1(tn, 'ow') ,
|| '.'mVaAtK1(tn, 'tb')
call jcl '2 PUNCHDDN TMULPUN UNLDDN TMUL'mVaAtK1(tn,'tsPa')
call jcl '2 SHRLEVEL REFERENCE'
return
endProcedure jclGenPunchCopyUnload
/*--- generate the db2 utility statements for 1 load or into ---------*/
jclGenPunchInto: procedure expose m.
parse arg in, ix, tn
pa = mVaAtK1(in, 'PART')
ln = mPar(in)
rs = mFirst('RESUME', 'NO', in, ln)
if rs = 'NO' then do
rsSp = 'RESUME NO REPLACE COPYDDN TCOPYD'
end
else do
rsSp = 'RESUME YES'
sh = mFirst('SHRLEVEL', '', in, ln)
if sh <> '' then
rsSp = rsSp 'SHRLEVEL' sh
end
if ix == 0 then do
if pa == '*' then do
call jcl '3 LOAD DATA INDDN TMLOADTS'
call jcl '3 ' rsSp 'LOG' rs
if rs == 'NO' then
call jcl '3 STATISTICS TABLE(ALL)' ,
'INDEX(ALL) UPDATE ALL'
end
else do
call jcl '3 LOAD DATA LOG' rs
end
jn = mPar(in)
end
else do
call jcl '3 INTO TABLE' mVaAtK1(tn,'ow')'.'mVaAtK1(tn,'tb')
if pa <> '*' then do
call jcl '3 PART' pa
call jcl '3 ' rsSp
call jcl '3 INDDN TMLOADPA'
end
jn = in
end
do cx=1 to mSize(jn)
cn = mAtSq(jn, cx)
key = mKy(cn)
if key = '' then
call jcl '3 'm.cn
end
return
endProcedure jclGenPunchInto
/*--- jcl to run the db2 utility -------------------------------------*/
jclGenUtil: procedure expose m.
parse arg pun, dbSys
call jcl '4* db2 utility macht die Arbeit'
call jcl '42IF RC=0 THEN'
call jcl '4'jclExec() "PGM=DSNUTILB,PARM='"dbSys","userid()".UN.LO'"
call jcl '40SYSMAP DD DISP=(,PASS),UNIT=SYSDA'
call jcl '40SYSUT1 DD DISP=(,PASS),UNIT=SYSDA'
call jcl '40SORTOUT DD DISP=(,PASS),UNIT=SYSDA'
call jcl '40SYSERR DD SYSOUT=*'
call jcl '40SYSPRINT DD SYSOUT=*'
call jcl '40UTPRINT DD SYSOUT=*'
call jcl '40SYSTEMPL DD DISP=SHR,DSN='dbSys'.DBAA.LISTDEF(TEMPL)'
call jcl '40SYSIN DD DISP=SHR,DSN='pun
call jcl '42ENDIF'
return
endProcedure jclGenUtil
/*--- generate DSN for this id, with the given llq and index ---------*/
genDSN: procedure expose m.
parse arg dbTs, leLlq, lx
llq = leLLq || lx
if length(llq) > 8 then
llq = left(leLlq, 8 - length(lx)) || lx
if dbTs = '' then
return m.dsnPref || '.'m.id'.'llq
else
return m.dsnPref || '.'m.id'.'dbTs'.'llq
endProcedure genDSN
/*--- generate DSN for the src DS of the id, with member and index ---*/
genSrcDsn: procedure expose m.
parse arg mbr, lx
dsn = m.dsnPref'.'m.id'.SRC'
if mbr = '' then
return dsn
m = mbr || lx
if length(m) > 8 then
m = left(mbr, 8 - length(lx)) || lx
return dsn'('m')'
endProcedure genSrcDsn
/*--- expand variables in dsn from the into node in ------------------*/
expDsn: procedure expose m.
parse arg in, dsn
do forever
px = pos('&', dsn)
if px = 0 then
return dsn
dx = pos('.', dsn, px+1)
if dx <= px then
call err 'no . after & in' dsn
k = translate(substr(dsn, px+1, dx-px-1))
if k = 'DB' then
v = mVaAtK1(m.in, 'db')
else if k = 'PART' | k = 'PA' then
v = mVaAtK1(in, 'PART')
else if k = 'TS' | k = 'SN' then
v = mVaAtK1(m.in, 'ts')
else
call err 'bad variable' k 'in' dsn
dsn = left(dsn, px-1) || v || substr(dsn,dx+1)
end
endProcedure expDsn
/*--- transform the dataset spec into a tree at node nd --------------*/
ds2tree: procedure expose m.
parse arg spec, nd
call mRemCh nd
upper spec
dsn = ''
do ix=1 by 1
w = word(spec, ix)
if w = '' then
leave
if abbrev(w, 'DSN(') then
dsn = substr(w, 5, length(w) - 5)
else if abbrev(w, 'VOLUME(') then
call mAddK1 nd, 'VOLUME', substr(w, 8, length(w) - 8)
else if dsn == '' then
dsn = w
end
if dsn ^= '' then
call mAddK1 nd, 'DSN', dsn
return nd
endProcedure ds2Tree
/*--- transform the spec for a new DS into a tree at node nd ---------*/
dsNew2tree: procedure expose m.
parse arg spec, nd
x = ds2Tree(spec, nd)
if m.mgmtClas <> '' then
call mPut x, 'MGMTCLAS', m.mgmtClas
return x
endProcedure dsNew2tree
/*--- jcl to copy a sequential DS ------------------------------------*/
jclCopy: procedure expose m.
parse arg fr, to
call jcl '2'jclExec() 'PGM=IEBGENER'
call jcl '20SYSPRINT DD SYSOUT=*'
call jcldd 2, 'o', 'SYSUT1', fr
if pos('(', mVaAtK1(to, 'DSN')) > 0 then
call jcldd 2, 's', 'SYSUT2', to
else
call jcldd 2,'nr', 'SYSUT2', to, fr
return
endProcedure jclCopy
/*--- generate a jcl dd statement
opt: n=new, s=shr, r=remove in first step
dd: ddname
nd: tree representation dataset spec
like: tree representation of like dataset ----------------------*/
jclDD: procedure expose m.
parse arg j, opt, dd, nd, like
new = pos('n', opt) > 0
li=left('0'dd, 12)'DD'
if new then
li = li 'DISP=(NEW,CATLG,DELETE)'
else if pos('s', opt) > 0 then
li = li 'DISP=SHR'
else
li = li 'DISP=OLD'
do cx=1 by 1 to m.nd.0
ch = nd'.'cx
va = m.ch
ky = mKy(ch)
if wordPos(ky, 'DSN MGMTCLAS') > 0 then
li = jclDDClause(j, li, ky'='va)
else if ky == 'VOLUME' then
li = jclDDClause(j, li, 'VOL=SER=('va'),UNIT=DISK')
else
call err 'bad dd attribute' ky'='va
end
if like == '' then do
end
else if like == 'fb80' then do
li = jclDDClause(j, li, 'RECFM=FB,LRECL=80')
end
else do
if '' == mAtK1(like, 'VOLUME') then do
li = jclDDClause(j, li, 'LIKE='mVaAtK1(like, 'DSN'))
end
else do
aa = jcl2dsn(mVaAtK1(like, 'DSN')) ,
'VOLUME('mVaAtK1(like, 'VOLUME')')'
lRc = listDsi(aa)
if lRc <> 0 then
call err 'rc' lRc from 'listDsi' aa
if sysUnits = 'CYLINDER' then
u = 'CYL'
else if sysUnits = 'TRACK' | sysUnits = 'BLOCK' then
u = left(sysUnits, 2) || 'K'
else
call err 'bad sysunits from listDsi:' sysUnits
li = jclDDClause(j, li, 'SPACE=('u',('sysPrimary',' ,
|| sysSeconds'))')
li = jclDDClause(j, li, 'RECFM='sysRecFm)
end
end
call jcl j || li
if new & pos('r', opt) > 0 then
call jclRemove nd
return
endProcedure jclDD
/*--- add a DS to the remove step ------------------------------------*/
jclRemove: procedure expose m.
parse arg nd
m.jclRemove = m.jclRemove + 1
li = left('0RM'm.jclRemove, 12)'DD DISP=(MOD,DELETE,DELETE)'
li = jclDDClause(1, li, 'DSN='mVaAtK1(nd, 'DSN'))
call jcl '1'li
return
endProcedure jclRemove
/*--- add one clause to a jcl dd statement
if the line overflows write it out
return rest of line ---------------------------------------*/
jclDDClause: procedure expose m.
parse arg j, li, cl
if left(li, 1) = '6' then
a = 15
else
a = 1
if a + length(li) + length(cl) < 70 then
return li','cl
call jcl j || li','
return '6'cl
endProcedure jclDDClause
/*--- generate an exec statement -------------------------------------*/
jclExec: procedure expose m.
m.jclStep = m.jclStep + 1
return left('0S'm.jclStep, 10)'EXEC'
endProcedure jclExec
/*--- initialize jcl generator ---------------------------------------*/
jclIni: procedure expose m.
m.jclCard.0 = 9
do x=1 to m.jclCard.0
m.jclCard.x.0 = 0
end
m.jclRemove=0
m.jclStep = 0
m.jclPref.0 = '//'
m.jclPref.2 = left('//', 11)
m.jclPref.4 = left('//', 13)
m.jclPref.6 = left('//', 15)
xx = ' '
m.jclPref.xx = ''
xx = '*'
m.jclPref.xx = '//*'
m.jclNdFr = mRoot()
m.jclNdTo = mRoot()
return
endProcedure jclIni
/*--- output one jcl line:
j (char 1): which stem
t (char 2): prefix
m (char 3 to end): message ----------------------------------*/
jcl: procedure expose m.
parse arg j 2 t 3 m
if m.orderTS & j > 2 then
j = 2
x = m.jclCard.j.0 + 1
m.jclCard.j.0 = x
if m.debug then
if symbol('m.jclPref.t') <> 'VAR' then
call err undefined jclPref for t 'in' j || t || m
m.jclCard.j.x = m.jclPref.t || strip(m, 't')
if m.debug then
say 'jcl'j m.jclCard.j.x
return
endProcedure jcl
/*--- add one line text to the stem m.st -----------------------------*/
/*--- copy a DS in tso -----------------------------------------------*/
copyDS: procedure
parse arg fj fa, tj ta
say 'copyDs from' fj fa 'to' tj ta
call adrTso 'free dd(sysut1)', '*'
call adrTso 'alloc dd(sysut1) shr dsn('jcl2dsn(fj)')' fa
call adrTso 'free dd(sysut2)', '*'
call adrTso 'delete' jcl2dsn(tj), '*'
call adrTso 'alloc dd(sysut2) new catalog refdd(sysut1)' ,
'dsn('jcl2dsn(tj)')' ta
call adrTso 'alloc dd(sysin) dummy reuse'
call adrTso 'alloc dd(sysprint) sysout(T) reuse'
/* call iebGener */
CALL ADRTSO 'CALL *(IEBGENER)', '*'
say 'iebGener rc' rc 'result' result
call adrTso 'free dd(sysin sysprint sysut1 sysut2)'
return
endProcedure copyDS
/* treeCopy : make a copy of a reader to a tree ***********************/
treeCopyLine: procedure expose m.
parse arg m, nx
if ^m.treeCopy.m.read then
return
if nx > length(m.treeCopy.m.line) then
qx = length(m.treeCopy.m.line)
else
qx = nx - 1
if m.treeCopy.m.on then do
le = left(m.treeCopy.m.line, qx)
if le <> '' then
call mAddKy m.treeCopy.m.dest, , le
end
m.treeCopy.m.line = overlay('', m.treeCopy.m.line, 1, qx)
return
endProcedure treeCopyLine
treeCopyDest: procedure expose m.
parse arg m, m.treeCopy.m.dest
return
endProcedure treeCopyDest
/*--- start copying at character nx of current line ------------------*/
treeCopyOn: procedure expose m.
parse arg m, nx
if m.treeCopy.m.on then
return
call treeCopyLine m, nx
m.treeCopy.m.on = 1
return
endProcedure treeCopyOn
/*--- stop copying at character nx of current line -------------------*/
treeCopyOff: procedure expose m.
parse arg m, nx
if ^ m.treeCopy.m.on then
return
call treeCopyLine m, nx
m.treeCopy.m.on = 0
return
endProcedure treeCopyOff
treeCopyRead: procedure expose m.
parse arg m, rdr, var
call treeCopyLine m, 1 + length(m.treeCopy.m.line)
m.treeCopy.m.read = ooRead(rdr, var)
m.treeCopy.m.line = m.var
return m.treeCopy.m.read
endProcedure treeCopyRead
treeCopyOpen: procedure expose m.
parse arg m, rdr, m.treeCopy.m.dest, isOn
call ooDefRead m, 'res = treeCopyRead("'m'", "'rdr'", var);'
m.treeCopy.m.read = 0
m.treeCopy.m.on = isOn = 1
return m
endProcedure treeCopyOpen
/* copy scanUtil begin *************************************************
scan db2 utility input statements using scan and a reader
**********************************************************************/
/*--- initialize with reader inRdr ----------------------------------*/
scanUtilReader: procedure expose m.
parse arg m, inRdr
call scanReader m, inRdr
call scanOptions sc, , , '--'
m.scan.m.utilBrackets = 0
return m
endProcedure scanUtilReader
/*--- scan next token and put its type in m.utilType:
'u' a utility name
'n' a name
'"' a quoted name
"'" an apostroph'd string
'.' a .
',' a ,
'v' a value
'' at end
---------------------------------------------------------------*/
scanUtil: procedure expose m.
parse arg sc
call scanSpaceNl sc
ty = '?'
if scanLit(sc, '(') then do
m.scan.sc.utilBrackets = m.scan.sc.utilBrackets + 1
end
else if scanLIT(sc, ')') then do
m.scan.sc.utilBrackets = m.scan.sc.utilBrackets - 1
if m.scan.sc.utilBrackets < 0 then
call scanErr sc, 'unmatched closing bracket )'
end
else if scanLit(sc, ',') then do
end
else if scanLit(sc, '.') then do
end
else if scanString(sc, "'") then do
end
else if scanString(sc, '"') then do
end
else if scanName(sc) then do
m.val = translate(m.tok)
if m.scan.sc.utilBrackets > 0 then
ty = 'n'
else if 0 < wordPos(m.val, 'BACKUP CATENFM CATMAINT CHECK' ,
'COPY COPYTOCOPY DIAGNOSE EXEC LISTDEF LOAD' ,
'MERGECOPY MODIFY OPTIONS QUIESCE REBUILD' ,
'RECOVER REORG REPAIR REPORT RESTORE' ,
'RUNSTATS STOSPACE TEMPLATE UNLOAD') then
ty = 'u'
else
ty = 'n'
end
else if scanVerify(sc, ' (),''"', 'm') then do
ty = 'v'
m.val = translate(m.tok)
end
else if ^scanAtEnd(sc) then do
call scanErr sc, 'scanUtil stopped before end'
end
else do
/* say 'scanUtil return atEnd' */
ty = ''
m.val = ''
end
if ty == '?' then
m.utilType = left(m.tok, 1)
else
m.utilType = ty
return m.utilType
endProcedure scanUtil
/*--- scan a value or a bracketed list of values ---------------------*/
scanUtilValue: procedure expose m.
parse arg sc
if '(' ^== scanUtil(sc) then
return scanUtilValueOne(sc)
v = ''
brx = m.scan.sc.utilBrackets
do forever
call scanUtil sc
one = scanUtilValueOne(sc)
if one == '' then
call scanErr sc, 'eof in brackets'
else if brx > m.scan.sc.utilBrackets then
return v
v = v || one
end
endProcedure scanUtilValue
scanUtilValueOne: procedure expose m.
parse arg sc
if utilType == '' then
return ''
else if m.utilType == 'u' then
call scanErr sc, 'util in scanUtilValueOne'
else if pos(m.utilType, 'nv''"') > 0 then
return m.val
else
return m.tok
endProcedure scanUtilValueOne
/* copy scanUtil end **************************************************/
/* 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(*)'
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')'
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 adrSql begin *************************************************/
/**********************************************************************
adrSql: execute sql thru the dsnRexx interface
***********************************************************************/
adrSql: /* no procedure, to keep variables sql... */
parse arg ggSqlStmt, ggRet, ggNo
if ggNo <> '1' then
ggSqlStmt = 'execSql' ggSqlStmt
address dsnRexx ggSqlStmt
/* say 'sqlCode' sqlCode 'rc' rc 'for' ggSqlStmt ggNo */
if rc = 0 then do
return 0
end
else if rc < 0 then do
if ggRet == '*' then nop
else if wordPos(sqlCode, ggRet) > 0 then nop
else
call err "sql rc" rc sqlmsg() ggNo
end
else if sqlWarn.0 ^== ' ' then do
say 'warning' sqlMsg() ggNo
end
return sqlCode
endSubroutine adrSql
adrSqlConnect: procedure
parse arg ggSys, ggRetCon
if adrTSO("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" ggSys, ggRetCon ,1
return
endProcedure adrSqlConnect
adrSqlDisconnect: procedure
parse arg ggRet
call adrSql "disconnect ", ggRet, 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
ggXX = pos(':', ggSqlStmt)
ggVV = ''
if ggXX > 0 then do
ggVV = word(substr(ggSqlStmt, ggXX + 1), 1)
ggXX = verify(ggVV, ' ,:+-*/&%?|', 'm')
if ggXX > 0 then
ggVV = left(ggVV, ggXX-1)
ggVV = 'with' ggVV '=' value(ggVV)
end
return 'sqlCode' sqlCode 'state' sqlState 'warn' ggW ,
'errMc' strip(translate(sqlerrmc, ',', 'FF'x)) ,
'stmt = ' ggSqlStmt ggVV
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 = adrTso('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
/* copy adrSql end *************************************************/
/* copy scan begin ****************************************************
Scan: scan an input:
scanLine(m,ln) : begin scanning a single line
scanStem(m,ln) : begin scanning all lines in a stem
scanAtEOL(m) : returns whether we reached end of line
scanAtEnd(m) : returns whether we reached end of input
scanLit(m,lit) : scan Literal lit if present or return 0
scanChar(m,n) : scan next n characters
scanName(m) : scan a name
scanNum(m) : scan integer (without sign)
scanString(m,q): scan a String with quote q. (with doubble = 1)
scanVerify(m,c,o): verify(...,c,o,...)
scanKeyValue(m): scan a key = value clause (with spaces)
scanWord(m,u) : scan a space delimited word or a string,
if u=1 then uppercase non-strings
scanErr(m, txt): error with current scan location
m is an adress, to store our state
if a scan function succeeds, the scan posititon is moved
returns: true if scanned, false otherwise
m.tok ==> last token
m.val ==> last value for scanString/Word/KeyValue
m.key ==> key for scanKeyValue
m.scan.m.pos ==> scan position
m.scan.m.src ==> scan source
***********************************************************************/
/*--- begin scanning a single line -----------------------------------*/
scanLine: procedure expose m.
parse arg m, m.scan.m.src
call scanStart m
return
endProcedure scanLine
/*--- begin scanning the lines of a stem -----------------------------*/
scanReader: procedure expose m.
parse arg m, inRdr
call scanStart m, inRdr
m.scan.m.src = ''
m.scan.m.atEnd = ^ scanNL(m, 1)
return m
endProcedure scanReader
/*--- switch to next line if atEOF or argument unCond=1 --------------*/
scanNL: procedure expose m.
parse arg m, unCond
if unCond == 1 then
m.scan.m.pos = 1 + length(m.scan.m.src)
else if m.scan.m.pos <= length(m.scan.m.src) then
return 0
if m.scan.m.reader = '' then
return 0
else if ^ ooRead(m.scan.m.reader, 'SCAN.'m'.SRC') then do
m.scan.m.atEnd = 1
return 0
end
m.scan.m.pos = 1
m.scan.m.tok = ''
return 1
endProcedure scanNL
/*--- initialize scanner for m --------------------------------------*/
scanStart: procedure expose m.
parse arg m, m.scan.m.reader
m.scan.m.pos = 1
m.tok = ''
m.val = ''
m.key = ''
if symbol('m.scan.m.Name') ^== 'VAR' then do
m.scan.LC = 'abcdefghijklmnopqurstuvwxyz'
m.scan.UC = 'ABCDEFGHIJKLMNOPQURSTUVWXYZ'
m.scan.Alpha = m.scan.LC || m.scan.UC
m.scan.AlNum = '0123456789' || m.scan.ALPHA
m.scan.m.Name1 = m.scan.ALPHA
m.scan.m.Name = m.scan.ALNUM
m.scan.m.comment = ''
end
return
endProcedure scanStart
/*--- set options name characters, comment characters ----------------*/
scanOptions: procedure expose m.
parse arg m, nameOne, namePlus, comm
if symbol('m.scan.m.Name') ^== 'VAR' then
call scanStart
if nameOne ^== '' then
m.scan.m.Name1 = nameOne
if nameOne ^= '' | namePlus ^== '' then
m.scan.m.name = m.scan.m.name1 || namePlus
m.scan.m.comment = comm
return
endProcedure scanBegin
/*--- return true/false whether we are at the end of the line --------*/
scanAtEOL: procedure expose m.
parse arg m
return m.scan.m.pos > length(m.scan.m.src)
endProcedure scanAtEOL
/*--- return true/false whether we are at the end of the input -------*/
scanAtEnd: procedure expose m.
parse arg m
if m.scan.m.pos <= length(m.scan.m.src) then
return 0
if m.scan.m.reader = '' then
return 1
else
return m.scan.m.atEnd
endProcedure scanAtEnd
/*--- scan len characters --------------------------------------------*/
scanChar: procedure expose m.
parse arg m, len
nx = 1 + length(m.scan.m.src)
if len ^== '' then
if nx > m.scan.m.pos + len then
nx = m.scan.m.pos + len
m.tok = substr(m.scan.m.src, m.scan.m.pos, nx - m.scan.m.pos)
if nx = m.scan.m.pos then
return 0
m.scan.m.pos = nx
return 1
endProcedure scanChar
/*--- scan the literal lit ------------------------------------------*/
scanLit: procedure expose m.
parse arg m, lit
if ^ abbrev(substr(m.scan.m.src, m.scan.m.pos), lit) then
return 0
m.scan.m.pos = m.scan.m.pos + length(lit)
m.tok = lit
return 1
endProcedure scanLit
/*--- scan a string with quote char qu -------------------------------*/
scanString: procedure expose m.
parse arg m, qu
m.val = ''
if qu = '' then
qu = "'"
if substr(m.scan.m.src, m.scan.m.pos, 1) ^== qu then
return 0
bx = m.scan.m.pos
qx = m.scan.m.pos + 1
do forever
px = pos(qu, m.scan.m.src, qx)
if px < 1 then
call scanErr m, 'ending Apostroph('qu') missing'
m.val = m.val || substr(m.scan.m.src, qx, px-qx)
if px >= length(m.scan.m.src) then
leave
else if substr(m.scan.m.src, px+1, 1) <> qu then
leave
qx = px+2
m.val = m.val || qu
end
m.tok = substr(m.scan.m.src, bx, px+1-bx)
m.scan.m.pos = px+1
return 1
endProcedure scanString
/*--- scan a Name, first char in *.name1, rest in *.name -------------*/
scanName: procedure expose m.
parse arg m
if pos(substr(m.scan.m.src, m.scan.m.pos, 1),
, m.scan.m.Name1) <= 0 then
return 0
bx = m.scan.m.pos
m.scan.m.pos = bx + 1
call scanVerify m, m.scan.m.Name
m.tok = substr(m.scan.m.src, bx, m.scan.m.pos - bx)
return 1
endProcedure scanName
/*--- scan with verify, vOpt is passed to verify ---------------------*/
scanVerify: procedure expose m.
parse arg m, alpha, vOpt
if vOpt == '' then /* empty string does not take default| */
nx = verify(m.scan.m.src, alpha, , m.scan.m.pos)
else
nx = verify(m.scan.m.src, alpha, vOpt, m.scan.m.pos)
if nx = 0 then
nx = length(m.scan.m.src) + 1
m.tok = substr(m.scan.m.src, m.scan.m.Pos, nx - m.scan.m.Pos)
if nx <= m.scan.m.pos then
return 0
m.scan.m.pos = nx
return 1
endProcedure scanVerify
/*--- scan a number --------------------------------------------------*/
scanNum: procedure expose m.
parse arg m
if ^ scanVerify(m, '0123456789') then
return 0
else if pos(substr(m.scan.m.src, m.scan.m.pos, 1), m.scan.m.name1) ,
> 0 then
call scanErr m, 'illegal number end'
return 1
endProcedure scanNum
/*--- scan a word and put value into *.val
a word is either delimited by space or stopper
or a string (with single or double quotes -------*/
scanWord: procedure expose m.
parse arg m, stopper
if scanString(m, "'") then return 1
if scanString(m, """") then return 1
if ^scanVerify(m, ' 'stopper, 'm') then return 0
m.val = m.tok
return 1
endProcedure scanWord
scanBack: procedure expose m.
parse arg m, tok
if m.scan.m.pos <= length(tok) then
call scanErr sc, 'cannot back "'tok'" length'
cx = m.scan.m.pos - length(tok)
if substr(m.scan.m.src, cx, length(tok)) ^== tok then
call scanErr sc, 'cannot back "'tok'" value'
m.scan.m.pos = cx
return
endProcedure scanBack
/*--- scan a key = word phrase
put key into *.key and word into val -------*/
scanKeyValue: procedure expose m.
parse arg m, def
if ^ scanName(scanSkip(m)) then
return 0
m.key = m.tok
if ^ scanLit(scanSkip(m), '=') then do
m.val = def
m.tok = ' no='
end
else if ^scanWord(scanSkip(m)) then
call scanErr(m, 'word expected after' m.key '=')
return 1
endProcedure scanKeyValue
/*--- emit an error with current scan pos ----------------------------*/
scanErr: procedure expose m.
parse arg m, txt
say 'scanErr' txt
say ' last token' m.tok
say ' charPos' m.scan.m.Pos':',
strip(substr(m.scan.m.src, m.scan.m.Pos), 't')
say ' in line:' strip(m.scan.m.src, 't')
call err 'scanErr' txt
endProcedure scanErr
/*--- skip over spaces, nl and comments (if option set) --------------*/
scanSpaceNL: procedure expose m.
parse arg m
lastTok = m.tok
res = 0
cc = m.scan.m.comment
do forever
if scanVerify(m, ' ') then nop
else if scanNL(m) then nop
else if cc == '' then leave
else if ^ scanLit(m, cc) then leave
else if ^scanNL(m, 1) then leave
res = 1
end
m.tok = lastTok
return res
endProcedure scanSpaceNL
/*--- skip over space, nl and comments and return m -----------------*/
scanSkip: procedure expose m.
parse arg m
call scanSpaceNl m
return m
endProcedure scanSkip
/* copy scan end ****************************************************/
/* copy ooDiv begin ****************************************************
***********************************************************************/
readDsnOpen: procedure expose m.
parse arg oid, spec
x = dsnAlloc(spec, 'SHR', 'RE'oid)
dd = word(x, 1)
call readDDBegin dd
return ooDefReadStem(oid, 'res = readDD('dd', "M."stem".")',
, 'call readDDEnd' dd';' subword(x, 2))
endProcedure readDsnOpen
readCatOpen: procedure expose m.
parse arg oid, src
if symbol("m.oo.oid.readCatOid") ^= 'VAR' then
m.oo.oid.readCatOid = ooNew()
catOid = m.oo.oid.readCatOid
ox = 0
do ix=2 to arg()
s = arg(ix)
do while s <> ''
ex = pos('$', s)
if ex > 0 then do
w = strip(left(s, ex-1))
s = substr(s, ex+1)
end
else do
w = strip(s)
s = ''
end
if w ^= '' then do
ox = ox + 1
m.oo.oid.readCat.ox = w
end
end
end
m.oo.oid.readCat.0 = ox
m.oo.oid.readCatIx = 0
call ooDefRead catOid, 'res=0'
return ooDefRead(oid, 'res = readCat("'oid'", var);',
, 'call readCatClose "'oid'";')
endProcedure readCatOpen
readCat: procedure expose m.
parse arg oid, var
catOid = m.oo.oid.readCatOid
do forever
if ooRead(catOid, var) then
return 1
catIx = m.oo.oid.readCatIx + 1
if catIx > 1 then
call ooReadClose catOid
if catIx > m.oo.oid.readCat.0 then
return 0
m.oo.oid.readCatIx = catIx
src = m.oo.oid.readCat.catIx
if left(src, 1) = '&' then
call ooReadStemOpen catOid, strip(substr(src, 2))
else
call readDsnOpen catOid, src
end
endProcedure readCat
readCatClose: procedure expose m.
parse arg oid
if m.oo.oid.readCatIx > 0 then
call ooReadClose m.oo.oid.readCatOid
return
endProcedure readCatClose
/* copy ooDiv end ***************************************************/
/* copy oo begin ******************************************************/
call ooIni
/* ri = readDsnOpen(ooNew(), 'wk.text(testin)') */
call ooArgs2Stem aaa, 1, 'aaa.1 eins', 'aaa.2 zwei', 'aaa.3 drei'
ri = readCatOpen(ooNew(), "&AAA $ wk.text(testin) ",,'&' aaa,
, 'wk.text(msk1) $ &AAA')
do i=1 by 1 while ooRead(ri, line)
say 'line' i strip(m.line, 't')
end
call ooReadClose ri
exit
ooIni: procedure expose m.
m.oo.lastId = 1
return
endProcedure ooIni
ooNew: procedure expose m.
m.oo.lastId = m.oo.lastId + 1
return m.oo.lastId
endProcedure newoo
ooFree: procedure expose m.
parse arg id
return
endProcedure ooFree
ooRead: procedure expose m.
parse arg oid, var
res = '?'
interpret m.oo.oid.read
return res
endProcedure ooRead
ooReadClose: procedure expose m.
parse arg oid
stem = ''
interpret m.oo.oid.readClose
m.oo.oid.read = 'res=0'
m.oo.oid.readClose = ''
return
endProcedure ooReadClose
ooDefRead: procedure expose m.
parse arg oid, m.oo.oid.read, m.oo.oid.readClose
return oid
endProcedure ooDefRead
ooDefReadStem: procedure expose m.
parse arg oid, m.oo.oid.readStem, close
m.oo.oid.0 = 0
m.oo.oid.readStemCx = 0
return ooDefRead(oid, 'res = ooReadStem2Ln("'oid'", var);', close)
endProcedure ooDefReadStem
ooReadStem2Ln: procedure expose m.
parse arg oid, v
cx = m.oo.oid.readStemCx
if cx >= m.oo.oid.0 then do
res = '?'
stem = 'OO.'oid
m.stem.0 = 0
m.oo.oid.stCx = 0
interpret m.oo.oid.readStem
if ^ res then
return 0
else if m.stem.0 < 1 then
call err 'stem.0='m.stem.0 'after 1 from' m.oo.oid.readStem
cx = 0
end
cx = cx + 1
m.v = m.oo.oid.cx
m.oo.oid.readStemCx = cx
return 1
endProcedure ooReadStem2Ln
ooReadStemOpen: procedure expose m.
parse arg oid, stem
call ooDefReadStem oid, 'res = 0;'
do ix=0 by 1 to m.stem.0
m.oo.oid.ix = m.stem.ix
end
m.oo.oid.0 = m.stem.0
return oid
endProcedure ooReadStemOpen
ooReadArgsOpen: procedure expose m.
parse arg oid, ox
call ooDefReadStem oid, 'res = 0;'
if ox = '' then
ox = m.oo.oid.0
else
ox = ox - 1
do ax=3 by 1 to arg()
ox = ox + 1
m.oo.oud.ox = arg(ax)
end
m.oo.oid.0 = ox
return oid
endProcedure ooReadArgsOpen
ooArgs2Stem: procedure expose m.
parse arg stem, ox
if ox = '' then
ox = m.stem.0
else
ox = ox - 1
do ax=3 by 1 to arg()
ox = ox + 1
m.stem.ox = arg(ax)
end
m.stem.0 = ox
return stem
endProcedure ooArgs2Stem
/* copy oo 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 -------------------------------------------*/
dsnAlloc: procedure expose m.
parse upper arg spec, disp, dd
m.dsnAlloc.dsn = ''
if left(spec, 1) = '=' then
return strip(substr(spec, 1))
addPref = pos('~', spec) > 0
if addPref then
spec = strip(spec, 'b', '~')
do wx=1 to 3
w = word(spec, wx)
if w = '' then
leave
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 m.dsnAlloc.dsn = '' then
m.dsnAlloc.dsn = dsn2jcl(w, addPref)
else
leave
end
if dd = '' then
dd = 'DD' || ooNew()
if disp = '' | (disp = 'OLD' & pos('(', dsn) > 0) then
disp = 'SHR'
if m.dsnAlloc.dsn <> '' then
disp = disp "dsn('"m.dsnAlloc.dsn"')"
call adrTso 'alloc dd('dd')' disp subword(spec, wx)
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 m begin ********************************************************
stem and tree handling
***********************************************************************/
/*--- increase m.m and return it (fail if undefined) -----------------*/
mInc: procedure expose m.
parse arg m, delta
if delta = '' then
m.m = m.m + 1
else
m.m = m.m + delta
return m.m
endProcedure mInc
/*--- increase m.m and return it (also if undefined) -----------------*/
mIncD: procedure expose m.
parse arg m, delta
if symbol('m.m') <> 'VAR' then
m.m = 0
return mInc(m)
endProcedure mIncD
/*--- return Ky of m ------------------------------------------------*/
mKy: procedure expose m.
parse arg m
return m.mKey.m
endProcedure mKy
/*--- return number of children of node m or 0 -----------------------*/
mSize: procedure expose m.
parse arg m
if symbol('m.m.0') == 'VAR' then
return m.m.0
else
return 0
endProcedure mSize
/*--- return parent of node m or '' ----------------------------------*/
mPar: procedure expose m.
parse arg m
dx = lastPos('.', m)
if dx <= 1 then
return ''
else
return left(m, dx - 1)
endProcedure mPar
/*--- create a new tree root -----------------------------------------*/
mRoot: procedure expose m.
parse arg m, Ky, val
if m == '' then
m = 'mRoot.' || mIncD('mRoot.0')
m.m = val
m.mKey.m = Ky
m.m.0 = 0
return m
endProcedure mRoot
/*--- add one or several values to stem m.m --------------------------*/
mAdd: procedure expose m.
parse arg m
ix = mSize(m)
do ax = 2 to arg()
ix = ix + 1
m.m.ix = arg(ax)
end
m.m.0 = ix
return m'.'ix
endProcedure mAdd
/*--- add to m.dst.* a (sub)sequence of m.src.* ----------------------*/
mAddSeq: procedure expose m.
parse arg dst, src, begX, endX
if begX = '' then
begX = 1
if endX = '' then
endX = mSize(src)
dx = mSize(dst)
do sx = begX to endX
dx = dx + 1
m.dst.dx = m.src.sx
end
m.dst.0 = dx
return dst
endProcedure mAddSeq
/*--- add one value to the stem m.m ----------------------------------*/
mAddNd: procedure expose m.
parse arg m
ix = mSize(m)
do ax = 2 to arg()
ix = ix + 1
m.m.ix = arg(ax)
m.m.ix.0 = 0
end
m.m.0 = ix
return m'.'ix
endProcedure mAddNd
/*--- add one Ky value pair to stem m.m -----------------------------*/
mAddKy: procedure expose m.
parse arg m, Ky, val
nn = mAddNd(m, val)
m.mKey.nn = Ky
return nn
endProcedure mAddKy
/*--- add one indexable Ky value pair to stem m.m -------------------*/
mAddK1: procedure expose m.
parse arg m, ky, val
if symbol('m.mIndex.m.mKey.ky') == 'VAR' then
call err 'duplicate Ky' ky 'for node' m
nn = mAddNd(m, val)
m.mKey.nn = ky
m.mIndex.m.mKey.ky = nn
return nn
endProcedure mAddK1
/*--- put value at Ky if it exists otherwise add the node -----------*/
mPut: procedure expose m.
parse arg m, Ky, val
if symbol('m.mIndex.m.mKey.Ky') == 'VAR' then do
ch = m.mIndex.m.mKey.Ky
m.ch = val
return ch
end
else do
return mAddK1(m, Ky, val)
end
return
endProcedure mPut
/*--- return the child of m at the given Ky, '' if not exists -------*/
mAtK1: procedure expose m.
parse arg m, ky
if symbol('m.mIndex.m.mKey.ky') == 'VAR' then
return m.mIndex.m.mKey.ky
else
return ''
endProcedure mAtK1
/*--- return the value of the child at Ky, fail if not exists -------*/
mVaAtK1: procedure expose m.
parse arg m, Ky
if symbol('m.mIndex.m.mKey.Ky') ^== 'VAR' then
call err 'no Ky' Ky 'at node' m
ch = m.mIndex.m.mKey.Ky
return m.ch
endProcedure mVaAtK1
/*--- return the value of the first defined ky in the list of nodes
def if ky isn't defined ---------------------------------------*/
mFirst: procedure expose m.
parse arg Ky, def
do ax=3 to arg()
m = arg(ax)
if symbol('m.mIndex.m.mKey.Ky') == 'VAR' then do
ch = m.mIndex.m.mKey.Ky
return m.ch
end
end
return def
endProcedure mFirst
/*--- return the child at sequenceNo seq of node m -------------------*/
mAtSq: procedure expose m.
parse arg m, seq
if symbol('m.m.seq') ^== 'VAR' then
return ''
else
return m'.'seq
endProcedure mAtSq
/*--- remove all or all after nwSz children --------------------------*/
mRemCh: procedure expose m.
parse arg pa, nwSz
if nwSz = '' then
nwSz = 0
do cx=nwSz+1 to mSize(pa)
ch = pa'.'cx
call mRemCh ch
ky = m.mKey.ch
drop m.mIndex.pa.mKey.ky m.mKey.ch m.ch m.ch.0
end
m.pa.0 = nwSz
return pa
endProcedure mRemCh
/*--- add to m.dst a (sub)tree of m.src.* ----------------------------*/
mAddTree: procedure expose m.
parse arg dst, src, begX, endX
if begX = '' then
begX = 1
if endX = '' then
endX = mSize(src)
do sx=begX to endX
sCh = src'.'sx
if symbol('m.mKey.sCh') ^= 'VAR' then do
dCh = mAddNd(dst, m.sCh)
end
else do
ky = m.mKey.sCh
if symbol('m.mIndex.src.mKey.ky') ^= 'VAR' then
dCh = mAddKy(dst, ky, m.sCh)
else
dCh = mAddK1(dst, ky, m.sCh)
end
call mAddTree dCh, sCh
end
return dst
endProcedure mAddTree
/*--- show from one node everything that is defined ------------------*/
mShowNd: procedure expose m.
parse arg m
pa = mPar(m)
t = 'node' m 'pa='pa
if symbol('m.m') == 'VAR' then
t = t 'va='m.m
if symbol('m.m.0') == 'VAR' then
t = t 'size='m.m.0
if symbol('m.mKey.m') == 'VAR' then do
ky = m.mKey.m
t = t 'ky='ky
if symbol('m.mIndex.pa.mKey.ky') == 'VAR' then
t = t 'index='m.mIndex.pa.mKey.ky
end
say t
return
endProcedure mShowNd
/*--- show the tree at m recursively ---------------------------------*/
mShow: procedure expose m.
parse arg m, lv
if lv = '' then
lv = 0
t = left('', lv)m
if symbol('m.mKey.m') == 'VAR' then do
ky = m.mKey.m
pa = mPar(m)
if symbol('m.mIndex.pa.mKey.ky') == 'VAR' then
t= t ky '>'
else
t= t ky '='
end
say t strip(m.m, 't')
do cx=1 to mSize(m)
call mShow mAtSq(m, cx), lv+1
end
return
endProcedure treeShow
/* copy m 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 *****************************************************/
}¢--- A540769.WK.REXX(PLOAD0) cre=2009-12-01 mod=2009-12-01-14.52.58 A540769 ---
/* rexx ****************************************************************
synopsis: pLoad ¢d! ¢?! ¢idNr!
d: mit Debug output
?: diese Hilfe
id: numerischer Teil einer existierenden id
keine id: neue id erstellen
Funktion:
Defaults (global und user) laden
Optionen für id editieren
und dann Job für copy/unload/load erstellen und editieren
logfile schreiben in DSN.pLoad.INFO(LOG)
Konfiguration (global, user (DSN.pLoad.INFO(userId())) und id):
rexx code, der folgende Variabeln setzen soll
m.auftrag Auftraggeber etc
m.punchList = list of punchfiles to analyze (fully qualified)
m.volume = '' input punch and load are catalogued
else reside on this volume
m.resume = '' use resume clause from punch
= 'NO' use log no resume no replace
= 'YES' use log yes resume yes
m.owner = '' deduce owner from db2SubSys and catalog
else use the given owner
m.load = '' use load DSN from punch
else use the given DSN (fully qualified) as loadfile
(with variables &PA. &TS. &DB.)
m.db2SubSys db2 subsystem for load
m.mgmtClas sms class for generated datasets
m.jobcard.* stem for jobcards
m.orderTS = 0 first all copies unloads, afterwards all loads
(usefull with constraints, because of checkPen)
else utility task grouped together for each TS
************************************************************************
08.08.2008 W. Keller: orderTS Option eingefügt
************** end help ***********************************************/
/************* rest of history *****************************************
toDo: enforce no einfügen (und check anhängen?)
copy load stirbt mit b37 ==> manuell space Angaben einfügen
load überschreiben ohne inDDN erlauben|
copy nach load resume anfügen
2 Phasen trennen: datasets reinkopieren (kumulieren)
: copy/load durchführe (+restore, +log?|)
==> genpügt: noCopy und noUtil Options
(2. Phase ab 1. benutzen)
scan stirbt bei einer template mit space (..) cyl am schluss
Funktion für unloads im RZ1 bzw. RR2, auf entsprechende Shares
und Vorbereitung einer id
16.05.2008 W. Keller: Warnung bei TS mit mehreren Tables
12.01.2007 W. Keller: support partitions
01.12.2006 W. Keller: fix volume and m.load
22.11.2006 W. Keller: neu erstellt
***********************************************************************/
parse upper arg args
/* Info DSN spezifizieren - hier sind alle LOADS verzeichnet */
m.mainLib = 'DSN.pLoad.INFO' /* read configs from here| */
m.debug = 0 /* Debug Funktion ausschalten */
/* Programm Inputparameter (args) verarbeiten */
idN = '' /* idN = pload Nummer */
do wx = 1 to words(args) /* Anzahl Worte in args */
w = word(args, wx) /* w = Wort1,2 - wenn wx=1,2 */
if w = '?' then
call help
else if w = 'D' then /* Anschalten Debug Funktion */
m.debug = 1
else if verify(w, '0123456789') = 0 then
idN = w /* NOMATCH = Default
Check Wortn IN '0123456789'
????? */
else
call errHelp 'bad argument "'w'" in' args
end
/* interpret mainOpt/userOpt */
call interDsn m.mainLib'(mainOpt)' /* m.mainlib = DSN.PLOAD.INFO */
/* überprüfen ob userOpt member existiert */
/* Wenn ja, hat dieses Priorität 1 */
userOpt = m.mainLib"("userId()")"
if sysDsn("'"userOpt"'") = 'OK' then /* dsn,member vorhanden? */
call interDsn userOpt /* m.mainlib = DSN.PLOAD.INFO */
/* get next ploadid (idN) */
if idN = '' then
idN = log('nextId') /* get next ploadid from log */
call genId idN /* idN = ploadid ohne N */
/* edit the options dataset with the data to be loaded */
/* e.g. lib = DSN.PLOAD.N0187.SRC(OPTIONS) */
call adrIsp "edit dataset('"m.optDsn"')", 4
/* pssss..... warten.... */
/* pssss..... warten.... */
/* pssss..... warten.... */
/* User hat PF3 gedrückt, weiter gehts... */
/* interpret options dataset */
call interDsn m.optDsn /* m.optDsn = DSN.PLOAD.N0186.SRC(OPTIONS) */
/* überprüfen ob Punchfile im Options Member spezifiziert wurde */
if m.punchList = '' then /* m.punchlist aus MAINOPT Member */
call errHelp 'no punch files specified in m.punchList'
call init
m.volume = strip(m.volume) /* m.volume aus MAINOPT Member */
vol = ''
if m.volume <> '' then
vol = 'volume('m.volume')' /* default value aus mainopt */
/* member, anonsten BLANK */
/* Wenn orderts = 1, dann erst alles laden dann copy. */
/* Dies aufgrund der probleme mit refrential integrity */
if m.orderts <> 0 then
m.orderts = 1
do wx=1 to words(m.punchList) /* analyze all punchfiles */
/* 1.Punchfile, dann word = 1 */
/* 2.Punchfile, dann word = 2 */
w = word(m.punchList, wx) /* save current punshfile dsn in w */
call debug 'analyzing punchfile' w vol
/* if m.debug=1 - say xxxxx */
call analyzePunch w vol, m.treeLd, m.treePn
end
call checkOverride m.treeLd /* massage the analyzed input */
call createTables m.treeLd, m.treeTb
if m.debug then
call mShow m.treeRoot
/* generate jcl */
call jclGenStart m.treePn, m.treeTb
call jclGenCopyInput m.treePn, m.treeTb
punDsn = genSrcDsn('PUNCH')
call jclGenPunch m.treeTb, punDsn
call jclGenUtil punDsn, m.db2SubSys
jclDsn = genSrcDsn('JCL')
call writeJcl jclDsn
call log 'load' /* write the log */
call adrIsp "edit dataset('"jclDsn"')", 4
call finish
exit
/*---tree structure-----------------------------------------------------
tree
punch
punchfiles*
templates* template in this punchfile
load
load* each load statement in a punchfile
into* each into clause in the load
table
table* each db2 table
----------------------------------------------------------------------*/
/*--- initialisation -------------------------------------------------*/
init: procedure expose m.
call ooIni /* set m.oo.lastId= 1 */
m.treeRoot = mRoot("root", "root")
m.treePn = mAddK1(m.treeRoot, 'punch')
m.treeLd = mAddK1(m.treeRoot, 'load')
m.treeTb = mAddK1(m.treeRoot, 'table')
call adrSqlConnect m.db2SubSys
return
endProcedure init
/*--- Adress SQL -----------------------------------------------------*/
adrSql: /* no procedure, to keep variables sql... */
parse arg ggSqlStmt, ggRet, ggNo
if ggNo <> '1' then
ggSqlStmt = 'execSql' ggSqlStmt
address dsnRexx ggSqlStmt
/* say 'sqlCode' sqlCode 'rc' rc 'for' ggSqlStmt ggNo */
if rc = 0 then do
return 0
end
else if rc < 0 then do
if ggRet == '*' then nop
else if wordPos(sqlCode, ggRet) > 0 then nop
else
call err "sql rc" rc sqlmsg() ggNo
end
else if sqlWarn.0 ^== ' ' then do
say 'warning' sqlMsg() ggNo
end
return sqlCode
endSubroutine adrSql
/*--- SQL Connect ----------------------------------------------------*/
adrSqlConnect: procedure
parse arg ggSys, ggRetCon
if adrTSO("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" ggSys, ggRetCon ,1
return
endProcedure adrSqlConnect
/*--- SQL Disconnect -------------------------------------------------*/
adrSqlDisconnect: procedure
parse arg ggRet
call adrSql "disconnect ", ggRet, 1
return
endProcedure adrSqlDisconnect
/*--- Write SQLCA ----------------------------------------------------*/
sqlMsg: /* no procedure, to keep variables sql... */
ggW = ''
do ggX=0 to 10
if sqlWarn.ggx <> '' then
ggw = ggw ggx'='sqlWarn.ggx
end
ggXX = pos(':', ggSqlStmt)
ggVV = ''
if ggXX > 0 then do
ggVV = word(substr(ggSqlStmt, ggXX + 1), 1)
ggXX = verify(ggVV, ' ,:+-*/&%?|', 'm')
if ggXX > 0 then
ggVV = left(ggVV, ggXX-1)
ggVV = 'with' ggVV '=' value(ggVV)
end
return 'sqlCode' sqlCode 'state' sqlState 'warn' ggW ,
'errMc' strip(translate(sqlerrmc, ',', 'FF'x)) ,
'stmt = ' ggSqlStmt ggVV
endSubroutine sqlMsg
/*--- cleanup at end of program and disconnect from DB2 --------------*/
finish: procedure expose m.
call adrSqlDisconnect
return
endProcedure finish
/*--- debug output if m.debug is set -- m.debug = 1 ------------------*/
debug: procedure expose m.
if m.debug then
say 'debug' arg(1)
return
endProcedure debug
/*--- error message an suicide ---------------------------------------*/
err:
parse arg ggMsg
call errA ggMsg, 1
endSubroutine 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 ------------------------------------------------*/
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
/*--- generate a SRC datatset for the created ploadid ----------------*/
/*--- Members are PUNCH and OPTIONS ----------------*/
genId: procedure expose m.
parse arg iNum /* iNum = idN (ploadid ohne N) */
m.id = 'N'right(iNum, 4, 0) /* m.id = Nnnnn, e.g N0125 */
/* return punch dsn name but do not create it */
/* e.g. lib = DSN.PLOAD.N0187.SRC(PUNCH) */
puDsn = genSrcDsn("PUNCH")
/* format dsn from jcl format to tso format */
puSta = sysDsn(jcl2dsn(puDsn))
if puSta = 'OK' then do /* punch dataset existiert bereits */
say 'Job wurde bereits gestartet, und hat Daten erstellt'
say 'Weiterarbeit kann diese Daten überschreiben'
say 'enter WEITER, falls Sie das wollen'
parse upper pull ans
if ans ^== 'WEITER' then
call err 'Weiterarbeit abgebrochen'
end
else if puSta ^= 'DATASET NOT FOUND' & puSta ^= 'MEMBER NOT FOUND',
then do
call err 'bad sysDsn result' puSta 'for' puDsn
end
/* return options dsn name but do not create it */
/* e.g. lib = DSN.PLOAD.N0187.SRC */
lib = genSrcDsn()
/* e.g. lib = DSN.PLOAD.N0187.SRC(OPTIONS) */
m.optDsn = genSrcDsn('OPTIONS')
/* format dsn from jcl format to tso format */
libSta = sysdsn(jcl2dsn(m.optDsn))
if libSta = 'DATASET NOT FOUND' then do
if m.mgmtClas <> '' then /* m.mgmtClas aus MAINOPT Member */
mgCl = 'MGMTCLAS('m.mgmtClas')'
call adrTso 'alloc dd(ddCrea) new catalog dsn('jcl2Dsn(lib)')',
'dsntype(library) dsorg(po) recfm(f b) lrecl(80)' ,
'space(1, 10)' mgCl
call adrTso 'free dd(ddCrea)'
end
else if libSta ^= 'MEMBER NOT FOUND' & libSta ^= 'OK' then do
call err 'not supported sysdsn = ' libSta 'for scrLib' m.optDsn
end
/* create the options mbr for this id if it does not exist */
if libSta ^= 'OK' then
call writeOptions
return
endProcedure genId
/*--- write the options member: contains variables and help ----------*/
writeOptions: procedure expose m.
m.op.0 = 0
m.generated = date('s') time() 'by' userId()
vars = 'generated auftrag punchList volume' ,
'resume owner load db2SubSys orderTs'
wp = words(m.punchList)
do vx=1 to words(vars)
v = word(vars, vx)
if v <> 'punchList' | wp <= 1 then do
call mAdd op, left('m.'v, 14)'=' quote(value('m.'v), "'")
end
else do
li = left('m.punchList', 14)'='
do wx=1 to wp
call mAdd op, left(li, 15) ,
quote(word(m.punchList, wx),"'"), left(',', wx < wp)
li = ''
end
end
end
/* help is the leading commentblock */
call mAdd op
do lx=1 by 1
li = strip(sourceLine(lx), 't')
call mAdd op, li
if pos('*/', li) > 0 then
leave
end
/* write new OPTIONS member */
call writeDsn m.optDsn, m.op.
return
endProcedure writeOptions
/*--- interpret the given dsn ----------------------------------------*/
/* DSN.PLOAD.INFO(MAINOPT) */
/* DSN.PLOAD.INFO(userid()) */
/* DSN.PLOAD.INFO(OPTIONS) */
interDsn: procedure expose m.
parse arg dsn /* procedure input variable
in dsn ablegen */
call debug 'interpreting' dsn /* if m.debug=1 - say xxxxx */
call readDsn dsn, x. /* read dataset */
/* concat all the lines */
/* seperate them when a ; was found */
s = ''
do x=1 to x.0
l = strip(x.x)
if right(l, 1) == ',' then /* rexx continuation */
s = s left(l, length(l) - 1)
else
s = s l';' /* separate statements */
end
interpret s
call debug 'interpreted' dsn /* if m.debug=1 - say xxxxx */
return
endProcedure interDsn
/*--- get the next ploadid from DSN.PLOAD.INFO(LOG) -----------------*/
/*--write the next ploadid into DSN.PLOAD.INFO(LOG) -----------------*/
log: procedure expose m.
parse arg fun /* fun = 'nextId' or 'load' */
dsn = m.mainLib'(LOG)'
call readDsn dsn, l. /* read dataset */
zx = l.0 /* Anzahl lines in dsn */
cId = m.id /* next ploadid */
/* für fun = 'load' */
/* next ploadid reservieren */
if fun = 'nextId' then do
id = strip(left(l.zx, 8)) /* ploadid aus log member */
/* pos1-8, e.g. N0125 */
if left(id, 1) ^== 'N',
| verify(substr(id, 2), '0123456789') > 0 then
/* | = ODER Verknüpfung */
call err 'illegal id "'id'" in line' zx 'of' dsn
cId = 'N'right(1 + substr(id, 2), 4, '0')
/* max ploadid + 1 e.g. max=N0192, next=N0193 */
zx = zx + 1
/* max line dsn + 1 */
l.zx = left(cId, 8) date('s') left(time(), 5) 'newId'
/* l.zx = N0192 20081112 11:29 newId */
end
else if fun = 'load' then do /* log the current id */
/* find the current id in the log */
do ax = 1 by 1 to zx while strip(left(l.ax, 8)) < cId
end
do bx = ax by 1 to zx while strip(left(l.bx, 8)) = cId
end
le = left(cId, 8) date('s') left(time(), 5) left(m.auftrag, 20),
left(sysVar(sysNode) m.db2SubSys, 8)
/* shift the remaining entries */
tbRoot = m.treeTb
tSize = mSize(tbRoot)
sx = tSize-bx+ax
if sx > 0 then do
do qx=zx by -1 to bx /* shift right */
rx = qx+sx
l.rx = l.qx
end
end
else if sx < 0 then do /* shift left */
do qx=bx by 1 to zx
rx = qx+sx
l.rx = l.qx
end
end
zx = zx + sx
/* one log line for each table */
do tx=1 to tSize
tn = mAtSq(tbRoot, tx)
in = word(mVaAtK1(tn, 'intos'), 1)
owTb = mVaAtK1(tn, 'ow')'.'mVaAtK1(tn, 'tb')
if length(owTb) < 19 then
owTb = left(owTb, 19)
dbTs = mVaAtK1(tn, 'db')'.'mVaAtK1(tn, 'ts')
if length(dbTs) < 19 then
dbTS = left(dbTS, 19)
rx = ax + tx - 1
l.rx = le ,
left(mFirst('RESUME', '???', in, mPar(in)), 3) ,
owTb dbTs mVaAtK1(tn, 'parts')
end
end
else do /* fun <> 'nextId' or 'load' */
call err 'bad log fun' fun
end
/* write new ploadid in LOG member */
call writeDsn dsn, l., zx /* DSN.pLoad.INFO(LOG) L. 163 */
return substr(cId, 2) /* return next ploadid ohne N */
endProcedure log
/*--- analyze a punchfile ----------------------------------------------
puDsn: spec for input dsn to analyze
ldRoot: parentNode of node for each load
puRoot: parent node for each punchFile ---------------------*//
analyzePunch: procedure expose m.
parse arg puDsn, ldRoot, puRoot
/* w vol, m.treeLd, m.treePn */
pu = readDsnOpen(ooNew(), puDsn) /* open (alloc) punchfile */
/* ooNew() = increment m.oo.lastId (initialised by ooInit proc.) */
/* ooNew() = save punchfile in tree structure. */
co = treeCopyOpen(ooNew(), pu, '??', 0)
sc = scanUtilReader(ooNew(), co)
tmpl = mAddKy(puRoot, 'punch', puDsn)
do forever
if utilNext == 'TEMPLATE' then do
utilNext = analyzeTemplate(sc, tmpl)
end
else if utilNext == 'LOAD' then do
ch = mAddKy(ldRoot, 'load', tmpl)
utilNext = analyzeLoad(sc, co, ch, tmpl)
end
else do
u = scanUtil(sc)
if u == 'u' then
utilNext = m.val
else if u == '' then
leave
end
end
call ooReadClose pu
return
endProcedure analyzePunch
/*--- analyze template -----------------------------------------------*/
analyzeTemplate: procedure expose m.
parse arg sc, nd
if 'u' = scanUtil(sc) then
return m.val
else if m.utilType ^= 'n' then
call scanErr sc, 'template name expected'
na = m.tok
ch = mAddK1(nd, na, 'template')
do forever
if 'u' == scanUtil(sc) | m.utilType = '' then do
return m.val
end
else if m.utilType == 'n' & m.scan.sc.utilBrackets = 0 then do
parm = m.val
if wordPos(parm, 'DSN VOLUME') > 0 then
call mAddK1 ch, parm, scanUtilValue(sc)
else if parm = 'VOLUMES' then
call mAddK1 ch, 'VOLUME', scanUtilValue(sc)
else
call debug 'ignoring' parm scanUtilValue(sc)
/* if m.debug=1 - say xxxxx */
end
else do
call debug 'template chunck' m.utilType m.tok
/* if m.debug=1 - say xxxxx */
end
end
endProcedure analyzeTemplate
/*--- analyze load ---------------------------------------------------*/
analyzeLoad: procedure expose m.
parse arg sc, cc, ldNd, tmplNd
if scanUtil(sc) ^== 'n' & m.val ^== 'DATA' then
call scanErr sc, 'load data expected'
nd = ldNd
/* the load into syntax is too complex to analyze completly
instead, we use treeCopy to copy all unAnalyzed text */
call treeCopyDest cc, nd
call treeCopyOn cc, m.scan.sc.pos
do while 'u' ^== scanUtil(sc) & m.utilType ^== ''
if m.utilType ^= 'n' | m.scan.sc.utilBrackets ^= 0 then
iterate
opt = m.val
if wordPos(m.val, 'INDDN RESUME SHRLEVEL REPLACE COPYDDN' ,
'LOG INTO PART') < 1 then
iterate
call treeCopyOff cc, m.scan.sc.pos - length(m.tok)
if opt == 'INTO' then do
if scanUtil(sc) ^== 'n' | m.val ^== 'TABLE' then
call scanErr sc, 'into table expected'
if scanUtil(sc) ^== 'n' & m.utilType ^== '"' then
call scanErr sc, 'table name expected'
nd = mAddKy(ldNd, opt, '')
call mAddK1 nd, 'ow', strip(m.val)
if scanUtil(sc) ^== '.' then
call scanErr sc, '.table expected'
if scanUtil(sc)^=='n' & m.utilType^=='"' then
call scanErr sc, 'table name expected'
call mAddK1 nd, 'tb', strip(m.val)
call treeCopyDest cc, nd
end
else if opt == 'INDDN' then do
dd = scanUtilValue(sc)
ddNd = mAtK1(tmplNd, dd)
if ddNd = '' & m.load = '' then
call err 'template not found for inDDn' dd
call mAddK1 nd, 'INDDN', ddNd
end
else if opt == 'REPLACE' then do
call mAddK1 nd, opt, 1
end
else do
call mAddK1 nd, opt, scanUtilValue(sc)
end
call treeCopyOn cc, m.scan.sc.pos
end
call treeCopyOff cc, m.scan.sc.pos - length(m.tok)
return m.val
endProcedure analyzeLoad
/*--- check loads and override values --------------------------------*/
checkOverride: procedure expose m.
parse arg ldRoot
rs = translate(m.resume)
do lx=1 to mSize(ldRoot) /* for each load */
ld = mAtSq(ldRoot, lx)
loDdn = overrideLoad(mAtK1(ld, 'INDDN'))
if rs <> '' then
call mPut ld, 'RESUME', rs
do ix=1 to mSize(ld) /* for each into */
in = mAtSq(ld, ix)
if mKy(in) <> 'INTO' then
iterate
nd = mAtK1(in, 'PART')
if nd = '' then
nd = mAddK1(in, 'PART', '*')
part = m.nd
info = mVaAtK1(in, 'ow')'.'mVaAtK1(in, 'tb') 'part' part
if part == '*' then
nop
else if ^ datatype(part, 'n') | length(part) > 5 then
call scanErr sc, 'bad partition' part 'for' info
else
part = right(part, 5, 0)
m.nd = part
inDdn = overrideLoad(mAtK1(in, 'INDDN'))
if inDDn = '' then do
if loDDn = '' then
call err 'no inDDN for' info
DDn = loDDn
end
else do
if loDDn <> '' then
call err 'inDDn twice specified for' info
ddn = inDDn
end
if m.volume <> '' & mAtK1(ddn, 'VOLUME') = '' then
call mAddK1 in, 'VOLUME', m.volume
if rs <> '' then
call mPut in, 'RESUME', rs
end /* for each into */
end /* for each load */
return
endProcedure checkOverride
/*--- override or modify the load pointed to by nd -------------------*/
overrideLoad: procedure expose m.
parse arg nd
if nd == '' then
return nd
if m.load <> '' then do
if symbol('m.loadNd') <> 'VAR' then do
m.loadNd = mAddK1(m.treeRoot, 'overLoad')
call ds2Tree m.load, m.loadNd
end
m.nd = m.loadNd
end
if m.volume <> '' then
call mPut m.nd, 'VOLUME', m.volume
return nd
endProcedure overrideLoad
/*--- create tables: find destination creator and ts in catalogue
create tree for destination table and
link it to all into nodes -----------------------*/
createTables: procedure expose m.
parse arg ldRoot, tbRoot
do lx=1 to mSize(ldRoot)
ld = mAtSq(ldRoot, lx)
do ix=1 to mSize(ld)
in = mAtSq(ld, ix)
if mKy(in) <> 'INTO' then
iterate
oOw = mVaAtK1(in, 'ow')
oTb = mVaAtK1(in, 'tb')
if symbol('old.oOw.oTb') = 'VAR' then do
nd = old.oOw.oTb
call debug 'found' nd 'for old table' oOw'.'oTb
/* if m.debug=1 - say xxxxx */
end
else do /* search table in db2 catalog */
parse value queryTable(oOw, oTb) ,
with nOw'.'nTb':'db'.'ts
nd = mAtK1(tbRoot, nOw'.'nTb)
if nd <> '' then do
call debug 'found' nd 'for new table' nOw'.'nTb
/* if m.debug=1 - say xxxxx */
end
else do /* create node for table */
nd = mAddK1(tbRoot, nOw'.'nTb)
call mAddK1 nd, 'ow', nOw
call mAddK1 nd, 'tb', nTb
call mAddK1 nd, 'db', db
call mAddK1 nd, 'ts', ts
call mAddK1 nd, 'parts'
call debug 'created' nd 'for new table' nOw'.'nTb
/* if m.debug=1 - say xxxxx */
end
old.oOw.oTb = nd
call debug 'map old tb' oOw'.'oTb 'to' nOw'.'nTb 'nd' nd
/* if m.debug=1 - say xxxxx */
end
m.in = nd
pp = mVaAtK1(in, 'PART')
op = mVaAtK1(nd, 'parts')
if op = '' then do
np = pp
ni = in
if pp = '*' then
call mAddK1 nd, 'tsPa', 'TS'
else
call mAddK1 nd, 'tsPa', 'PA'
end
else if pp = '*' | op = '*' then
call err 'part * not alone in tb' nOw'.'nTb
else if wordPos(pp, op) > 0 then
call err 'part' pp 'duplicate n tb' nOw'.'nTb
else do /* add new partition into sorted list */
do wx=1 to words(op) while pp > word(op, wx)
end
np = subword(op, 1, wx-1) pp subword(op, wx)
oi = mVaAtK1(nd, 'intos')
ni = subword(oi, 1, wx-1) in subword(oi, wx)
end
call mPut nd, 'parts', np
call mPut nd, 'intos', ni
end
end
return
endProcedure createTables
/*--- query the db2 catalog for creator, db, ts etc.
of the tables to load --------------------------------------*/
queryTable: procedure expose m.
parse upper arg ow, tb
sql = "select t.name, t.creator, tsName, t.dbname, s.nTables" ,
"from sysibm.systables t, sysibm.systablespace s" ,
"where t.type = 'T'" ,
"and s.dbName = t.dbName and s.name = t.tsName" ,
"and t.name = '"strip(tb)"' and t.creator"
if m.owner <> '' then do /* override owner */
sql = sql "= '"strip(m.owner)"'"
end
else if left(ow, 3) == 'OA1' then do /* translate OA1* owners */
o = substr(strip(m.db2SubSys), 3, 1)
if o = 'O' | sysvar(sysnode) <> 'RZ1' then
o = 'P'
nn = overlay(o, ow, 4)
if nn = 'OA1P' then
sql = sql "in ('OA1P', 'ODV', 'IMF')"
else
sql = sql "= '"strip(nn)"'"
end
else do /* user owner as is */
sql = sql "= '"strip(ow)"'"
end
/* execute sql and fetch row */
call adrSql 'prepare s1 from :sql'
call adrSql "declare c1 cursor for s1"
call adrSql 'open c1'
cnt = 0
do forever
call adrSql 'fetch c1 into :tb, :cr, :ts, :db, :tbCnt'
if sqlCode = 100 then
leave
cnt = cnt + 1
if cnt > 1 then
call err 'fetched more than 1 row for table' ow'.'tb ':'sql
end
if cnt = 0 then
call err 'table' ow'.'tb 'not found in catalog:' sql
else if tbCnt <> 1 then do
say 'ts' db'.'ts 'hat' tbCnt 'Tabellen'
say 'pLoad kann mit RESUME=NO Daten ueberschreiben'
say 'trotzdem weitermache (w=weiter)?'
parse upper pull a
if ^ abbrev(a, 'W') then
call err 'nicht weiter'
end
call adrSql 'close c1'
return strip(cr)'.'strip(tb)':'strip(db)'.'strip(ts)
endProcedure queryTable
/*--- write the generated jcl ----------------------------------------*/
writeJcl: procedure expose m.
parse arg dsn
x = dsnAlloc(dsn, 'SHR', jclGen)
dd = word(x, 1)
call writeDDBegin dd
call writeDD dd, 'M.JOBCARD.'
do j = 1 to m.jclCard.0
call debug 'jclCard j' M.JCLCARD.j.0
/* if m.debug=1 - say xxxxx */
call writeDD dd, 'M.JCLCARD.'j'.'
end
call writeDDEnd dd
interpret subword(x, 2)
return
endProcedure writeJCL
/*--- generate the JCL -----------------------------------------------*/
jclGenStart: procedure expose m.
parse arg pnRoot, tbRoot
call jclIni
/* show our infos in comment */
call jcl '10'copies('*', 69)
parse source . . ggS3 .
call jcl '10* load job generated by' ggS3 ,
'in' sysvar(sysnode) 'for' m.db2SubSys 'by' userid()
call jcl '10* id' m.id 'at' date('s') time()
do px=1 to mSize(pnRoot) /* show input punch */
pn = mAtSq(pnRoot, px)
call jcl '1* punch ' m.pn
end
do tx=1 to mSize(tbRoot) /* show output tables */
tn = mAtSq(tbRoot, tx)
call jcl '1* load ' ,
mVaAtK1(tn, 'ow')'.'mVaAtK1(tn, 'tb') ,
'in' mVaAtK1(tn, 'db')'.'mVaAtK1(tn, 'ts')
p = mVaAtK1(tn, 'parts')
if p <> '*' then
call jcl '1* ' words(p) 'partitions between' word(p, 1),
'and' word(p, words(p))
intos = mVaAtK1(tn, 'intos')
do ix=1 to words(intos) /* show input tables and dsns */
in = word(intos, ix)
owTb = mVaAtK1(in, 'ow')'.'mVaAtK1(in, 'tb')
if i.owTb == 1 then
iterate
i.owTb = 1
if length(owTb) < 16 then
owTb = left(owTb, 16)
tmpl = mFirst('INDDN', , in, mPar(in))
call jcl '1* from' owTb mVaAtK1(tmpl, 'DSN')
end
drop i.
end
call jcl '10'copies('*', 69) /* end of info comment */
call jcl '1* alle Dataset löschen, die wir nachher neu erstellen'
call jcl '1'jclExec() 'PGM=IEFBR14'
return
endProcedure jclGenStart
/*--- copy all input dsns to our Prefix ------------------------------*/
jclGenCopyInput: procedure expose m.
parse arg puRoot, tbRoot
do px=1 to mSize(puRoot) /* punch files */
pn = mAtSq(puRoot, px)
call jcl '2* Originales Punchfile Kopieren'
call jclCopy ds2Tree(m.pn, m.jclNdFr) ,
, ds2Tree(genSrcDsn('OPUNCH', px), m.jclNdTo)
end
/* load input dsns */
m.dsnLoadTS = genDsn('&DB..&TS.', 'LOAD')
m.dsnLoadPA = genDsn('&DB..&TS..P&PA.', 'LOAD')
do tx=1 to mSize(tbRoot)
tn = mAtSq(tbRoot, tx)
intos = mVaAtK1(tn, 'intos')
do ix=1 to words(intos)
in = word(intos, ix)
ln = mPar(in)
if mAtK1(in, 'INDDN') <> '' then
dn = mVaAtK1(in, 'INDDN')
else
dn = mVaAtK1(ln, 'INDDN')
dnDsn = mVaAtK1(dn, 'DSN')
chDsn = expDsn(in, dnDsn)
if dnDsn <> chDsn then do
dn = mAddTree(mRemCh(m.jclNdFr), dn)
call mPut dn, 'DSN', chDsn
end
vv = 'DSNLOAD'mVaAtK1(tn, 'tsPa')
newLo = expDsn(in, m.vv)
call jcl '2* Originales Loadfile Kopieren'
call jclCopy dn, dsNew2Tree(newLo, m.jclNdTo)
end
end
return
endProcedure jclGenCopyInput
/*--- generate the db2 utility statements for copy & unload ----------*/
jclGenPunch: procedure expose m.
parse arg tbRoot, puDsn
if m.mgmtClas == '' then
m.mgmtClasCl = ''
else
m.mgmtClasCl = 'MGMTCLAS('m.mgmtClas')'
call jcl '2* Neues Punchfile Kopieren'
call jcl '2'jclExec() 'PGM=IEBGENER'
call jcl '20SYSPRINT DD SYSOUT=*'
call jcldd 2, 's', 'SYSUT2', ds2Tree(puDsn, m.jclNdTo)
call jcl '20SYSUT1 DD *'
/* add a second copy template,
to avoid duplicate on the copy before/after */
call jcl '2 TEMPLATE TCOPYQ'
call jcl '2 ' ,
"DSN('&SSID..&DB..&SN..Q&PART(2)..D&DATE(3)..T&TIME.')"
call jcl '2 DATACLAS (NULL12) MGMTCLAS(COM#A045)'
call jcl '2 SPACE (10,250) CYL'
call jcl '2 TEMPLATE TMLOADTS'
call jcl "2 DSN('"m.dsnLoadTS"')"
call jcl "2 DISP(SHR,KEEP,KEEP)"
call jcl '2 TEMPLATE TMLOADPA'
call jcl "2 DSN('"m.dsnLoadPA"')"
call jcl "2 DISP(SHR,KEEP,KEEP)"
xx = overlay(".UNLO", m.dsnLoadTS, lastPos(".", m.dsnLoadTS))
call jcl '2 TEMPLATE TMULTS'
call jcl "2 DSN('"xx"')"
call jcl '2 DATACLAS (NULL12) MGMTCLAS(COM#A045)'
call jcl '2 SPACE (10,250) CYL'
xx = overlay(".UNLO", m.dsnLoadPA, lastPos(".", m.dsnLoadPA))
call jcl '2 TEMPLATE TMULPA'
call jcl "2 DSN('"xx"')"
call jcl '2 DATACLAS (NULL12) MGMTCLAS(COM#A045)'
call jcl '2 SPACE (10,250) CYL'
xx = overlay(".UNPU", m.dsnLoadTS, lastPos(".", m.dsnLoadTS))
call jcl '2 TEMPLATE TMULPUN'
call jcl "2 DSN('"xx"')"
call jcl '2 DATACLAS (NULL12) MGMTCLAS(COM#A045)'
call jcl '2 SPACE (1,10) CYL'
do tx=1 to mSize(tbRoot)
tn = mAtSq(tbRoot, tx)
intos = mVaAtK1(tn, 'intos')
call jclGenPunchCopyUnload tn, tx
call jclGenPunchInto word(intos, 1), 0, tn
do ix=1 to words(intos)
in = word(intos, ix)
call jclGenPunchInto in, ix, tn
end
end
return
endProcedure jclGenPunch
/*--- generate utility copy and unload statement for table tn --------*/
jclGenPunchCopyUnload: procedure expose m.
parse arg tn, tx
parts = mVaAtK1(tn, 'parts')
paMin = word(parts, 1)
paMax = word(parts, words(parts))
dbTs = mVaAtK1(tn, 'db')'.'mVaAtK1(tn, 'ts')
if parts == '*' then do
call jcl '2 COPY TABLESPACE' dbTS 'FULL YES'
end
else do
call jcl '2 LISTDEF COLI'tx
call jcl '2 INCLUDE TABLESPACE' dbTs 'PARTLEVEL'
call jcl '2 COPY LIST COLI'tx 'FULL YES PARALLEL'
end
call jcl '2 COPYDDN (TCOPYQ) SHRLEVEL REFERENCE'
/* unload before */
call jcl '2 UNLOAD TABLESPACE' dbTS
if parts = '*' then
nop
else if paMin == paMax then
call jcl '2 PART' paMin
else
call jcl '2 PART' paMin ':' paMax
call jcl '2 FROM TABLE' mVaAtK1(tn, 'ow') ,
|| '.'mVaAtK1(tn, 'tb')
call jcl '2 PUNCHDDN TMULPUN UNLDDN TMUL'mVaAtK1(tn,'tsPa')
call jcl '2 SHRLEVEL REFERENCE'
return
endProcedure jclGenPunchCopyUnload
/*--- generate the db2 utility statements for 1 load or into ---------*/
jclGenPunchInto: procedure expose m.
parse arg in, ix, tn
pa = mVaAtK1(in, 'PART')
ln = mPar(in)
rs = mFirst('RESUME', 'NO', in, ln)
if rs = 'NO' then do
rsSp = 'RESUME NO REPLACE COPYDDN TCOPYD'
end
else do
rsSp = 'RESUME YES'
sh = mFirst('SHRLEVEL', '', in, ln)
if sh <> '' then
rsSp = rsSp 'SHRLEVEL' sh
end
if ix == 0 then do
if pa == '*' then do
call jcl '3 LOAD DATA INDDN TMLOADTS'
call jcl '3 ' rsSp 'LOG' rs
if rs == 'NO' then
call jcl '3 STATISTICS TABLE(ALL)' ,
'INDEX(ALL) UPDATE ALL'
end
else do
call jcl '3 LOAD DATA LOG' rs
end
jn = mPar(in)
end
else do
call jcl '3 INTO TABLE' mVaAtK1(tn,'ow')'.'mVaAtK1(tn,'tb')
if pa <> '*' then do
call jcl '3 PART' pa
call jcl '3 ' rsSp
call jcl '3 INDDN TMLOADPA'
end
jn = in
end
do cx=1 to mSize(jn)
cn = mAtSq(jn, cx)
key = mKy(cn)
if key = '' then
call jcl '3 'm.cn
end
return
endProcedure jclGenPunchInto
/*--- jcl to run the db2 utility -------------------------------------*/
jclGenUtil: procedure expose m.
parse arg pun, dbSys
call jcl '4* db2 utility macht die Arbeit'
call jcl '42IF RC=0 THEN'
call jcl '4'jclExec() "PGM=DSNUTILB,PARM='"dbSys","userid()".UN.LO'"
call jcl '40SYSMAP DD DISP=(,PASS),UNIT=SYSDA'
call jcl '40SYSUT1 DD DISP=(,PASS),UNIT=SYSDA'
call jcl '40SORTOUT DD DISP=(,PASS),UNIT=SYSDA'
call jcl '40SYSERR DD SYSOUT=*'
call jcl '40SYSPRINT DD SYSOUT=*'
call jcl '40UTPRINT DD SYSOUT=*'
call jcl '40SYSTEMPL DD DISP=SHR,DSN='dbSys'.DBAA.LISTDEF(TEMPL)'
call jcl '40SYSIN DD DISP=SHR,DSN='pun
call jcl '42ENDIF'
return
endProcedure jclGenUtil
/*--- generate DSN for this id, with the given llq and index ---------*/
genDSN: procedure expose m.
parse arg dbTs, leLlq, lx
llq = leLLq || lx
if length(llq) > 8 then
llq = left(leLlq, 8 - length(lx)) || lx
if dbTs = '' then
return m.dsnPref || '.'m.id'.'llq
else
return m.dsnPref || '.'m.id'.'dbTs'.'llq
endProcedure genDSN
/*--- generate DSN for the src DS of the id, with member and index ---*/
genSrcDsn: procedure expose m.
parse arg mbr, lx /* mbr = PUNCH oder OPTIONS */
dsn = m.dsnPref'.'m.id'.SRC' /* e.g.dsn = DSN.PLOAD.N0181.SRC */
/* m.dsnpref aus MAINOPT Member */
if mbr = '' then
return dsn /* e.g.dsn = DSN.PLOAD.N0181.SRC */
m = mbr || lx
if length(m) > 8 then
m = left(mbr, 8 - length(lx)) || lx
return dsn'('m')' /* DSN.PLOAD.N0185.SRC(PUNCH) */
/* DSN.PLOAD.N0185.SRC(OPTIONS) */
endProcedure genSrcDsn
/*--- expand variables in dsn from the into node in ------------------*/
expDsn: procedure expose m.
parse arg in, dsn
do forever
px = pos('&', dsn)
if px = 0 then
return dsn
dx = pos('.', dsn, px+1)
if dx <= px then
call err 'no . after & in' dsn
k = translate(substr(dsn, px+1, dx-px-1))
if k = 'DB' then
v = mVaAtK1(m.in, 'db')
else if k = 'PART' | k = 'PA' then
v = mVaAtK1(in, 'PART')
else if k = 'TS' | k = 'SN' then
v = mVaAtK1(m.in, 'ts')
else
call err 'bad variable' k 'in' dsn
dsn = left(dsn, px-1) || v || substr(dsn,dx+1)
end
endProcedure expDsn
/*--- transform the dataset spec into a tree at node nd --------------*/
ds2tree: procedure expose m.
parse arg spec, nd
call mRemCh nd
upper spec
dsn = ''
do ix=1 by 1
w = word(spec, ix)
if w = '' then
leave
if abbrev(w, 'DSN(') then
dsn = substr(w, 5, length(w) - 5)
else if abbrev(w, 'VOLUME(') then
call mAddK1 nd, 'VOLUME', substr(w, 8, length(w) - 8)
else if dsn == '' then
dsn = w
end
if dsn ^= '' then
call mAddK1 nd, 'DSN', dsn
return nd
endProcedure ds2Tree
/*--- transform the spec for a new DS into a tree at node nd ---------*/
dsNew2tree: procedure expose m.
parse arg spec, nd
x = ds2Tree(spec, nd)
if m.mgmtClas <> '' then
call mPut x, 'MGMTCLAS', m.mgmtClas
return x
endProcedure dsNew2tree
/*--- jcl to copy a sequential DS ------------------------------------*/
jclCopy: procedure expose m.
parse arg fr, to
call jcl '2'jclExec() 'PGM=IEBGENER'
call jcl '20SYSPRINT DD SYSOUT=*'
call jcldd 2, 'o', 'SYSUT1', fr
if pos('(', mVaAtK1(to, 'DSN')) > 0 then
call jcldd 2, 's', 'SYSUT2', to
else
call jcldd 2,'nr', 'SYSUT2', to, fr
return
endProcedure jclCopy
/*--- generate a jcl dd statement
opt: n=new, s=shr, r=remove in first step
dd: ddname
nd: tree representation dataset spec
like: tree representation of like dataset ----------------------*/
jclDD: procedure expose m.
parse arg j, opt, dd, nd, like
new = pos('n', opt) > 0
li=left('0'dd, 12)'DD'
if new then
li = li 'DISP=(NEW,CATLG,DELETE)'
else if pos('s', opt) > 0 then
li = li 'DISP=SHR'
else
li = li 'DISP=OLD'
do cx=1 by 1 to m.nd.0
ch = nd'.'cx
va = m.ch
ky = mKy(ch)
if wordPos(ky, 'DSN MGMTCLAS') > 0 then
li = jclDDClause(j, li, ky'='va)
else if ky == 'VOLUME' then
li = jclDDClause(j, li, 'VOL=SER=('va'),UNIT=DISK')
else
call err 'bad dd attribute' ky'='va
end
if like == '' then do
end
else if like == 'fb80' then do
li = jclDDClause(j, li, 'RECFM=FB,LRECL=80')
end
else do
if '' == mAtK1(like, 'VOLUME') then do
li = jclDDClause(j, li, 'LIKE='mVaAtK1(like, 'DSN'))
end
else do
aa = jcl2dsn(mVaAtK1(like, 'DSN')) ,
'VOLUME('mVaAtK1(like, 'VOLUME')')'
lRc = listDsi(aa)
if lRc <> 0 then
call err 'rc' lRc from 'listDsi' aa
if sysUnits = 'CYLINDER' then
u = 'CYL'
else if sysUnits = 'TRACK' | sysUnits = 'BLOCK' then
u = left(sysUnits, 2) || 'K'
else
call err 'bad sysunits from listDsi:' sysUnits
li = jclDDClause(j, li, 'SPACE=('u',('sysPrimary',' ,
|| sysSeconds'))')
li = jclDDClause(j, li, 'RECFM='sysRecFm)
end
end
call jcl j || li
if new & pos('r', opt) > 0 then
call jclRemove nd
return
endProcedure jclDD
/*--- add a DS to the remove step ------------------------------------*/
jclRemove: procedure expose m.
parse arg nd
m.jclRemove = m.jclRemove + 1
li = left('0RM'm.jclRemove, 12)'DD DISP=(MOD,DELETE,DELETE)'
li = jclDDClause(1, li, 'DSN='mVaAtK1(nd, 'DSN'))
call jcl '1'li
return
endProcedure jclRemove
/*--- add one clause to a jcl dd statement
if the line overflows write it out
return rest of line ---------------------------------------*/
jclDDClause: procedure expose m.
parse arg j, li, cl
if left(li, 1) = '6' then
a = 15
else
a = 1
if a + length(li) + length(cl) < 70 then
return li','cl
call jcl j || li','
return '6'cl
endProcedure jclDDClause
/*--- generate an exec statement -------------------------------------*/
jclExec: procedure expose m.
m.jclStep = m.jclStep + 1
return left('0S'm.jclStep, 10)'EXEC'
endProcedure jclExec
/*--- initialize jcl generator ---------------------------------------*/
jclIni: procedure expose m.
m.jclCard.0 = 9
do x=1 to m.jclCard.0
m.jclCard.x.0 = 0
end
m.jclRemove=0
m.jclStep = 0
m.jclPref.0 = '//'
m.jclPref.2 = left('//', 11)
m.jclPref.4 = left('//', 13)
m.jclPref.6 = left('//', 15)
xx = ' '
m.jclPref.xx = ''
xx = '*'
m.jclPref.xx = '//*'
m.jclNdFr = mRoot()
m.jclNdTo = mRoot()
return
endProcedure jclIni
/*--- output one jcl line:
j (char 1): which stem
t (char 2): prefix
m (char 3 to end): message ----------------------------------*/
jcl: procedure expose m.
parse arg j 2 t 3 m
if m.orderTS & j > 2 then
j = 2
x = m.jclCard.j.0 + 1
m.jclCard.j.0 = x
if m.debug then
if symbol('m.jclPref.t') <> 'VAR' then
call err undefined jclPref for t 'in' j || t || m
m.jclCard.j.x = m.jclPref.t || strip(m, 't')
if m.debug then
say 'jcl'j m.jclCard.j.x
return
endProcedure jcl
/*--- add one line text to the stem m.st -----------------------------*/
/*--- copy a DS in tso -----------------------------------------------*/
copyDS: procedure
parse arg fj fa, tj ta
say 'copyDs from' fj fa 'to' tj ta
call adrTso 'free dd(sysut1)', '*'
call adrTso 'alloc dd(sysut1) shr dsn('jcl2dsn(fj)')' fa
call adrTso 'free dd(sysut2)', '*'
call adrTso 'delete' jcl2dsn(tj), '*'
call adrTso 'alloc dd(sysut2) new catalog refdd(sysut1)' ,
'dsn('jcl2dsn(tj)')' ta
call adrTso 'alloc dd(sysin) dummy reuse'
call adrTso 'alloc dd(sysprint) sysout(T) reuse'
/* call iebGener */
CALL ADRTSO 'CALL *(IEBGENER)', '*'
say 'iebGener rc' rc 'result' result
call adrTso 'free dd(sysin sysprint sysut1 sysut2)'
return
endProcedure copyDS
/* treeCopy : make a copy of a reader to a tree ***********************/
treeCopyLine: procedure expose m.
parse arg m, nx
if ^m.treeCopy.m.read then
return
if nx > length(m.treeCopy.m.line) then
qx = length(m.treeCopy.m.line)
else
qx = nx - 1
if m.treeCopy.m.on then do
le = left(m.treeCopy.m.line, qx)
if le <> '' then
call mAddKy m.treeCopy.m.dest, , le
end
m.treeCopy.m.line = overlay('', m.treeCopy.m.line, 1, qx)
return
endProcedure treeCopyLine
treeCopyDest: procedure expose m.
parse arg m, m.treeCopy.m.dest
return
endProcedure treeCopyDest
/*--- start copying at character nx of current line ------------------*/
treeCopyOn: procedure expose m.
parse arg m, nx
if m.treeCopy.m.on then
return
call treeCopyLine m, nx
m.treeCopy.m.on = 1
return
endProcedure treeCopyOn
/*--- stop copying at character nx of current line -------------------*/
treeCopyOff: procedure expose m.
parse arg m, nx
if ^ m.treeCopy.m.on then
return
call treeCopyLine m, nx
m.treeCopy.m.on = 0
return
endProcedure treeCopyOff
treeCopyRead: procedure expose m.
parse arg m, rdr, var
call treeCopyLine m, 1 + length(m.treeCopy.m.line)
m.treeCopy.m.read = ooRead(rdr, var)
m.treeCopy.m.line = m.var
return m.treeCopy.m.read
endProcedure treeCopyRead
treeCopyOpen: procedure expose m.
parse arg m, rdr, m.treeCopy.m.dest, isOn
call ooDefRead m, 'res = treeCopyRead("'m'", "'rdr'", var);'
m.treeCopy.m.read = 0
m.treeCopy.m.on = isOn = 1
return m
endProcedure treeCopyOpen
/* copy scanUtil begin *************************************************
scan db2 utility input statements using scan and a reader
**********************************************************************/
/*--- initialize with reader inRdr ----------------------------------*/
scanUtilReader: procedure expose m.
parse arg m, inRdr
call scanReader m, inRdr
call scanOptions sc, , , '--'
m.scan.m.utilBrackets = 0
return m
endProcedure scanUtilReader
/*--- scan next token and put its type in m.utilType:
'u' a utility name
'n' a name
'"' a quoted name
"'" an apostroph'd string
'.' a .
',' a ,
'v' a value
'' at end
---------------------------------------------------------------*/
scanUtil: procedure expose m.
parse arg sc
call scanSpaceNl sc
ty = '?'
if scanLit(sc, '(') then do
m.scan.sc.utilBrackets = m.scan.sc.utilBrackets + 1
end
else if scanLIT(sc, ')') then do
m.scan.sc.utilBrackets = m.scan.sc.utilBrackets - 1
if m.scan.sc.utilBrackets < 0 then
call scanErr sc, 'unmatched closing bracket )'
end
else if scanLit(sc, ',') then do
end
else if scanLit(sc, '.') then do
end
else if scanString(sc, "'") then do
end
else if scanString(sc, '"') then do
end
else if scanName(sc) then do
m.val = translate(m.tok)
if m.scan.sc.utilBrackets > 0 then
ty = 'n'
else if 0 < wordPos(m.val, 'BACKUP CATENFM CATMAINT CHECK' ,
'COPY COPYTOCOPY DIAGNOSE EXEC LISTDEF LOAD' ,
'MERGECOPY MODIFY OPTIONS QUIESCE REBUILD' ,
'RECOVER REORG REPAIR REPORT RESTORE' ,
'RUNSTATS STOSPACE TEMPLATE UNLOAD') then
ty = 'u'
else
ty = 'n'
end
else if scanVerify(sc, ' (),''"', 'm') then do
ty = 'v'
m.val = translate(m.tok)
end
else if ^scanAtEnd(sc) then do
call scanErr sc, 'scanUtil stopped before end'
end
else do
/* say 'scanUtil return atEnd' */
ty = ''
m.val = ''
end
if ty == '?' then
m.utilType = left(m.tok, 1)
else
m.utilType = ty
return m.utilType
endProcedure scanUtil
/*--- scan a value or a bracketed list of values ---------------------*/
scanUtilValue: procedure expose m.
parse arg sc
if '(' ^== scanUtil(sc) then
return scanUtilValueOne(sc)
v = ''
brx = m.scan.sc.utilBrackets
do forever
call scanUtil sc
one = scanUtilValueOne(sc)
if one == '' then
call scanErr sc, 'eof in brackets'
else if brx > m.scan.sc.utilBrackets then
return v
v = v || one
end
endProcedure scanUtilValue
scanUtilValueOne: procedure expose m.
parse arg sc
if utilType == '' then
return ''
else if m.utilType == 'u' then
call scanErr sc, 'util in scanUtilValueOne'
else if pos(m.utilType, 'nv''"') > 0 then
return m.val
else
return m.tok
endProcedure scanUtilValueOne
/* copy scanUtil end **************************************************/
/* 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
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(*)'
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')'
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 *************************************************/
/**********************************************************************
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 = adrTso('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
/* copy adrSql end *************************************************/
/* copy scan begin ****************************************************
Scan: scan an input:
scanLine(m,ln) : begin scanning a single line
scanStem(m,ln) : begin scanning all lines in a stem
scanAtEOL(m) : returns whether we reached end of line
scanAtEnd(m) : returns whether we reached end of input
scanLit(m,lit) : scan Literal lit if present or return 0
scanChar(m,n) : scan next n characters
scanName(m) : scan a name
scanNum(m) : scan integer (without sign)
scanString(m,q): scan a String with quote q. (with doubble = 1)
scanVerify(m,c,o): verify(...,c,o,...)
scanKeyValue(m): scan a key = value clause (with spaces)
scanWord(m,u) : scan a space delimited word or a string,
if u=1 then uppercase non-strings
scanErr(m, txt): error with current scan location
m is an adress, to store our state
if a scan function succeeds, the scan posititon is moved
returns: true if scanned, false otherwise
m.tok ==> last token
m.val ==> last value for scanString/Word/KeyValue
m.key ==> key for scanKeyValue
m.scan.m.pos ==> scan position
m.scan.m.src ==> scan source
***********************************************************************/
/*--- begin scanning a single line -----------------------------------*/
scanLine: procedure expose m.
parse arg m, m.scan.m.src
call scanStart m
return
endProcedure scanLine
/*--- begin scanning the lines of a stem -----------------------------*/
scanReader: procedure expose m.
parse arg m, inRdr
call scanStart m, inRdr
m.scan.m.src = ''
m.scan.m.atEnd = ^ scanNL(m, 1)
return m
endProcedure scanReader
/*--- switch to next line if atEOF or argument unCond=1 --------------*/
scanNL: procedure expose m.
parse arg m, unCond
if unCond == 1 then
m.scan.m.pos = 1 + length(m.scan.m.src)
else if m.scan.m.pos <= length(m.scan.m.src) then
return 0
if m.scan.m.reader = '' then
return 0
else if ^ ooRead(m.scan.m.reader, 'SCAN.'m'.SRC') then do
m.scan.m.atEnd = 1
return 0
end
m.scan.m.pos = 1
m.scan.m.tok = ''
return 1
endProcedure scanNL
/*--- initialize scanner for m --------------------------------------*/
scanStart: procedure expose m.
parse arg m, m.scan.m.reader
m.scan.m.pos = 1
m.tok = ''
m.val = ''
m.key = ''
if symbol('m.scan.m.Name') ^== 'VAR' then do
m.scan.LC = 'abcdefghijklmnopqurstuvwxyz'
m.scan.UC = 'ABCDEFGHIJKLMNOPQURSTUVWXYZ'
m.scan.Alpha = m.scan.LC || m.scan.UC
m.scan.AlNum = '0123456789' || m.scan.ALPHA
m.scan.m.Name1 = m.scan.ALPHA
m.scan.m.Name = m.scan.ALNUM
m.scan.m.comment = ''
end
return
endProcedure scanStart
/*--- set options name characters, comment characters ----------------*/
scanOptions: procedure expose m.
parse arg m, nameOne, namePlus, comm
if symbol('m.scan.m.Name') ^== 'VAR' then
call scanStart
if nameOne ^== '' then
m.scan.m.Name1 = nameOne
if nameOne ^= '' | namePlus ^== '' then
m.scan.m.name = m.scan.m.name1 || namePlus
m.scan.m.comment = comm
return
endProcedure scanBegin
/*--- return true/false whether we are at the end of the line --------*/
scanAtEOL: procedure expose m.
parse arg m
return m.scan.m.pos > length(m.scan.m.src)
endProcedure scanAtEOL
/*--- return true/false whether we are at the end of the input -------*/
scanAtEnd: procedure expose m.
parse arg m
if m.scan.m.pos <= length(m.scan.m.src) then
return 0
if m.scan.m.reader = '' then
return 1
else
return m.scan.m.atEnd
endProcedure scanAtEnd
/*--- scan len characters --------------------------------------------*/
scanChar: procedure expose m.
parse arg m, len
nx = 1 + length(m.scan.m.src)
if len ^== '' then
if nx > m.scan.m.pos + len then
nx = m.scan.m.pos + len
m.tok = substr(m.scan.m.src, m.scan.m.pos, nx - m.scan.m.pos)
if nx = m.scan.m.pos then
return 0
m.scan.m.pos = nx
return 1
endProcedure scanChar
/*--- scan the literal lit ------------------------------------------*/
scanLit: procedure expose m.
parse arg m, lit
if ^ abbrev(substr(m.scan.m.src, m.scan.m.pos), lit) then
return 0
m.scan.m.pos = m.scan.m.pos + length(lit)
m.tok = lit
return 1
endProcedure scanLit
/*--- scan a string with quote char qu -------------------------------*/
scanString: procedure expose m.
parse arg m, qu
m.val = ''
if qu = '' then
qu = "'"
if substr(m.scan.m.src, m.scan.m.pos, 1) ^== qu then
return 0
bx = m.scan.m.pos
qx = m.scan.m.pos + 1
do forever
px = pos(qu, m.scan.m.src, qx)
if px < 1 then
call scanErr m, 'ending Apostroph('qu') missing'
m.val = m.val || substr(m.scan.m.src, qx, px-qx)
if px >= length(m.scan.m.src) then
leave
else if substr(m.scan.m.src, px+1, 1) <> qu then
leave
qx = px+2
m.val = m.val || qu
end
m.tok = substr(m.scan.m.src, bx, px+1-bx)
m.scan.m.pos = px+1
return 1
endProcedure scanString
/*--- scan a Name, first char in *.name1, rest in *.name -------------*/
scanName: procedure expose m.
parse arg m
if pos(substr(m.scan.m.src, m.scan.m.pos, 1),
, m.scan.m.Name1) <= 0 then
return 0
bx = m.scan.m.pos
m.scan.m.pos = bx + 1
call scanVerify m, m.scan.m.Name
m.tok = substr(m.scan.m.src, bx, m.scan.m.pos - bx)
return 1
endProcedure scanName
/*--- scan with verify, vOpt is passed to verify ---------------------*/
scanVerify: procedure expose m.
parse arg m, alpha, vOpt
if vOpt == '' then /* empty string does not take default| */
nx = verify(m.scan.m.src, alpha, , m.scan.m.pos)
else
nx = verify(m.scan.m.src, alpha, vOpt, m.scan.m.pos)
if nx = 0 then
nx = length(m.scan.m.src) + 1
m.tok = substr(m.scan.m.src, m.scan.m.Pos, nx - m.scan.m.Pos)
if nx <= m.scan.m.pos then
return 0
m.scan.m.pos = nx
return 1
endProcedure scanVerify
/*--- scan a number --------------------------------------------------*/
scanNum: procedure expose m.
parse arg m
if ^ scanVerify(m, '0123456789') then
return 0
else if pos(substr(m.scan.m.src, m.scan.m.pos, 1), m.scan.m.name1) ,
> 0 then
call scanErr m, 'illegal number end'
return 1
endProcedure scanNum
/*--- scan a word and put value into *.val
a word is either delimited by space or stopper
or a string (with single or double quotes -------*/
scanWord: procedure expose m.
parse arg m, stopper
if scanString(m, "'") then return 1
if scanString(m, """") then return 1
if ^scanVerify(m, ' 'stopper, 'm') then return 0
m.val = m.tok
return 1
endProcedure scanWord
scanBack: procedure expose m.
parse arg m, tok
if m.scan.m.pos <= length(tok) then
call scanErr sc, 'cannot back "'tok'" length'
cx = m.scan.m.pos - length(tok)
if substr(m.scan.m.src, cx, length(tok)) ^== tok then
call scanErr sc, 'cannot back "'tok'" value'
m.scan.m.pos = cx
return
endProcedure scanBack
/*--- scan a key = word phrase
put key into *.key and word into val -------*/
scanKeyValue: procedure expose m.
parse arg m, def
if ^ scanName(scanSkip(m)) then
return 0
m.key = m.tok
if ^ scanLit(scanSkip(m), '=') then do
m.val = def
m.tok = ' no='
end
else if ^scanWord(scanSkip(m)) then
call scanErr(m, 'word expected after' m.key '=')
return 1
endProcedure scanKeyValue
/*--- emit an error with current scan pos ----------------------------*/
scanErr: procedure expose m.
parse arg m, txt
say 'scanErr' txt
say ' last token' m.tok
say ' charPos' m.scan.m.Pos':',
strip(substr(m.scan.m.src, m.scan.m.Pos), 't')
say ' in line:' strip(m.scan.m.src, 't')
call err 'scanErr' txt
endProcedure scanErr
/*--- skip over spaces, nl and comments (if option set) --------------*/
scanSpaceNL: procedure expose m.
parse arg m
lastTok = m.tok
res = 0
cc = m.scan.m.comment
do forever
if scanVerify(m, ' ') then nop
else if scanNL(m) then nop
else if cc == '' then leave
else if ^ scanLit(m, cc) then leave
else if ^scanNL(m, 1) then leave
res = 1
end
m.tok = lastTok
return res
endProcedure scanSpaceNL
/*--- skip over space, nl and comments and return m -----------------*/
scanSkip: procedure expose m.
parse arg m
call scanSpaceNl m
return m
endProcedure scanSkip
/* copy scan end ****************************************************/
/* copy ooDiv begin ****************************************************
***********************************************************************/
/* File einlesen, z.B. PUNCHFILE */
readDsnOpen: procedure expose m.
parse arg oid, spec
/* oid = ooNew(), spec = punchfile(volume) */
x = dsnAlloc(spec, 'SHR', 'RE'oid)
/* dsnAlloc = Procedure zum anlegen/öffnen von datasets */
/* x = RE2 call adrTso "free dd(RE2)"; */
dd = word(x, 1)
/* dd = RE2 */
return ooDefReadStem(oid, 'res = readDD('dd', "M."stem".")',
, 'call readDDEnd' dd';' subword(x, 2))
endProcedure readDsnOpen
/* copy ooDiv end ***************************************************/
/* copy oo begin ******************************************************/
/* m.oo.lastid = 1 */
ooIni: procedure expose m.
m.oo.lastId = 1
return
endProcedure ooIni
/* m.oo.lastid inkrementieren */
/* m.oo.lastid = neue adresse (objekt) erstellen */
ooNew: procedure expose m.
m.oo.lastId = m.oo.lastId + 1
return m.oo.lastId
endProcedure newoo
ooFree: procedure expose m.
parse arg id
return
endProcedure ooFree
/* nächste Zeile einlesen */
ooRead: procedure expose m.
parse arg oid, var
res = '?'
interpret m.oo.oid.read
return res
endProcedure ooRead
ooReadClose: procedure expose m.
parse arg oid
stem = ''
interpret m.oo.oid.readClose
m.oo.oid.read = 'res=0'
m.oo.oid.readClose = ''
return
endProcedure ooReadClose
ooDefRead: procedure expose m.
parse arg oid, m.oo.oid.read, m.oo.oid.readClose
return oid
endProcedure ooDefRead
ooDefReadStem: procedure expose m.
parse arg oid, m.oo.oid.readStem, close
m.oo.oid.0 = 0
m.oo.oid.readStemCx = 0
return ooDefRead(oid, 'res = ooReadStem2Ln("'oid'", var);', close)
endProcedure ooDefReadStem
ooReadStem2Ln: procedure expose m.
parse arg oid, v
cx = m.oo.oid.readStemCx
if cx >= m.oo.oid.0 then do
res = '?'
stem = 'OO.'oid
m.stem.0 = 0
m.oo.oid.stCx = 0
interpret m.oo.oid.readStem
if ^ res then
return 0
else if m.stem.0 < 1 then
call err 'stem.0='m.stem.0 'after 1 from' m.oo.oid.readStem
cx = 0
end
cx = cx + 1
m.v = m.oo.oid.cx
m.oo.oid.readStemCx = cx
return 1
endProcedure ooReadStem2Ln
ooReadStemOpen: procedure expose m.
parse arg oid, stem
call ooDefReadStem oid, 'res = 0;'
do ix=0 by 1 to m.stem.0
m.oo.oid.ix = m.stem.ix
end
m.oo.oid.0 = m.stem.0
return oid
endProcedure ooReadStemOpen
ooReadArgsOpen: procedure expose m.
parse arg oid, ox
call ooDefReadStem oid, 'res = 0;'
if ox = '' then
ox = m.oo.oid.0
else
ox = ox - 1
do ax=3 by 1 to arg()
ox = ox + 1
m.oo.oud.ox = arg(ax)
end
m.oo.oid.0 = ox
return oid
endProcedure ooReadArgsOpen
ooArgs2Stem: procedure expose m.
parse arg stem, ox
if ox = '' then
ox = m.stem.0
else
ox = ox - 1
do ax=3 by 1 to arg()
ox = ox + 1
m.stem.ox = arg(ax)
end
m.stem.0 = ox
return stem
endProcedure ooArgs2Stem
/* copy oo 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
/*--- 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: readDD*, readDDEnd
write: writeBegin, writeDD*, writeEnd
readDD returns true if data read, false at eof
***********************************************************************/
/*--- 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 (member) ----------------------------------*/
dsnAlloc: procedure expose m.
parse upper arg spec, disp, dd
m.dsnAlloc.dsn = ''
if left(spec, 1) = '=' then
return strip(substr(spec, 1))
addPref = pos('~', spec) > 0
if addPref then
spec = strip(spec, 'b', '~')
do wx=1 to 3
w = word(spec, wx)
if w = '' then
leave
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 m.dsnAlloc.dsn = '' then
m.dsnAlloc.dsn = dsn2jcl(w, addPref)
else
leave
end
if dd = '' then
dd = 'DD' || ooNew()
if disp = '' | (disp = 'OLD' & pos('(', dsn) > 0) then
disp = 'SHR'
if m.dsnAlloc.dsn <> '' then
disp = disp "dsn('"m.dsnAlloc.dsn"')"
call adrTso 'alloc dd('dd')' disp subword(spec, wx)
return dd 'call adrTso "free dd('dd')";'
endProcedure dsnAlloc
/*--- read dsn, e.g. DSN.PLOAD.INFO(MAINOPT) -------------------------*/
readDSN:
parse arg ggDsnSpec, ggSt
/* DSN.PLOAD.INFO(MAINOPT), ggSt = X.
DSN.PLOAD.INFO(LOG) , ggSt = L. */
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
/* dsnAlloc = Procedure zum anlegen/öffnen von datasets */
/* ggAlloc = READDSN call adrTso "free dd(READDSN)"; */
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
/* READDSN */ /* X. or L. */
interpret subword(ggAlloc, 2) /* interpret = Befehl ausführen
subword = Wörter ab Pos2
von ggAlloc */
/* ggAlloc,2 = call adrTso "free dd(READDSN)"; */
return
endSubroutine readDsn
/*--- write dsn, e.g. DSN.PLOAD.INFO(LOG) ----------------------------*/
/*--- write dsn, e.g. DSN.PLOAD.INFO(OPTIONS) ------------------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
/* DSN.PLOAD.INFO(LOG) , ggSt = L., ggCnt = maxline + 1
DSN.PLOAD.INFO(OPTIONS), ggSt = m.op, ggCnt = ''
ggsay = wie m.debug = 1 */
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
/* dsnAlloc = Procedure zum anlegen/öffnen von datasets */
/* ggAlloc = READDSN call adrTso "free dd(READDSN)"; */
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'finis)' /* READDSN */
/* L. or m.op */
interpret subword(ggAlloc, 2) /* interpret = Befehl ausführen
subword = Wörter ab Pos2
von ggAlloc */
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
/* copy adrTso end ****************************************************/
/* copy m begin ********************************************************
stem and tree handling
***********************************************************************/
/*--- return Ky of m ------------------------------------------------*/
mKy: procedure expose m.
parse arg m
return m.mKey.m
endProcedure mKy
/*--- return number of children of node m or 0 -----------------------*/
mSize: procedure expose m.
parse arg m
if symbol('m.m.0') == 'VAR' then
return m.m.0
else
return 0
endProcedure mSize
/*--- return parent of node m or '' ----------------------------------*/
mPar: procedure expose m.
parse arg m
dx = lastPos('.', m)
if dx <= 1 then
return ''
else
return left(m, dx - 1)
endProcedure mPar
/*--- create a new tree root -----------------------------------------*/
mRoot: procedure expose m.
parse arg m, Ky, val /* m = ROOT, Ky = ROOT */
if m == '' then
m = 'mRoot.' || mIncD('mRoot.0')
m.m = val
m.mKey.m = Ky
m.m.0 = 0
return m
endProcedure mRoot
/*--- increase m.m and return it (also if undefined) -----------------*/
mIncD: procedure expose m.
parse arg m, delta /* m = ROOT, delta = '' */
if symbol('m.m') <> 'VAR' then
m.m = 0
return mInc(m)
endProcedure mIncD
/*--- increase m.m and return it (fail if undefined) -----------------*/
mInc: procedure expose m.
parse arg m, delta
if delta = '' then
m.m = m.m + 1
else
m.m = m.m + delta
return m.m
endProcedure mInc
/*--- add one or several values to stem m.m --------------------------*/
mAdd: procedure expose m.
parse arg m
ix = mSize(m)
do ax = 2 to arg()
ix = ix + 1
m.m.ix = arg(ax)
end
m.m.0 = ix
return m'.'ix
endProcedure mAdd
/*--- add to m.dst.* a (sub)sequence of m.src.* ----------------------*/
mAddSeq: procedure expose m.
parse arg dst, src, begX, endX
if begX = '' then
begX = 1
if endX = '' then
endX = mSize(src)
dx = mSize(dst)
do sx = begX to endX
dx = dx + 1
m.dst.dx = m.src.sx
end
m.dst.0 = dx
return dst
endProcedure mAddSeq
/*--- add one value to the stem m.m ----------------------------------*/
mAddNd: procedure expose m.
parse arg m
ix = mSize(m)
do ax = 2 to arg()
ix = ix + 1
m.m.ix = arg(ax)
m.m.ix.0 = 0
end
m.m.0 = ix
return m'.'ix
endProcedure mAddNd
/*--- add one Ky value pair to stem m.m -----------------------------*/
mAddKy: procedure expose m.
parse arg m, Ky, val
nn = mAddNd(m, val)
m.mKey.nn = Ky
return nn
endProcedure mAddKy
/*--- add one indexable Ky value pair to stem m.m -------------------*/
mAddK1: procedure expose m.
parse arg m, ky, val
if symbol('m.mIndex.m.mKey.ky') == 'VAR' then
call err 'duplicate Ky' ky 'for node' m
nn = mAddNd(m, val)
m.mKey.nn = ky
m.mIndex.m.mKey.ky = nn
return nn
endProcedure mAddK1
/*--- put value at Ky if it exists otherwise add the node -----------*/
mPut: procedure expose m.
parse arg m, Ky, val
if symbol('m.mIndex.m.mKey.Ky') == 'VAR' then do
ch = m.mIndex.m.mKey.Ky
m.ch = val
return ch
end
else do
return mAddK1(m, Ky, val)
end
return
endProcedure mPut
/*--- return the child of m at the given Ky, '' if not exists -------*/
mAtK1: procedure expose m.
parse arg m, ky
if symbol('m.mIndex.m.mKey.ky') == 'VAR' then
return m.mIndex.m.mKey.ky
else
return ''
endProcedure mAtK1
/*--- return the value of the child at Ky, fail if not exists -------*/
mVaAtK1: procedure expose m.
parse arg m, Ky
if symbol('m.mIndex.m.mKey.Ky') ^== 'VAR' then
call err 'no Ky' Ky 'at node' m
ch = m.mIndex.m.mKey.Ky
return m.ch
endProcedure mVaAtK1
/*--- return the value of the first defined ky in the list of nodes
def if ky isn't defined ---------------------------------------*/
mFirst: procedure expose m.
parse arg Ky, def
do ax=3 to arg()
m = arg(ax)
if symbol('m.mIndex.m.mKey.Ky') == 'VAR' then do
ch = m.mIndex.m.mKey.Ky
return m.ch
end
end
return def
endProcedure mFirst
/*--- return the child at sequenceNo seq of node m -------------------*/
mAtSq: procedure expose m.
parse arg m, seq
if symbol('m.m.seq') ^== 'VAR' then
return ''
else
return m'.'seq
endProcedure mAtSq
/*--- remove all or all after nwSz children --------------------------*/
mRemCh: procedure expose m.
parse arg pa, nwSz
if nwSz = '' then
nwSz = 0
do cx=nwSz+1 to mSize(pa)
ch = pa'.'cx
call mRemCh ch
ky = m.mKey.ch
drop m.mIndex.pa.mKey.ky m.mKey.ch m.ch m.ch.0
end
m.pa.0 = nwSz
return pa
endProcedure mRemCh
/*--- add to m.dst a (sub)tree of m.src.* ----------------------------*/
mAddTree: procedure expose m.
parse arg dst, src, begX, endX
if begX = '' then
begX = 1
if endX = '' then
endX = mSize(src)
do sx=begX to endX
sCh = src'.'sx
if symbol('m.mKey.sCh') ^= 'VAR' then do
dCh = mAddNd(dst, m.sCh)
end
else do
ky = m.mKey.sCh
if symbol('m.mIndex.src.mKey.ky') ^= 'VAR' then
dCh = mAddKy(dst, ky, m.sCh)
else
dCh = mAddK1(dst, ky, m.sCh)
end
call mAddTree dCh, sCh
end
return dst
endProcedure mAddTree
/*--- show from one node everything that is defined ------------------*/
mShowNd: procedure expose m.
parse arg m
pa = mPar(m)
t = 'node' m 'pa='pa
if symbol('m.m') == 'VAR' then
t = t 'va='m.m
if symbol('m.m.0') == 'VAR' then
t = t 'size='m.m.0
if symbol('m.mKey.m') == 'VAR' then do
ky = m.mKey.m
t = t 'ky='ky
if symbol('m.mIndex.pa.mKey.ky') == 'VAR' then
t = t 'index='m.mIndex.pa.mKey.ky
end
say t
return
endProcedure mShowNd
/*--- show the tree at m recursively ---------------------------------*/
mShow: procedure expose m.
parse arg m, lv
if lv = '' then
lv = 0
t = left('', lv)m
if symbol('m.mKey.m') == 'VAR' then do
ky = m.mKey.m
pa = mPar(m)
if symbol('m.mIndex.pa.mKey.ky') == 'VAR' then
t= t ky '>'
else
t= t ky '='
end
say t strip(m.m, 't')
do cx=1 to mSize(m)
call mShow mAtSq(m, cx), lv+1
end
return
endProcedure treeShow
/* copy m end *********************************************************/
/*--- 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 *****************************************************/
}¢--- A540769.WK.REXX(PRB) cre=2013-02-01 mod=2013-11-08-11.34.21 A540769 ------
/* rexx ---------------------------------------------------------------
edit macro fuer prb Columns 8.11.13 kidi 63
Walter Keller
line Commands
d: replace deleted lines with generate columns
a: b: add generated columns there
Options in First word of argument
g: tacct_general table (default)
p: tacct_program table
s: sum on numeric columns
e: fosFmte7 on numeric columns plus totals
n: add all numeric columns (not just the short list)
r: surround numeric columns with real
c: add all not numeric columns
second and following (space separated) words of argument
a<alias>: alias (default g)
e<expr> : sql expression with ~(tilde) placeHolder for current column
8.11.13 walter r=real option added to avoid fixpoint overflow
----------------------------------------------------------------------*/
call errReset hi
call mapIni
call adrEdit 'macro (args) NOPROCESS'
if pos('?', args) > 0 then
return help()
pc = adrEdit("process dest range D", 0 4 8 12 16)
if pc = 16 then
call err 'Only A or B line expected, \n ' ,
'You entered incomplete or conflicting line commands'
if pc = 0 | pc = 8 then do
call adrEdit "(rFi) = lineNum .zFrange"
call adrEdit "(rLa) = lineNum .zLrange"
m.dst = rFi - 1
call adrEdit 'delete' rFi rLa
end
if pc = 0 | pc = 4 then do
call adrEdit "(d1) = lineNum .zDest", 0 4
m.dst = d1 /* rc=4 ist lineNum 0| */
end
if pc = 12 then do
call adrEdit "(c1, c2) = cursor"
m.dst = c1
end
call addLine '-- begin prb insert' args
parse var args arg1 argR
argR = ' 'argR
if pos('p', arg1) > 0 then
tb = 'program'
else
tb = 'general'
txt = '-- tacct_'tb
i = mapInline('prb_'tb)
m.alias = left(tb, 1)
cx = pos(' a', argR)
if cx > 0 then
m.alias = word(substr(argR, cx+2), 1)
txt = strip(txt m.alias)','
if m.alias \== '' then
m.alias = m.alias'.'
m.e7 = pos('e', arg1) > 0
if m.e7 then
txt = txt 'fsoFmtE7,'
allNum = pos('n', arg1) > 0
notNum = pos('c', arg1) > 0
txt = txt word('short all', allNum + 1)','
m.expr = '~'
cx = pos(' e', argR)
if cx > 0 then
m.expr = word(substr(argR, cx+2), 1)
if pos('r', arg1) > 0 then
m.expr = repAll(m.expr, '~', 'real(~)')
if pos('s', arg1) > 0 then
m.expr = 'sum('m.expr')'
if length(txt m.expr) > 65 then do
call addLine txt
txt = '-- '
end
call addLine txt 'expr' m.expr
listExt = 0
do ix=1 to m.i.0
if abbrev(word(m.i.ix, 1), '*') then do
listExt = 1
iterate
end
parse var m.i.ix cNo col typ len 52 as 62
if cNo == 'f' then do
as = subWord(m.i.ix, 3)
fArgs = CLines()
if m.e7 then
call addFunction col, fArgs, as
iterate
end
if cNo == '+' then do
fArgs = CLines()
if m.e7 then
call addPlus typ, fArgs, as
iterate
end
if wordPos(typ, 'REAL FLOAT INTEGER SMALLINT DECIMAL') ,
< 1 then do
if notNum then
call addLine ' ,' haCol('as', col, as)
iterate
end
if listExt & (c.col == 1 | \ allNum) then
iterate
c.col = 1
call addLine ' ,' haCol('ages', col, as)
end
call addLine '-- end prb insert' args
exit
/*--- read all following c lines and return its words ---------------*/
cLines: procedure expose m. i ix
r = ''
do ix=ix+1 to m.i.0 while abbrev(m.i.ix, 'c ')
r = r strip(substr(m.i.ix, 3))
end
ix = ix - \ abbrev(m.i.ix, 'c ')
return r
endProcedure cLines
/*--- handle one column
opts: a=add alias
g=aggregate
e=fmtE7
s=as column name --------------------------------------*/
haCol: procedure expose m.
parse arg opts, col, as
r = col
if pos('a', opts) > 0 then
r = m.alias || r
r1 = r
if pos('g', opts) > 0 then
r = repAll(m.expr, '~', r)
if pos('e', opts) > 0 & m.e7 then
r = 'fosFmtE7('r')'
if pos('s', opts) > 0 then
if m.e7 & as \== '' then
r = r '"'strip(as)'"'
else if r1 <> r then
r = r col
return r
endProcedure haCol
/*--- handle non numeric column
opts: a=add alias
g=aggregate
e=fmtE7
s=as column name --------------------------------------*/
/*--- add one function
, arguments with alias and aggregate and AS ".." ---------------*/
addFunction: procedure expose m.
parse arg fun, aCols, as
t = ''
do ax=1 to words(aCols)
t = t',' haCol('ag', word(aCols, ax))
end
t = fun'('substr(t, 3)') "'strip(as)'"'
call addLineSplit t, ','
return
endProcedure addFunction
/*--- add one function
, arguments with alias and aggregate and AS ".." ---------------*/
addPlus: procedure expose m.
parse arg fun, aCols, as
t = ''
do ax=1 to words(aCols)
t = t '+' haCol('a', word(aCols, ax))
end
t = haCol('g', '('substr(t, 4)')')
if fun == '-' then
t = haCol('e', t)
else
t = strip(fun)'('t')'
call addLineSplit t '"'strip(as)'"', '+'
return
endProcedure addPlus
addLine: procedure expose m.
parse arg li
call adrEdit "line_after" m.dst " = (li)"
m.dst = m.dst + 1
return
endProcedure addLine
addLineSplit: procedure expose m.
parse arg src, spl
r = ' ,' src
do while length(r) > 70
lx = lastPos(spl, r, 70)
call addLine left(r, lx-1)
r = ' ' substr(r, lx)
end
call addLIne r
return
endProcedure addLIneSPlit
$</prb_general/
*** PBDD.TACCT_GENERAL
32 ELAPSETOD FLOAT 8 totElap
33 ELAPSETCB FLOAT 8 totCPU
37 EDB2TOD FLOAT 8 db2Elap
38 EDB2TCB FLOAT 8 db2CPU
f fosGeWait wait % 1. % 2. % 3.
c eWaitIO waitReadIO waitWriteIO openClsElap
c datasetElap eWaitLAL
c sysLgRngElap logWrtElap waitArcLog archReadWar
c drainLkWDR claimRlWcl
c gblLokElap wtelawtk wtelawtm wtelawtn
c wtelawto wtelawtq gblMsgElap
c waitSyncEvent otherSWElap spWaitElap
c funcWait lobWaitElap
+ - - sqls
c p2Commits aborts
c selects inserts updates deletes
c describes prepares opens fetches closes
c setcurprec dclglobaltt sqlcrgtt
35 P2COMMITS FLOAT 8 commit
36 ABORTS FLOAT 8 abort
132 SELECTS FLOAT 8
133 INSERTS FLOAT 8
134 UPDATES FLOAT 8
135 DELETES FLOAT 8
136 DESCRIBES FLOAT 8
137 PREPARES FLOAT 8
138 OPENS FLOAT 8
139 FETCHES FLOAT 8
140 CLOSES FLOAT 8
86 LOGWRTELAP FLOAT 8 logEla
88 LOGRECORDS FLOAT 8 logRecs
89 LOGBYTES FLOAT 8 logByte
153 BPGETPAGE FLOAT 8
154 BPPGUPDAT FLOAT 8
155 BPSYNCRD FLOAT 8
156 BPPREFET FLOAT 8
157 BPSYNCWR FLOAT 8
158 BPLISTPREF FLOAT 8
159 BPDPF FLOAT 8
160 BPNGT FLOAT 8
161 BPSIO FLOAT 8
+ - REAL wait
c eWaitIO waitReadIO waitWriteIO openClsElap
c datasetElap eWaitLAL
c sysLgRngElap logWrtElap waitArcLog archReadWar
c drainLkWDR claimRlWcl
c gblLokElap wtelawtk wtelawtm wtelawtn
c wtelawto wtelawtq gblMsgElap
c waitSyncEvent otherSWElap spWaitElap
c funcWait lobWaitElap
*** PBDD.TACCT_GENERAL
1 OCCURRENCES INTEGER 4
2 SYSTEMID CHAR 4
3 SUBSYSTEM CHAR 4
4 PLANNAME CHAR 8
5 AUTHID CHAR 8
6 CONNECTION CHAR 8
7 CORRID CHAR 12
8 ORIGPRIMID CHAR 8
9 LUWIDNID CHAR 8
10 LUWIDLUNM CHAR 8
11 LUWIDINST CHAR 6
12 LUWIDCOMIT FLOAT 8
13 CONNTYPE CHAR 8
14 DATETIME TIMESTMP 10
15 DATE DATE 4
16 LOCATION CHAR 16
17 GROUPNAME CHAR 8
18 FIRSTPKG CHAR 18
19 ACCTTOKN CHAR 22
20 ENDUSERID CHAR 16
21 ENDUSERTX CHAR 32
22 ENDUSERWN CHAR 18
23 PSTNUMBER CHAR 4
24 PSBNAME CHAR 8
25 CICSTRAN CHAR 4
26 CORRNAME CHAR 8
27 NETWORKID CHAR 16
28 TRANSCNT FLOAT 8
29 CLASS2CNT FLOAT 8
30 CLASS3CNT FLOAT 8
31 IFCIDSEQ# FLOAT 8
32 ELAPSETOD FLOAT 8
33 ELAPSETCB FLOAT 8
34 ELAPSESRB FLOAT 8
35 P2COMMITS FLOAT 8
36 ABORTS FLOAT 8
37 EDB2TOD FLOAT 8
38 EDB2TCB FLOAT 8
39 EDB2SRB FLOAT 8
40 EWAITIO FLOAT 8 synIOWait
41 EWAITLAL FLOAT 8 locLoLaWait
42 ENTEXEVNT FLOAT 8
43 WAITEVNT FLOAT 8
44 WAITREADIO FLOAT 8 othReaWait
45 WAITWRITEIO FLOAT 8 othWriWait
46 WAITSYNCEVENT FLOAT 8 uniSwiWait
47 WAITARCLOG FLOAT 8 arcLogWait
48 WEVLOCK FLOAT 8
49 WEVREAD FLOAT 8
50 WEVWRITE FLOAT 8
51 WEVSYNCH FLOAT 8
52 CLASS1CPU_ZIIP FLOAT 8
53 CLASS2CPU_ZIIP FLOAT 8
54 TRIGGERCPU_ZIIP FLOAT 8
55 CPUZIIPELIGIBLE FLOAT 8
56 ARCLOG FLOAT 8
57 DRAINLKRND FLOAT 8
58 DRAINLKWDR FLOAT 8 drainWait
59 CLAIMRLWCL FLOAT 8 claimWait
60 CLAIMRLRNC FLOAT 8
61 ARCHREADWAR FLOAT 8 arcReaWait
62 ARCHREADNAR FLOAT 8
63 OPENCLSELAP FLOAT 8 opeCloWait
64 SYSLGRNGELAP FLOAT 8 sysLgRaWait
65 DATASETELAP FLOAT 8 datSetWait
66 OTHERSWELAP FLOAT 8 othSwiEla
67 OPENCLSEVNT FLOAT 8
68 SYSLGRNGEVNT FLOAT 8
69 DATASETEVNT FLOAT 8
70 OTHERSWEVNT FLOAT 8
71 LATCHCNTWTP FLOAT 8
72 LATCHCNTRNH FLOAT 8
73 GBLMSGELAP FLOAT 8 gblMsgWait s
74 GBLMSGEVNT FLOAT 8
75 GBLLOKELAP FLOAT 8 gblConWait s
76 GBLLOKEVNT FLOAT 8
77 SPTCB FLOAT 8 stoProCpu c1 nurWLM
78 SPTCBINDB2 FLOAT 8 stoProDb2 c2
79 SPEVNT FLOAT 8
80 SPWAITELAP FLOAT 8 stoProWait
81 SPWAITCNT FLOAT 8
82 PARATASKS FLOAT 8
83 PARALLTASKS FLOAT 8
84 CPUSUCONV FLOAT 8
85 LOGWRTEVNT FLOAT 8
86 LOGWRTELAP FLOAT 8 logWrtWait
87 WLMSVCCLASS CHAR 8
88 LOGRECORDS FLOAT 8
89 LOGBYTES FLOAT 8
90 FUNCTCB FLOAT 8 funcCpu c1 cpu
91 FUNCSQLTCB FLOAT 8 funcD2Cpu c2 cpu
92 FUNCSQLEVNT FLOAT 8
93 LOBWAITCNT FLOAT 8
94 FUNCWAIT FLOAT 8 funcWait
95 FUNCELAP FLOAT 8 funcEla c1 ela
96 FUNCSQLELAP FLOAT 8 funcD2Ela c2 ela
97 TRIGGERTCB FLOAT 8 triD2Cpu
98 TRIGGERELAP FLOAT 8 triD2Ela
99 PREENCTCB FLOAT 8 ???
100 PREENCSQLTCB FLOAT 8 ???
101 SPROCELAP FLOAT 8 stoProToEla
102 SPROCSQLELAP FLOAT 8 stoProD2Ela
103 ENCTRIGGERTCB FLOAT 8 triNesToCpu
104 ENCTRIGGERELAP FLOAT 8 triNesToEla
105 LOBWAITELAP FLOAT 8
106 SPNFCPUZIIP FLOAT 8 ???
107 SPNFCPU FLOAT 8 ???
108 SPNFELAP FLOAT 8 ???
109 UDFNFCPUZIIP FLOAT 8
110 UDFNFCPU FLOAT 8
111 UDFNFELAP FLOAT 8
112 SVPOINTREQ FLOAT 8
113 SVPOINTREL FLOAT 8
114 SVPOROLLBK FLOAT 8
115 WTELAWTK FLOAT 8 gblChiWait
116 WTELAWTM FLOAT 8 gblOtLWait
117 WTELAWTN FLOAT 8 gblPrPWait
118 WTELAWTO FLOAT 8 gblPgPWait
119 WTELAWTQ FLOAT 8 gblOtPWait
120 WTEVARNK FLOAT 8
121 WTEVARNM FLOAT 8
122 WTEVARNN FLOAT 8
123 WTEVARNO FLOAT 8
124 WTEVARNQ FLOAT 8
125 WTELAWFC FLOAT 8 ???
126 WTEVFCCT FLOAT 8
127 WTELIXLT FLOAT 8
128 WTEVIXLE FLOAT 8
129 SETCURPREC FLOAT 8
130 DCLGLOBALTT FLOAT 8
131 PARAGLOBALTT FLOAT 8
132 SELECTS FLOAT 8
133 INSERTS FLOAT 8
134 UPDATES FLOAT 8
135 DELETES FLOAT 8
136 DESCRIBES FLOAT 8
137 PREPARES FLOAT 8
138 OPENS FLOAT 8
139 FETCHES FLOAT 8
140 CLOSES FLOAT 8
141 PARAMAXDEG FLOAT 8
142 PARAREDGRP FLOAT 8
143 SQLCALLAB FLOAT 8
144 SQLCALLTO FLOAT 8
145 SQLCRGTT FLOAT 8
146 REOPTIMIZE FLOAT 8
147 DIRECTROWIX FLOAT 8
148 DIRECTROWTS FLOAT 8
149 FUNC FLOAT 8
150 FUNCAB FLOAT 8
151 FUNCTO FLOAT 8
152 FUNCRJ FLOAT 8
153 BPGETPAGE FLOAT 8
154 BPPGUPDAT FLOAT 8
155 BPSYNCRD FLOAT 8
156 BPPREFET FLOAT 8
157 BPSYNCWR FLOAT 8
158 BPLISTPREF FLOAT 8
159 BPDPF FLOAT 8
160 BPNGT FLOAT 8
161 BPSIO FLOAT 8
162 DEADLOCKS FLOAT 8
163 SUSPENDS FLOAT 8
164 TIMEOUTS FLOAT 8
165 LOCKESHR FLOAT 8
166 LOCKEXCL FLOAT 8
167 MAXPGLOCKS FLOAT 8
168 SUSPLATCH FLOAT 8
169 SUSPOTHER FLOAT 8
170 LOCKREQS FLOAT 8
171 CLAIMREQ FLOAT 8
172 CLAIMREQUN FLOAT 8
173 DRAINREQ FLOAT 8
174 DRAINREQUN FLOAT 8
175 GBPREADINVBD FLOAT 8
176 GBPREADINVBR FLOAT 8
177 GBPREADNOPGD FLOAT 8
178 GBPREADNOPGR FLOAT 8
179 GBPREADNOPGN FLOAT 8
180 GBPWRITCHG FLOAT 8
181 GBPWRITCLEAN FLOAT 8
182 GBPUNREGPG FLOAT 8
183 GBPEXPLICITXI FLOAT 8
184 GBPWRITCHK2 FLOAT 8
185 GBPASYNPRIM FLOAT 8
186 GBPASYNSEC FLOAT 8
187 GBPDEPGETPG FLOAT 8
188 GBPPLKSPMAP FLOAT 8
189 GBPPLKDATA FLOAT 8
190 GBPPLKIDX FLOAT 8
191 GBPPLKUNLK FLOAT 8
192 GBPPSUSSPMAP FLOAT 8
193 GBPPSUSDATA FLOAT 8
194 GBPPSUSIDX FLOAT 8
195 GBPWARMULTI FLOAT 8
196 GBPWAR FLOAT 8
197 GLPLOCKLK FLOAT 8
198 GLPLOCKCHG FLOAT 8
199 GLPLOCKUNLK FLOAT 8
200 GLXESSYNCLK FLOAT 8
201 GLXESSYNCCHG FLOAT 8
202 GLXESSYNCUNLK FLOAT 8
203 GLSUSPIRLM FLOAT 8
204 GLSUSPXES FLOAT 8
205 GLSUSPFALSE FLOAT 8
206 GLINCOMPAT FLOAT 8
207 GLNOTFYSENT FLOAT 8
208 GLFALSECONT FLOAT 8
209 RLFCPULIMITU FLOAT 8
210 RLFCPUUSEDU FLOAT 8
211 UNLOCKREQS FLOAT 8
212 QUERYREQS FLOAT 8
213 CHNGREQS FLOAT 8
214 IFIELAPSED FLOAT 8
215 IFITCBCPU FLOAT 8
216 IFIELAPDTC FLOAT 8
217 IFIELAPEXT FLOAT 8
218 PROGRAMS FLOAT 8
219 LOADTS TIMESTMP 10
$/prb_general/
$</prb_program/
*** PBDD.TACCT_PROGRAM
27 ELAPSEPKG FLOAT 8 pkgElap
28 CPUTCBPKG FLOAT 8 pkgCpu
46 CLASS7CPU_ZIIP FLOAT 8 pkgZIIP
f fosPrWait wait % 1. % 2. % 3.
c ELAPSYNCIO ELPLOCK ELPOTHREAD ELPOTHWRIT
c ELPUNITSW ELPARCQIS ELPDRAIN ELPCLAIM
c ELPARCREAD ELPPGLAT GBLMSGELAP GBLLOKELAP
c SPWAITELAP FUNCWAIT LOBWAITELAP WTELAWTK
c WTELAWTM WTELAWTN WTELAWTO WTELAWTQ
52 BPGETPAGE FLOAT 8 bpGetPg
53 BPPGUPDAT FLOAT 8 bpUpdPg
54 BPSYNCRD FLOAT 8 bpSynRe
75 SQLCALL FLOAT 8
26 SQLCOUNT FLOAT 8
66 SELECTS FLOAT 8
67 INSERTS FLOAT 8
68 UPDATES FLOAT 8
69 DELETES FLOAT 8
70 DESCRIBES FLOAT 8 describ
71 PREPARES FLOAT 8 prepare
72 OPENS FLOAT 8
73 FETCHES FLOAT 8
74 CLOSES FLOAT 8
+ - real wait
c ELAPSYNCIO ELPLOCK ELPOTHREAD ELPOTHWRIT
c ELPUNITSW ELPARCQIS ELPDRAIN ELPCLAIM
c ELPARCREAD ELPPGLAT GBLMSGELAP GBLLOKELAP
c SPWAITELAP FUNCWAIT LOBWAITELAP WTELAWTK
c WTELAWTM WTELAWTN WTELAWTO WTELAWTQ
*** all of PBDD.TACCT_PROGRAM
1 OCCURRENCES INTEGER 4
2 SYSTEMID CHAR 4
3 SUBSYSTEM CHAR 4
4 PLANNAME CHAR 8
5 AUTHID CHAR 8
6 CONNECTION CHAR 8
7 CORRID CHAR 12
8 ORIGPRIMID CHAR 8
9 CONNTYPE CHAR 8
10 DATETIME TIMESTMP 10
11 DATE DATE 4
12 LOCATION CHAR 16
13 GROUPNAME CHAR 8
14 ENDUSERID CHAR 16
15 ENDUSERTX CHAR 32
16 ENDUSERWN CHAR 18
17 CORRNAME CHAR 8
18 CLASS7CNT FLOAT 8
19 CLASS8CNT FLOAT 8
20 IFCIDSEQ# FLOAT 8
21 CPUSUCONV FLOAT 8
22 EXECLOCATION CHAR 16
23 COLLECTIONID CHAR 18
24 PROGRAMNAME CHAR 18
25 CONSISTOKEN CHAR 16
26 SQLCOUNT FLOAT 8
27 ELAPSEPKG FLOAT 8
28 CPUTCBPKG FLOAT 8
29 ELAPSYNCIO FLOAT 8 syncIOW
30 ELPLOCK FLOAT 8
31 ELPOTHREAD FLOAT 8 othReaW
32 ELPOTHWRIT FLOAT 8 othWriW
33 ELPUNITSW FLOAT 8 unitSwW
34 ELPARCQIS FLOAT 8 arcLQuW
35 ELPDRAIN FLOAT 8 drainW
36 ELPCLAIM FLOAT 8 claimW
37 ELPARCREAD FLOAT 8 arcLReW
38 ELPPGLAT FLOAT 8 pgLatW
39 GBLMSGELAP FLOAT 8 glMsgW
40 GBLLOKELAP FLOAT 8 glLockW
41 SPWAITELAP FLOAT 8 stPrW
42 SPROCCNT FLOAT 8
43 FUNCWAIT FLOAT 8
44 FUNCCNT FLOAT 8
45 LOBWAITELAP FLOAT 8 lobW
46 CLASS7CPU_ZIIP FLOAT 8
47 WTELAWTK FLOAT 8 glChiW
48 WTELAWTM FLOAT 8 glOthW
49 WTELAWTN FLOAT 8 glPrtW
50 WTELAWTO FLOAT 8 glPgPhW
51 WTELAWTQ FLOAT 8 glOtPhW
52 BPGETPAGE FLOAT 8
53 BPPGUPDAT FLOAT 8
54 BPSYNCRD FLOAT 8
55 RLFCPULIMITU FLOAT 8
56 RLFCPUUSEDU FLOAT 8
57 SUSPLATCH FLOAT 8
58 SUSPOTHER FLOAT 8
59 LOCKREQS FLOAT 8
60 UNLOCKREQS FLOAT 8
61 QUERYREQS FLOAT 8
62 CHNGREQS FLOAT 8
63 IRLMREQS FLOAT 8
64 CLAIMREQ FLOAT 8
65 DRAINREQ FLOAT 8
66 SELECTS FLOAT 8
67 INSERTS FLOAT 8
68 UPDATES FLOAT 8
69 DELETES FLOAT 8
70 DESCRIBES FLOAT 8
71 PREPARES FLOAT 8
72 OPENS FLOAT 8
73 FETCHES FLOAT 8
74 CLOSES FLOAT 8
75 SQLCALL FLOAT 8
76 LOADTS TIMESTMP 10
$/prb_program/
/* copy adrIsp begin *************************************************/
/**********************************************************************
lmd: catalog read
call sequence: lmdBegin, lmdNext*, lmdEnd
mit lmd service (mit save in file und read,
weil list zu langsam und listcat abstürzt)
1. arg (grp) als group dataset für lmd save
und dd name für file read
***********************************************************************/
lmdBegin: procedure expose m.
parse arg grp, lev
call adrIsp 'lmdinit listid(lmdId) level('lev')'
res = adrIsp('lmdlist listid(&lmdId) option(save) group('grp')', 4)
call adrIsp 'lmdfree listid(&lmdId)'
if res = 0 then do
call trc timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') shr dsn('grp'.datasets)'
end
else do
call trc 'no datasets found' timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') dummy'
end
call readDDBegin grp
return /* end lmdBegin */
lmdNext:
parse arg ggGrp, ggSt, withVolume
if \ readDD(ggGrp, ggSt) then
return 0
if withVolume \== 1 then
do ggIx=1 to value(ggSt'0')
x = value(ggSt || ggIx, word(value(ggSt || ggIx), 1))
end
return 1
endSubroutin lmdNext
lmdEnd: procedure expose m.
parse arg grp
call readDDEnd grp
call adrTso 'free dd('grp')'
return /* end lmdEnd */
lmd: procedure expose m.
parse arg lev, withVol
call lmdBegin gg1, lev
do while lmdNext(gg1, q., withVol)
do x=1 to q.0
call out q.x
end
end
call lmdEnd gg1
return
endProcedure lmd
/**********************************************************************
member list of a pds:
call sequence x=lmmBegin(dsn) lmmNext(x) * lmmEnd(x)
***********************************************************************/
lmm: procedure expose m.
parse arg dsn
id = lmmBegin(dsn)
do ix=1 by 1
m = lmmNext(id)
if m = '' then
leave
call out m
end
call lmmEnd id
return
endProcedure lmm
lmmBegin: procedure expose m.
parse arg dsn
mbr = dsnGetMbr(dsn)
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET('"pds"') ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(INPUT) "
res = lmmId
if mbr <> '' then
res = res 'pattern('mbr')'
return res
endProcedure lmmBegin
lmmEnd: procedure expose m.
parse arg lmmId opt
call adrIsp "LMMLIST DATAID("lmmId") option(free)", 8
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
return
endProcedure lmmEnd
lmmNext: procedure expose m.
parse arg lmmId opt
if adrIsp("LMMLIST DATAID("lmmid")" ,
"OPTION(LIST) MEMBER(Mbr)" opt, 4 8) = 0 then
return strip(mbr)
else
return ''
endProcedure lmmNext
lmmRm: procedure expose m.
parse arg dsn, mbrs
mbrs = dsnGetMbr(dsn) mbrs
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET("pds") ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(OUTPUT) "
err = ''
do wx=1 to words(mbrs)
m1 = word(mbrs, wx)
rr = adrIsp("lmmDel dataid("lmmId") member("m1")", 0 8 12)
if rc = 0 then
say 'removed' m1 'from' pds
else if rc = 8 then
say 'not found' m1 'in' pds
else do
err = 'error deleting' m1 'in' pds 'rc' rr strip(zerrlm)
say err
leave
end
end
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
if err <> '' then
call err err
return
endProcedure lmmRm
/*--- address ispf with error checking -------------------------------*/
adrIsp:
parse arg ggIspCmd, ggRet
address ispexec ggIspCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr ispExec rc' rc 'in' ggIspCmd':' strip(zerrlm)
endSubroutine adrIsp
/*--- address editor with error checking -----------------------------*/
adrEdit:
parse arg ggEditCmd, ggRet
address isrEdit ggEditCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr isrEdit rc' rc 'for' ggEditCmd
endSubroutine adrEdit
/* copy adrIsp end *************************************************/
/* copy adrTso begin *************************************************/
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet ---*/
adrTso:
parse arg ggTsoCmd, ggRet
address tso ggTsoCmd
if rc == 0 then return 0
else if ggRet == '*' then return rc
else if wordPos(rc, ggRet) > 0 then return rc
else
call err 'adrTso rc' rc 'for' ggTsoCmd
return /* end adrTso */
/*--- format dsn from tso format to jcl format -----------------------*/
dsn2jcl: procedure expose m.
parse upper arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
cx = pos('~', dsn)
if cx < 1 & addPrefix == 1 then
return sp'.'dsn
do while cx \== 0
le = left(dsn, cx-1)
ri = substr(dsn, cx+1)
if right(le, 1) == '.' | left(ri, 1) == '.' then
dsn = le || sp || ri
else
dsn = le || left('.', le \== '') || sp ,
|| left('.', ri \== '') || ri
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
parse arg dsn, mbr
bx = pos('(', dsn)
if bx > 0 then
dsn = strip(left(dsn, bx-1))
if mbr <> '' then
dsn = dsn'('strip(mbr)')'
return dsn
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn
lx = pos('(', dsn)
rx = pos(')', dsn, lx+1)
if lx < 1 then
return ''
else if lx < rx then
return substr(dsn, lx+1, rx-lx-1)
else
return strip(substr(dsn,lx+1))
endProcedure dsnGetMbr
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: readDDBegin, readDD*, readDDEnd
write: writeBegin, writeDD*, writeEnd
readDD returns true if data read, false at eof
***********************************************************************/
/*--- prepare reading from a DD --------------------------------------*/
readDDBegin: procedure expose m.
parse upper arg ggDD
call errAddCleanup 'call readDDEnd' ggDD', "*"'
return /* end readDDBegin */
/*--- read from DD ggDD into ggSt, return false at eof ---------------*/
readDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskr' ggDD '(stem' ggSt')', 2
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- finish reading DD ggDD ----------------------------------------*/
readDDEnd: procedure expose m.
parse upper arg ggDD, ggRet
call errRmCleanup 'call readDDEnd' ggDD', "*"'
return adrTso('execio 0 diskr' ggDD '(finis)', ggRet)
endProcedure readDDEnd
/*--- prepare writing to DD ggDD -------------------------------------*/
writeDDBegin: procedure expose m.
parse upper arg ggDD
/* ensure file is erased, if no records are written */
call adrTso 'execio' 0 'diskw' ggDD '(open)'
call errAddCleanup 'call writeDDEnd' ggDD', "*"'
return /* end writeDDBegin */
/*--- write to gg ggDD from stem ggSt, ggCnt records -----------------*/
writeDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt == '' then
ggCnt = value(ggst'0')
call adrTso 'execio' ggCnt 'diskw' ggDD '(stem' ggSt')'
return
endSubroutine writeDD
/*--- end writing to dd ggDD (close) --------------------------------*/
writeDDEnd: procedure expose m.
parse upper arg ggDD, ggRet
call errRmCleanup 'call writeDDEnd' ggDD', "*"'
return adrTso('execio 0 diskw' ggDD '(finis)', ggRet)
endProcedure writeDDEnd
/*--- readNx: read next line, using buffer ---------------------------*/
/*--- begin: allocate dsnSpec and ini ------------------------ -------*/
readNxBegin: procedure expose m.
parse arg m, m.m.dsn, m.m.dd, m.m.Cnt
if m.m.dd = '' then
m.m.dd = 'DDNX'
if m.m.cnt = '' then
m.m.cnt = 1000
m.m.cx = m.m.cnt + 999
m.m.buf0x = 0
m.m.0 = 0
m.m.free = subword(dsnAlloc('dd('m.m.dd')' m.m.dsn), 2)
call readDDBegin m.m.dd
return m
endProcedure readDDNxBegin
/*--- return the stem of the next line, or '' at end -----------------*/
readNx: procedure expose m.
parse arg m
m.m.cx = m.m.cx + 1
if m.m.cx <= m.m.0 then
return m'.'m.m.cx
m.m.buf0x = m.m.buf0x + m.m.0
if \ readDD(m.m.dd, 'M.'m'.', m.m.cnt)then
return ''
m.m.cx = 1
return m'.1'
endProcedure readDDNx
/*--- return the stem of the curr line, '' at end --------------------*/
readNxCur: procedure expose m.
parse arg m
if m.m.cx <= m.m.0 then
return m'.'m.m.cx
else
return ''
endProcedure readNxCur
/*--- return the position (line number) of reader
plus le characters of the current line (default 50) ------*/
readnxPos: procedure expose m.
parse arg m, le
li = m'.'m.m.cx
li = strip(m.li, 't')
if arg() < 2 then
le = 50
if le < 1 then
li = ''
else if length(li) <= le then
li = ':' li
else
li = ':' left(li, le-3)'...'
return 'line' (m.m.buf0x + m.m.cx)li
endProcedure readnxPos
/*--- close and deallocate ------------------------------------------*/
readNxEnd: procedure expose m.
parse arg m
call readDDEnd m.m.dd
interpret m.m.free
return
endProcedure readDDNxEnd
/*--- standardise a dsn spec
word1 dsName or -
word2 dd or -
word3 disp or -
word4 to first : attributes in tso format
after first : attributes for new allocation
----------------------------------------------------------------------*/
dsnSpec: procedure expose m.
parse upper arg spec
rr = '' /* put leading - in separate words */
do sx=1 while words(rr) < 3 & wx \= ''
wx = word(spec, sx)
do while abbrev(wx, '-') & words(rr) < 3
wx = substr(wx, 2)
rr = rr '-'
end
rr = rr wx
end
spec = rr subWord(spec, sx)
na = ''
dd = ''
di = ''
if left(spec, 1) = '&' then /* external spec is handled ok */
spec = strip(substr(spec, 2))
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, '.') | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
di = w
else if w = 'CATALOG' then
di = di w
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
na = strip(substr(w, 5, length(w)-5))
else if na == '' then
na = dsn2jcl(w)
else if dd == '' then
dd = w
else if di == '' then
di = w
else
leave
end
if na == '' then
na = '-'
else if abbrev(na, "'") then
na = substr(na, 2, length(na)-2)
if dd == '' then dd = '-'
if di == '' then di = '-'
re = subword(spec, wx)
if abbrev(re, '.') then
re = substr(re, 2)
return na dd di re
endProcedure dsnSpec
/*--- alloc a dsn with dsnAlloc
if the dsn is inuse wait and retry
until either the allocation is successfull
or the timeout occurs --------------------------------------*/
dsnAllocWait: procedure expose m.
parse upper arg spec, pDi, pDD, timeOut
x = max(1, arg() - 1)
do rt=0
m.adrTsoAl.1 = ''
m.adrTsoAl.2 = ''
m.adrTsoAl.3 = ''
call outtrap m.adrTsoAl.
res = dsnAlloc(spec, pDi, pDD, '*')
call outtrap off
if \ abbrev(res, ' ') then
return res
msg = m.adrTsoAl.1'\n'm.adrTsoAl.2'\n'm.adrTsoAl.3
if rt > timeOut & timeOut \== '' then
return err('timeout allocating' spec time() '\n'msg)
if pos('DATA SET IS ALLOCATED TO ANOTHER', msg) < 1 then
return err('allocating' spec'\n'msg)
say time() 'sleep and retry alloc' spec
call sleep 1, 0
end
endProcedure dsnAllocWait
/*--- alloc a dsn or a dd
spec '-'<ddName>
datasetName? disposition? '.'? attributes? (':' newAtts)?
disp default disposition
dd default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc -----*/
dsnAlloc: procedure expose m.
parse upper arg spec, pDi, pDD, retRc
parse value dsnSpec(spec) with na dd di rest
if na = '-' then
m.dsnAlloc.dsn = ''
else
m.dsnAlloc.dsn = na
if na == '-' & dd \== '-' & di == '-' & rest = '' then
return dd
if dd == '-' & pDD \== '' then
dd = pDD
if dd == '-' then do
if symbol('m.adrTso.ddNum') = 'VAR' then
dd = m.adrTso.ddNum + 1
else
dd = 1
m.adrTso.ddNum = dd
dd = 'DD' || dd
end
if di = '-' & pDi \== '' then
di = pDi
if di = '-' then
di = 'SHR'
else if pos('(', na) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if pos('/', na) > 0 then
return csmAlloc(na dd di rest, retRc)
else
return tsoAlloc(na dd di rest, retRc)
endProcedure dsnAlloc
tsoAlloc: procedure expose m.
parse arg na dd disp rest ':' nn, retRc
c = 'alloc dd('dd')' disp
if na \== '-' then
c = c "DSN('"na"')"
else if disp = 'NEW' and nn \== '' then
c = c dsnCreateAtts(,nn)
call outtrap m.adrTsoAl.
alRc = adrTso(c rest, '*')
call outtrap off
if alRc = 0 then do
call errAddCleanup 'call tsoFree' dd', "*"'
return dd 'call tsoFree' dd';'
end
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& sysDsn("'"m.dsnAlloc.dsn"'") == 'DATASET NOT FOUND' then do
say 'tsoAlloc creating' c rest ':'nn
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na dd disp rest, retRc)
end
do ax=1 to m.adrTsoAl.0
say m.adrTsoal.ax
end
if retRc = '*' | wordPos(alRc, retRc) > 0 then
return ' ' alRc
call err 'tsoAlloc rc' alRc 'for' c rest
endProcedure tsoAlloc
tsoAtts: procedure expose m.
parse arg dsn
rc = listDsi("'"dsn"' SMSINFO")
if rc = 0 then
mv = ''
else if rc = 4 & sysReason = 19 then do
mv = 'UNITCNT(30)'
say 'multi volume' mv
end
else if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
al = 'CAT'
al = ''
if right(sysDsSms, 7) == 'LIBRARY' ,
| abbrev(sysDsSms, 'PDS') then
al = al 'DSNTYPE(LIBRARY)'
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
al = al "DSORG("sysDSorg") MGMTCLAS("sysMgmtClass")",
"DATACLAS("sysDataClass")" ,
"RECFM("translate('1 2 3', ' 'sysREcFM, ' 123')")",
"LRECL("SYSLRECL")",
"blksize("sysBLkSIZE")",
"SPACE("sysPrimary"," sysSeconds")" sysUnits mv
return al
endProcedure tsoAtts
tsoFree: procedure expose m.
parse arg dd, ggRet
call adrTso 'free dd('dd')', ggRet
call errRmCleanup 'call tsoFree' dd', "*"'
return
endProcedure tsoFree
dsnCreateAtts: procedure expose m.
parse arg dsn, atts, forCsm
forCsm = forCsm == 1
aU = ' 'translate(atts)
if abbrev(atts, ':') then do
parse var atts a1 atts
bl = 32760
rl = substr(a1, 3)
if abbrev(a1, ':F') then do
if rl = '' then
rl = 80
recfm='f b'
bl = bl - (bl // rl)
end
else do
if rl = '' then
rl = bl-4
recfm = substr(a1, 2, 1) 'b'
end
if forCsm then
atts = atts "recfm("space(recfm, 0)") lrecl("rl")",
"blkSize("bl")"
else
atts = atts "recfm("recfm") lrecl("rl") block("bl")"
end
if pos('(', dsn) > 0 & pos(' DSNTYPE(', aU) < 1 ,
& pos(' DSORG(', aU) < 1 then
atts = atts 'dsntype(library) dsorg(po)'
if pos(' MGMTCLAS(', aU) < 1 then
atts = atts 'mgmtclas(COM#A091)'
if pos(' SPACE(', aU) < 1 then
if forCsm then
atts = atts 'space(10, 1000) cylinder'
else
atts = atts 'space(10, 1000) cyl'
if dsn == '' then
return atts
return "dataset('"dsnSetMbr(dsn)"')" atts
endProcedure dsnCreateAtts
/*--- check if a dataset is archive ------------------------------------
returns 'ok' if dataset on disk
'not' if dataset is not catalogued
'arc' if dataset archived
listDsi errorMsg otherwise ------------------*/
dsnArc: procedure expose m.
parse upper arg dsn
lc = listDsi("'"strip(dsn)"' noRecall")
if lc = 0 then
return 'ok'
else if lc=4 & sysReason = 19 then /* multiple volumes */
return 'ok'
else if lc=16 & sysReason = 5 then
return 'notCat'
else if lc=16 & sysReason = 9 then
return 'arc'
else
return 'listDsi cc='lc', sysReason='sysReason ,
'm2='sysMsgLvl2', m1='sysMsgLvl1
endProcedure dsnArc
/*--- read the dataset specified in ggDsnSpec to stem ggSt -----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
interpret subword(ggAlloc, 2)
return
endSubroutine readDsn
/*--- write the dataset specified in ggDsnSpec from stem ggSt
write ggCnt records if not empty otherwise ggst0
if ggSay 1 then say ... records written to ... -------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'open finis)'
interpret subword(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
copyDSN: procedure expose m.
parse arg frSpec, toSpec, ggSay
frDD = dsnAlloc(frSpec, 'SHR', 'FRDD')
toDD = dsnAlloc(toSpec, 'OLD', 'TODD')
call readDDBegin word(frDD, 1)
call writeDDBegin word(toDD, 1)
cnt = 0
do while readDD(word(frDD, 1), r.)
call writeDD word(toDD, 1), r.
cnt = cnt + r.0
end
call readDDEnd word(frDD, 1)
call writeDDEnd word(toDD, 1)
interpret ';' subword(frDD, 2) '; ; ;' subword(toDD, 2)
if ggSay == 1 | m.debug == 1 then
say cnt 'records copied from' frSpec 'to' to toSpec
return
endSubroutine writeDsn
/* copy adrTso end ****************************************************/
/* copy map begin ******************************************************
a map stores values at keys
it may also maintain a list of keys
the basic ideas are similar to the java Interface java.util.Map
contrary to stems we also handle keys longer then 250 bytes
***********************************************************************/
/*--- initialize the module ------------------------------------------*/
mapIni: procedure expose m.
if m.map.ini = 1 then
return
m.map.ini = 1
call mIni
m.map.0 = 0
m.map.inlineSearch = 1
call mapReset map.inlineName, map.inline
return
endProcedure mapIni
mapInline: procedure expose m.
parse arg pName, opt
if mapHasKey(map.inlineName, pName) then do
im = mapGet(map.inlineName, pName)
if pos('l', opt) < 1 & symbol('m.im.0') \== 'VAR' then do
m.im.0 = m.im.lEnd - m.im.lBegin - 1
do ix=1 to m.im.0
m.im.ix = strip(sourceline(ix+m.im.lBegin), 't')
end
end
return im
end
name = '/'
do lx = m.map.inlineSearch to sourceline()
if \ abbrev(sourceline(lx), '$') then
iterate
li = sourceline(lx)
s1 = pos('/', li)+ 1
if s1 < 3 | s1 > 4 then
iterate
s2 = pos('/', li, s1)
if s2 <= s1 then
iterate
if s1 == 3 then do
if name \== substr(li, s1, s2-s1) then
iterate
im = 'MAP.INLINE.' || (m.map.inline.0+1)
call mapAdd map.inlineName, name, im
m.im.lBegin = lBeg
m.im.lEnd = lx
m.im.mark = mrk
if name == pName then do
m.map.inlineSearch = lx+1
return mapInline(pName)
end
name = '/'
end
else if \ mapHasKey(map.inlineName,
, substr(li, s1, s2-s1)) then do
lBeg = lx
mrk = substr(li, 2, s1-3)
name = substr(li, s1, s2-s1)
end
else do
name = '/'
end
end
if pos('r', opt) > 0 then
return ''
return err('no inline data /'pName'/ found')
endProcedure mapInline
/*--- create a new map ----------------------------------------------*/
mapNew: procedure expose m.
parse arg opt
m.map.0 = m.map.0 + 1
return mapReset('MAP.'m.map.0 , opt)
endProcedure mapNew
/*--- make an empty map, if opt <> '' maintain stem of keys
('K' in map.keys, '=' in a else in opt) --------------*/
mapReset: procedure expose m.
parse arg a, opt
if symbol('m.map.keys.a') == 'VAR' then
call mapClear a
if opt = '=' then
st = a
else if translate(opt) = 'K' then
st = 'MAP.KEYS.'a
else
st = opt
m.map.keys.a = st
if st \== '' then
m.st.0 = 0
return a
endProcedure
/*--- add a new key value pair to the map ----------------------------*/
mapAdd: procedure expose m.
parse arg a, ky, val
vv = mapValAdr(a, ky, 'a')
m.vv = val
return val
endProcedure mapAdd
/*--- change the value at a key or add key value ---------------------*/
mapPut: procedure expose m.
parse arg a, ky, val
vv = mapValAdr(a, ky, 'p')
m.vv = val
return val
endProcedure mapPut
/*--- return 1 if key ky exists in map a, 0 otherwise ----------------*/
mapHasKey: procedure expose m.
parse arg a, ky
return mapValAdr(a, ky) \== ''
endProcedure mapHasKey
/*--- return the value of key ky in map a if it exists,
else if called with a third argument return third argument
else issue an error ----------------------------------------*/
mapGet: procedure expose m.
parse arg a, ky
vv = mapValAdr(a, ky)
if vv \== '' then
return m.vv
else if arg() > 2 then
return arg(3)
else
return err('missing key in mapGet('a',' ky')')
endProcedure mapGet
/*--- return a stem of all keys --------------------------------------*/
mapKeys: procedure expose m.
parse arg a
if m.map.keys.a == '' then
call err 'mapKeys('a') with no keys'
return m.map.keys.a
endProcedure mapKeys
/*--- remove a key from the map, do nothing if it is missing ---------*/
mapRemove: procedure expose m.
parse arg a, ky
vv = mapValAdr(a, ky)
if vv == '' then
return ''
if m.map.keys.a \== '' then do
trace ?R /* not tested yet ???wkTest */
k = m.map.keys.a
mx = m.k.0
do i=1 to mx
if m.k.i == ky then do
m.k.i = m.k.mx
m.k.0 = mx - 1
return
end
end
end
val = m.vv
drop m.a.ky
return val
endProcedure mapRemove
/*--- remove all entries ---------------------------------------------*/
mapClear: procedure expose m.
parse arg a
st = mapKeys(a)
liLe = 243 - length(a)
do kx=1 to m.st.0
ky = m.st.kx
drop m.st.kx
if length(ky) <= liLe then do
drop m.a.ky
end
else do
adr = mapValAdr(a, ky)
if adr \== '' then do
ha = left(adr, lastPos('.', adr) - 3)
do i = 1 to m.ha.k.0
drop m.ha.k.i m.ha.v.i
end
drop m.ha.k.0
end
end
end
m.st.0 = 0
return a
endProcedure mapClear
/*--- return the value pointer for a key, '' if non existing
with fun = 'a' add a key, with 'p' put a key ------------*/
mapValAdr: procedure expose m.
parse arg a, ky, fun
if length(ky) + length(a) <= 243 then do
res = a'.'ky
if symbol('m.res') == 'VAR' then do
if fun == 'a' then
call err 'duplicate key' ky 'in map' a
return res
end
else if fun == '' then
return ''
end
else do
len = 243 - length(a)
q = len % 4
ha = a'.'left(ky, len - 2 * q) || substr(ky,
, (length(ky)-len) % 2 + 2 * q, q) || right(ky, q)
if symbol('M.ha.k.0') == 'VAR' then do
do i=1 to m.ha.k.0
if m.ha.k.i == ky then do
if fun == 'a' then
call err 'duplicate key' ky ,
'map' a 'hash' ha'.K.'i
return ha'.V.'i
end
end
end
else do
i = 1
end
if fun == '' then
return ''
if i > 9 then
call err 'overflow long key' y 'in map' a 'hash' ha'.K.'i
m.ha.k.0 = i
m.ha.k.i = ky
res = ha'.V.'i
end
if m.map.keys.a \== '' then
call mAdd m.map.Keys.a, ky
m.res = ''
return res
endProcedure mapValAdr
/* copy map end *******************************************************/
/* copy m begin ********************************************************
we use variables as follows
m. stem m: all global data and object data that must survive
a procedure call (m for memory in Memoria of B5000)
m.<mbr>.** to avoid conflicts: every rexx Module (copy) should
only allocate addresses m.<mbr>.** with <mbr> the name of
the rexx module
we pass parameters around (e.g. a=address, m=memory, st=stem)
and the called function may use m.a or m.a.subField etc.
gg*: local variable in subroutines without procedure
everything else: temporary data within procedure
every subroutine is declared as procedure expose m.
(also if no m. variable is used, because e.g. of error handling)
the few subroutines that cannot use procedure, should use only
variables starting with gg
***********************************************************************/
/*---make an area -----*/
mNewArea: procedure expose m.
parse arg nm, adr, newCd, freeCd
m.m.area.0 = m.m.area.0 + 1
a = 'M.AREA.'m.m.area.0
if adr == '=' then
adr = nm
else if adr == '' then
adr = 'M.'m.m.area.0
if symbol('m.m.n2a.adr') == 'VAR' then
call err 'adr' adr 'for area' nm 'already used'
m.m.n2a.adr = a
call mAlias adr, nm
m.m.p2a.adr = a
m.a.0 = 0
m.a.free.0 = 0
m.a.address = adr
m.a.newCode = newCd
m.a.freeCode = freeCd
return nm
endProcedure mNewArea
mAlias: procedure expose m.
parse arg oldNa, newNa
if symbol('m.m.n2a.oldNa') \== 'VAR' then
call err 'area' oldNa 'does not exist'
if oldNa == newNa then
return
if symbol('m.m.n2a.newNa') == 'VAR' then
call err 'newName' newNa 'for old' oldNa 'already used'
m.m.n2a.newNa = m.m.n2a.oldNa
return
endProcedure mAlias
mBasicNew: procedure expose m. ggArea
parse arg name
if symbol('m.m.n2a.name') \== 'VAR' then
call err 'area' name 'does not exists'
ggArea = m.m.n2a.name
if m.ggArea.free.0 > 0 then do
fx = m.ggArea.free.0
m.ggArea.free.0 = fx-1
m = m.ggArea.free.fx
end
else do
m.ggArea.0 = m.ggArea.0 + 1
m = m.ggArea.address'.'m.ggArea.0
end
return m
endProcedure mBasicNew
mNew: procedure expose m.
labelMNew:
parse arg name, arg, arg2, arg3
m = mBasicNew(name)
interpret m.ggArea.newCode
return m
endProcedure mNew
mReset: procedure expose m.
parse arg a, name
ggArea = m.m.n2a.name
m = a
interpret m.ggArea.newCode
return m
endProcedure mReset
mFree: procedure expose m.
parse arg m
p = 'M.P2A.'left(m, lastPos('.', m)-1)
area = m.p
if m.area.freeCode \== '' then
interpret m.area.freeCode
fx = m.area.free.0 + 1
m.area.free.0 = fx
m.area.free.fx = m
return
endProcedure mFree
/*--- iterate over all allocate elements of an area ------------------*/
mIterBegin: procedure expose m.
parse arg nm
a = m.m.n2a.nm
return m.a.address'.0'
endProcedure mIterBegin
mIter: procedure expose m.
parse arg cur
if cur == '' then
return ''
lx = lastPos('.', cur)
p = 'M.P2A.'left(cur, lx-1)
a = m.p
ix = substr(cur, lx+1)
do ix=ix+1 to m.a.0
n = m.a.address'.'ix
do fx=1 to m.a.free.0 while m.a.free \== n
end
if fx > m.a.free.0 then
return n
end
return ''
endProcedure mIter
/*--- get m.a --------------------------------------------------------*/
mGet: procedure expose m.
parse arg a
return m.a
endProcedure mGet
/*--- cut stem a to length len ---------------------------------------*/
mCut: procedure expose m.
parse arg a, len
m.a.0 = len
return a
endProcedure mCut
/*--- add one or several arguments to stem m.a -----------------------*/
mAdd: procedure expose m.
parse arg a
ix = m.a.0
do ax = 2 to arg()
ix = ix + 1
m.a.ix = arg(ax)
end
m.a.0 = ix
return a'.'ix
endProcedure mAdd
/*--- pop last element from stem m.a ---------------------------------*/
mPop: procedure expose m.
parse arg a
ix = m.a.0
if ix < 1 then
call err 'pop from empty stem' a
m.a.0 = ix-1
return m.a.ix
endProcedure mPop
/*--- add to m.dst.* a (sub)sequence of m.src.* ----------------------*/
mAddSt: procedure expose m.
parse arg dst, src, fx , tx
dx = m.dst.0
if fx == '' then
fx = 1
if tx == '' then
tx = m.src.0
do sx = fx to tx
dx = dx + 1
m.dst.dx = m.src.sx
end
m.dst.0 = dx
return
endProcedure mAddSt
/*--- find position of first occurrence of ele in stem m,
return 0 if nonemove a part of a stem -----------------------*/
mPos: procedure expose m.
parse arg m, ele, sx
if sx == '' then
sx = 1
do x=sx to m.m.0
if m.m.x = ele then
return x
end
return 0
endProcedure mPos
/*--- move a part of a stem ------------------------------------------*/
mMove: procedure expose m.
parse arg m, sx, dx
if dx < sx then do
y = dx
do x=sx to m.m.0
m.m.y = m.m.x
y = y + 1
end
end
else if dx > sx then do
y = m.m.0 + dx - sx
do x=m.m.0 by -1 to sx
m.m.y = m.m.x
y = y - 1
end
end
m.m.0 = m.m.0 + dx - sx
return
endProcedure mMove
/*--- insert a stem into another ------------------------------------*/
mInsert: procedure expose m.
parse arg m, tx, st
call mMove m, tx, tx+m.st.0
do sx=1 to m.st.0
dx = tx-1+sx
m.m.dx = m.st.sx
end
return
endProcedure mInsert
/*--- strip all elements of a stem -----------------------------------*/
mStrip: procedure expose m.
parse arg st, opt
if opt == '' then
opt = 'b'
do x=1 to m.st.0
m.st.x = strip(m.st.x, opt)
end
return st
endProcedure mStrip
/* cat the lines of a stem, possibly repeated --------------------------
args: stem, fmt see fGen: -------------------------------------*/
mCat: procedure expose m.
parse arg st, fmt
fmt = '%s%qn%s%qe%q^'fmt
if m.st.0 < 1 then
return ''
res = f(fmt, m.st.1)
do sx=2 to m.st.0
res = res || f(fmt'%Qn', m.st.sx)
end
return res || f(fmt'%Qe')
endProcedure mCat
mIni: procedure expose m.
if m.m.ini = 1 then
return
m.m.ini = 1
m.mDigits = '0123456789'
m.mAlfLC = 'abcdefghijklmnopqrstuvwxyz'
m.mAlfUC = translate(m.mAlfLC)
m.mAlfa = m.mAlfLC || m.mAlfUC
m.mAlfNum = m.mAlfa || m.mDigits
m.mAlfDot = m.mAlfNum || '.'
m.mBase64 = m.mAlfUC || m.mAlfLC || m.mDigits'+-'
m.mId = m.mAlfNum'_' /* avoid rexx allowed @ # $ ¬ . | ? */
m.mAlfRex1 = m.mAlfa'@#$?' /* charset problem with ¬| */
m.mAlfRexR = m.mAlfRex1'.0123456789'
m.mPrint = m.mAlfNum'+-*/=()¢!{}<> .:,;?|''"%&#@$£\_'
m.m.area.0 = 0
call mNewArea
return
endProcedure mIni
verifId: procedure expose m.
parse arg src, extra, sx
if sx == '' then
sx = 1
if pos(substr(src, sx, 1), m.mDigits) > 0 then
return sx
else
return verify(src, m.mId || extra, 'n', sx)
endProcedure verifId
/* copy m end *********************************************************/
/* copy err begin *** errorhandling, messages, help ****************/
errIni: procedure expose m.
if m.err.ini == 1 then
return
m.err.ini = 1
m.err.handler = ''
m.err.cleanup = ';'
m.err.opt = ''
return
endProcedure errIni
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err.opt, m.err.handler
if pos('I', translate(m.err.opt)) > 0 then
if errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
call adrIsp 'control errors return'
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
call errIni
drop err handler cleanup opt call return
if ggOpt == '' & m.err.handler \== '' then
interpret m.err.handler
call errSay ggTxt, 'e'
call errCleanup
if ggOpt == '' then
ggOpt = m.err.opt
ggOpt = translate(ggOpt)
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 then do
call errSay 'divide by zero to show stackHistory', 'e'
x = 1 / 0
end
call errSay 'exit(12)', 'e'
exit errSetRc(12)
endSubroutine err
/*--- return the Operating System we are running on: TSO or LINUX ---*/
errOS: procedure expose m.
parse source os .
return os
endProcedure errOS
/*--- set rc for ispf: -------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared variable zIspfRc
back as return code
----------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- error routine: user message cleanup exit -----------------------*/
errAddCleanup: procedure expose m.
parse arg code
call errIni
/* concatenate backwards, then it is executed also backwards */
m.err.cleanup = ';'code || m.err.cleanup
return
endProcedure errAddCleanup
errRmCleanup: procedure expose m.
parse arg code
call errIni
cx = pos(';'code';', m.err.cleanup)
if cx > 0 then
m.err.cleanup = left(m.err.cleanup, cx) ,
|| substr(m.err.cleanup, cx + length(code)+2)
return
endProcedure errRmCleanup
errCleanup: procedure expose m.
call errIni
errCleanup = m.err.cleanup
if errCleanup = ';' then
return
m.err.cleanup = ';'
say 'err cleanup begin' errCleanup
interpret errCleanup
say 'err cleanup end' errCleanup
return
endProcedure errCleanup
/*--- say an errorMessage msg with pref and linesplits --------------*/
errSay: procedure expose m.
parse arg msg, pref
return saySt(errMsg(msg, pref))
/*--- prefix an errormessage with pref,
split it into lines at \n to stem m.err -------------------*/
errMsg: procedure expose m.
parse arg msg, pref
parse source . . ggS3 . /* current rexx */
if pref == 'e' then
msg = 'fatal error in' ggS3':' msg
else if pref == 'w' then
msg = 'warning in' ggS3':' msg
else if pref \== '' then
msg = pref':' msg
return splitNl(err, msg) /* split lines at \n */
endProcedure errMsg
splitNL: procedure expose m.
parse arg st, msg
bx = 1
do lx=1 to 20
ex = pos('\n', msg, bx)
if ex < bx then
leave
m.st.lx = substr(msg, bx, ex-bx)
bx = ex+2
end
m.st.lx = substr(msg, bx)
m.st.0 = lx
return st
endProcedure splitNL
/*--- say (part of) the lines of a stem ----------------------------*/
saySt: procedure expose m.
parse arg st, fx, tx
do lx=word(fx 1, 1) to word(tx m.st.0, 1)
say m.st.lx
end
return st
endProcedure saySt
/*--- out (part of) the lines of a stem ----------------------------*/
outSt: procedure expose m.
parse arg st, fx, tx
do lx=word(fx 1, 1) to word(tx m.st.0, 1)
call out m.st.lx
end
return st
endProcedure outSt
/*--- say a trace message if m.trace is set --------------------------*/
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
say 'debug:' msg
return
endProcedure debug
/*--- output a trace if m.trace is set -------------------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
/*--- assert that the passed rexx expression evaluates to true -------*/
assert:
interpret 'assertRes =' arg(1)
if assertRes \==1 then
call err 'assert failed' arg(1) '==>' assertRes':' arg(2)
return
endProcedure assert
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg, op
call errSay msg, 'e'
call help
call err msg, op
endProcedure errHelp
/*--- display the first comment block of the source as help ----------*/
help: procedure expose m.
parse source . . s3 .
say right(' help for rexx' s3, 79, '*')
do ax=1 to arg()
say ' ' arg(ax)
end
do lx=1 by 1
if pos('/*', sourceLine(lx)) > 0 then
leave
else if lx > 10 then do
say 'initial commentblock not found for help'
return
end
end
do lx=lx+1 by 1
li = strip(sourceLine(lx), 't', ' ')
if pos('*/', li) > 0 then
leave
say li
end
say right(' end help for rexx' s3, 79, '*')
return 4
endProcedure help
/* copy err end *****************************************************/
/* copy ut begin *****************************************************/
/*--- if function warning all3 arguments get evaluated|
e.g if(x=0, 'infinity', 1/0) will fail| -----------*/
if: procedure expose m.
parse arg co, ifTrue, ifFalse
if co then
return ifTrue
else
return ifFalse
endProcedure if
/*--- embedded ASSignement:
assign the second argument to the variable with name in first arg
and return the value assigned ----------------------------------*/
ass:
call value arg(1), arg(2)
return arg(2)
/*--- embedded ASSignement only if NotNull:
assign the second argument to the variable with name in first arg
if the second arg is not null, return new value ---------------*/
assIf:
if arg(2) == '' then
return value(arg(1))
call value arg(1), arg(2)
return arg(2)
/*--- return first nonNull argument ---------------------------------*/
nn:
if arg(1) \== '' then
return arg(1)
if arg(2) \== '' then
return arg(2)
call err 'nn() both args empty'
/*--- embedded ASSignement return NotNull:
assign the second argument to the variable with name in first arg
and return 1 if value not null, 0 if null ----------------------*/
assNN:
call value arg(1), arg(2)
return arg(2) \== ''
/*--- return current time and cpu usage ------------------------------*/
timing: procedure expose m.
return return time() 'ela='time('E') 'cpu='sysvar('syscpu'),
'su='sysvar('syssrv')
timingTest: procedure expose m.
say 'begin' timing() sysvar('sysnode')
do 30000000
end
say 'end ' timing()
return
/*--- sleep several seconds ------------------------------------------*/
sleep: procedure expose m.
parse arg secs, sayIt
if sayit <> 0 then
say 'sleeping' secs 'secs' time()
CALL SYSCALLS 'ON'
ADDRESS SYSCALL "sleep" secs
CALL SYSCALLS 'OFF'
if sayit <> 0 then
say 'slept' secs 'secs' time()
return
endProcedure sleep
/*--- elongate inp with spaces up to given len -----------------------*/
elong: procedure expose m.
parse arg inp, len
if length(inp) >= len then
return inp
return left(inp, len)
endProcedure elong
/*--- quote string txt using quoteChar qu ("""" ==> ") ---------------*/
quote: procedure expose m.
parse arg txt, qu
if qu = '' then
qu = '"'
res = qu
ix = 1
do forever
qx = pos(qu, txt, ix)
if qx = 0 then
return res || substr(txt, ix) || qu
res = res || substr(txt, ix, qx-ix) || qu || qu
ix = qx + length(qu)
end
endProcedure quote
/*--- return the count of occurrences of needle in heyStack ----------*/
posCount: procedure expose m.
parse arg needle, hayStack, start, fin
if start = '' then
start = 1
if fin = '' then
fin = length(hayStack) + 1 - length(needle)
do cnt = 0 by 1
start = pos(needle, haystack, start)
if start < 1 | start > fin then
return cnt
start = start + length(needle)
end
endProcedure posCount
repAll: procedure expose m.
parse arg src, w, new
res = ''
cx = 1
do forever
nx = pos(w, src, cx)
if nx < 1 then
return res || substr(src, cx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAll
repAllWords: procedure expose m.
parse arg src, w, new
res = ''
wx = 0
cx = 1
do forever
wx = wordPos(w, src, wx+1)
if wx < 1 then
return res || substr(src, cx)
nx = wordindex(src, wx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAllWords
/* copy ut end ********************************************************/
}¢--- A540769.WK.REXX(PRIME) cre=2009-05-04 mod=2014-06-25-13.45.58 A540769 ----
parse arg st
numeric digits 15
do qx=1 to 20
m.q.qx = qx
end
do i=0 to 18
call permut q, i
say right(i,4) 'sqrt' right(sqrt(i), 2) ,
'isPrime' isPrime(i) 'nxPrime' right(nxPrime(i), 4) ,
'permut' m.q.0 '>' m.q.1 m.q.2 m.q.3 m.q.4 m.q.5
end
exit
say 2**32 2**31 2**30 2**20
if st = '' then
st = 2147483647
say 'starting from st' st
cnt = 0
q = 2
f = 2
sqrt: procedure expose m.
parse arg n
if n < 2 then
return n
k = 1
g = n
do while k+1 < g
m = (g + k) % 2
if m * m <= n then
k = m
else
g = m
end
return k
endProcedure sqrt
isPrime: procedure expose m.
parse arg n
if n < 2 then
return 0
if n // 2 = 0 then
return n = 2
do q=3 by 2 to sqrt(n)
if n // q = 0 then
return 0
end
return 1
endProcedure isPrime
nxPrime: procedure expose m.
parse arg n
do i = n + (\ (n // 2)) by 2
if isPrime(i) then
return i
end
endProcedure nxPrime
permut: procedure expose m.
parse arg m, p
m.m.1 = 1
do i=2 while p > 0
j = i - (p // i)
m.m.i = m.m.j
m.m.j = i
p = p % i
say 'i='i 'j='j 'p='p m.m.1 m.m.2 m.m.3 m.m.4
end
m.m.0 = i-1
return i-1
endProcedure permut
permu2: procedure expose m.
parse arg seq, p, i, f
if i == '' then
return permu2(seq, p, 2, 2)
if f > p then
return seq
s2 = permu2(seq, p, i+1, f * (i+1))
k = p // (f * (i+1)) % f
m.m.1 = 1
do i=2 while p > 0
j = i - (p // i)
m.m.i = m.m.j
m.m.j = i
p = p % i
say 'i='i 'j='j 'p='p m.m.1 m.m.2 m.m.3 m.m.4
end
m.m.0 = i-1
return i-1
endProcedure permut
do while (q+1)**2 <= st
if trunc(f*q) > q then
do while (f*q)**2 <= st
q = trunc(f*q)
end
else
do while (q+1)**2 <= st
q = q + 1
end
f = (f+1) / 2
end
say 'st='st 'q='q 'q**2='q**2 '(q+1)**2=' || (q+1)**2
do n=st + 1 - st//2 by -2 while cnt < 3
do d=3 by 2 to q while n // d \= 0
if d // 1000000 = 1 then
say d
end
if d > q then do
say 'prime' n
/* say n '1:'right(100000//N,5) '4:'right(400000//N, 5),
'8:'right(800000//N,5) '12:'right(1200000//N, 5) */
cnt = cnt + 1
end
end
}¢--- A540769.WK.REXX(PROTOTYP) cre=2012-08-24 mod=2012-08-24-10.57.29 A540769 ---
$#@
call sqlConnect dbaf
$;
$>.fEdit()
call sqlSel 'select name db from sysibm.sysDatabase' ,
"where name like 'DGDB%'" ,
"or name like 'DGO%'" ,
"or name like '%A1X%'"
$| $@¢
$=dx = 0
$@forWith db $@/db/
$=dx =- $dx+1
if $dx // 100 = 1 then $@=¢
//A540769W JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//*MAIN CLASS=LOG0
$!
$@=¢
//************ $dx db $DB
//STEP$dx EXEC PGM=PTLDRIVM,REGION=0M,
// PARM='EP=PTLHDDLB'
//STEPLIB DD DISP=SHR,DSN=DSN.CADB2.RZ1.P1.CDBALOAD
// DD DISP=SHR,DSN=DB2@.RZ1.P0.DSNLOAD
//PTILIB DD DISP=SHR,DSN=DSN.CADB2.RZ1.P1.CDBALOAD
// DD DISP=SHR,DSN=DB2@.RZ1.P0.DSNLOAD
//PTIPARM DD DISP=SHR,DSN=DSN.CADB2.RZ1.P1.CDBAPARM
//ACMBLKI DD DUMMY DSN=A540769.ACM.INPUT.D120823.T141828,
//HDDLOUT DD DISP=SHR,DSN=DSN.DBADM.PROTOTYP($DB)
//ERRORMSG DD SYSOUT=*
//SYSPRINT DD SYSOUT=*
//SYSOUT DD SYSOUT=*
//PARMFILE DD *
OBJTYPE DB
NAME $DB
SSID DBAF
SQLID S100447
LOCATION LOCAL
$!
$/db/
$!
$;
call sqlDisconnect dbaf
$#out 20120823 16:54:44
$#out 20120823 16:49:54
$#out 20120823 16:42:41
$#out 20120823 16:41:38
}¢--- A540769.WK.REXX(PROTSTFO) cre=2012-08-24 mod=2012-08-24-12.17.53 A540769 ---
$#@ $*( -sta force auf alle Prototypen in RECP or RBDP pending
Achtung: dies ist eine kriminelle Aktion
nur durchführen falls ......
$*)
$= dbsy = DBAF
call reoRefSt $dbsy '-1'
call sqlConnect $dbsy
call sqlSel 'select * from S100447.tDbState' ,
"where ( db like 'DGDB%'" ,
"or db like 'DGO%'" ,
"or db like '%A1X%')" ,
"and( sta like '%RBDP%' or sta like '%RECP%')"
$|
$@forWith sta $@¢
db = strip($DB)
sp = strip($SP)
if m.dbsp.db.sp = 1 then do
$** say 'already' db'.'sp
end
else do
say '-sta db('db') sp('sp') access(force) ***' $STA
m.dbSp.db.sp = 1
$** Kommentar in naechster Zeile entfernen
$** nur wenn ganz sicher ||||||
$**??? call sqlDsn st, $dbsy, '-sta db('db') sp('sp') access(force)'
if 0 then do /* output anzeigen */
do sx=1 to m.st.0
say '.' m.st.sx
end
end
$*) end
$!
call sqlDISConnect
$#out 20120824 12:12:15
}¢--- A540769.WK.REXX(Q) cre=2010-12-01 mod=2010-12-01-22.09.16 A540769 --------
/* copy adrTso begin *************************************************/
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet ---*/
adrTso:
parse arg ggTsoCmd, ggRet
address tso ggTsoCmd
if rc == 0 then return 0
else if ggRet == '*' then return rc
else if wordPos(rc, ggRet) > 0 then return rc
else
call err 'adrTso rc' rc 'for' ggTsoCmd
return /* end adrTso */
/*--- format dsn from tso format to jcl format -----------------------*/
dsn2jcl: procedure expose m.
parse upper arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
cx = pos('~', dsn)
if cx < 1 & addPrefix == 1 then
return sp'.'dsn
do while cx \== 0
le = left(dsn, cx-1)
ri = substr(dsn, cx+1)
if right(le, 1) == '.' | left(ri, 1) == '.' then
dsn = le || sp || ri
else
dsn = le || left('.', le \== '') || sp ,
|| left('.', ri \== '') || ri
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
parse arg dsn, mbr
bx = pos('(', dsn)
if bx > 0 then
dsn = strip(left(dsn, bx-1))
if mbr <> '' then
dsn = dsn'('strip(mbr)')'
return dsn
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn
lx = pos('(', dsn)
rx = pos(')', dsn, lx+1)
if lx < 1 then
return ''
else if lx < rx then
return substr(dsn, lx+1, rx-lx-1)
else
return strip(substr(dsn,lx+1))
endProcedure dsnGetMbr
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: readDDBegin, readDD*, readDDEnd
write: writeBegin, writeDD*, writeEnd
readDD returns true if data read, false at eof
***********************************************************************/
/*--- prepare reading from a DD --------------------------------------*/
readDDBegin: procedure expose m.
parse upper arg ggDD
call errAddCleanup 'call readDDEnd' ggDD', "*"'
return /* end readDDBegin */
/*--- read from DD ggDD into ggSt, return false at eof ---------------*/
readDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskr' ggDD '(stem' ggSt')', 2
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- finish reading DD ggDD ----------------------------------------*/
readDDEnd: procedure expose m.
parse upper arg ggDD, ggRet
call errRmCleanup 'call readDDEnd' ggDD', "*"'
return adrTso('execio 0 diskr' ggDD '(finis)', ggRet)
endProcedure readDDEnd
/*--- prepare writing to DD ggDD -------------------------------------*/
writeDDBegin: procedure expose m.
parse upper arg ggDD
/* ensure file is erased, if no records are written */
call adrTso 'execio' 0 'diskw' ggDD '(open)'
call errAddCleanup 'call writeDDEnd' ggDD', "*"'
return /* end writeDDBegin */
/*--- write to gg ggDD from stem ggSt, ggCnt records -----------------*/
writeDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt == '' then
ggCnt = value(ggst'0')
call adrTso 'execio' ggCnt 'diskw' ggDD '(stem' ggSt')'
return
endSubroutine writeDD
/*--- end writing to dd ggDD (close) --------------------------------*/
writeDDEnd: procedure expose m.
parse upper arg ggDD, ggRet
call errRmCleanup 'call writeDDEnd' ggDD', "*"'
return adrTso('execio 0 diskw' ggDD '(finis)', ggRet)
endProcedure writeDDEnd
/*--- standardise a dsn spec
word1 dsName or -
word2 dd or -
word3 disp or -
word4 to first : attributes in tso format
after first : attributes for new allocation
----------------------------------------------------------------------*/
dsnSpec: procedure expose m.
parse upper arg spec
rr = '' /* put leading - in separate words */
do sx=1 while words(rr) < 3 & wx \= ''
wx = word(spec, sx)
do while abbrev(wx, '-') & words(rr) < 3
wx = substr(wx, 2)
rr = rr '-'
end
rr = rr wx
end
spec = rr subWord(spec, sx)
na = ''
dd = ''
di = ''
if left(spec, 1) = '&' then /* external spec is handled ok */
spec = strip(substr(spec, 2))
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, '.') | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
di = w
else if w = 'CATALOG' then
di = di w
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
na = strip(substr(w, 5, length(w)-5))
else if na == '' then
na = dsn2jcl(w)
else if dd == '' then
dd = w
else if di == '' then
di = w
else
leave
end
if na == '' then
na = '-'
else if abbrev(na, "'") then
na = substr(na, 2, length(na)-2)
if dd == '' then dd = '-'
if di == '' then di = '-'
re = subword(spec, wx)
if abbrev(re, '.') then
re = substr(re, 2)
return na dd di re
endProcedure dsnSpec
/*--- alloc a dsn with dsnAlloc
if the dsn is inuse wait and retry
until either the allocation is successfull
or the timeout occurs --------------------------------------*/
dsnAllocWait: procedure expose m.
parse upper arg spec, pDi, pDD, timeOut
x = max(1, arg() - 1)
do rt=0
m.adrTsoAl.1 = ''
m.adrTsoAl.2 = ''
m.adrTsoAl.3 = ''
call outtrap m.adrTsoAl.
res = dsnAlloc(spec, pDi, pDD, '*')
call outtrap off
if \ abbrev(res, ' ') then
return res
msg = m.adrTsoAl.1'\n'm.adrTsoAl.2'\n'm.adrTsoAl.3
if rt > timeOut & timeOut \== '' then
return err('timeout allocating' spec time() '\n'msg)
if pos('DATA SET IS ALLOCATED TO ANOTHER', msg) < 1 then
return err('allocating' spec'\n'msg)
say time() 'sleep and retry alloc' spec
call sleep 1, 0
end
endProcedure dsnAllocWait
/*--- alloc a dsn or a dd
spec '-'<ddName>
datasetName? disposition? '.'? attributes? (':' newAtts)?
disp default disposition
dd default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc -----*/
dsnAlloc: procedure expose m.
parse upper arg spec, pDi, pDD, retRc
parse value dsnSpec(spec) with na dd di rest
if na = '-' then
m.dsnAlloc.dsn = ''
else
m.dsnAlloc.dsn = na
if na == '-' & dd \== '-' & di == '-' & rest = '' then
return dd
if dd == '-' & pDD \== '' then
dd = pDD
if dd == '-' then do
if symbol('m.adrTso.ddNum') = 'VAR' then
dd = m.adrTso.ddNum + 1
else
dd = 1
m.adrTso.ddNum = dd
dd = 'DD' || dd
end
if di = '-' & pDi \== '' then
di = pDi
if di = '-' then
di = 'SHR'
else if pos('(', na) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if pos('/', na) > 0 then
return csmAlloc(na dd di rest, retRc)
else
return tsoAlloc(na dd di rest, retRc)
endProcedure dsnAlloc
tsoAlloc: procedure expose m.
parse arg na dd disp rest ':' nn, retRc
c = 'alloc dd('dd')' disp
if na \== '-' then
c = c "DSN('"na"')"
call outtrap m.adrTsoAl.
alRc = adrTso(c rest, '*')
call outtrap off
if alRc = 0 then do
call errAddCleanup 'call tsoFree' dd', "*"'
return dd 'call tsoFree' dd';'
end
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& sysDsn("'"m.dsnAlloc.dsn"'") == 'DATASET NOT FOUND' then do
say 'tsoAlloc creating' c rest ':'nn
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na dd disp rest, retRc)
end
do ax=1 to m.adrTsoAl.0
say m.adrTsoal.ax
end
if retRc = '*' | wordPos(alRc, retRc) > 0 then
return ' ' alRc
call err 'tsoAlloc rc' alRc 'for' c rest
endProcedure tsoAlloc
tsoAtts: procedure expose m.
parse arg dsn
rc = listDsi("'"dsn"' SMSINFO")
if rc = 0 then
mv = ''
else if rc = 4 & sysReason = 19 then do
mv = 'UNITCNT(30)'
say 'multi volume' mv
end
else if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
al = 'CAT'
al = ''
if right(sysDsSms, 7) == 'LIBRARY' ,
| abbrev(sysDsSms, 'PDS') then
al = al 'DSNTYPE(LIBRARY)'
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
al = al "DSORG("sysDSorg") MGMTCLAS("sysMgmtClass")",
"DATACLAS("sysDataClass")" ,
"RECFM("translate('1 2 3', ' 'sysREcFM, ' 123')")",
"LRECL("SYSLRECL")",
"blksize("sysBLkSIZE")",
"SPACE("sysPrimary"," sysSeconds")" sysUnits mv
return al
endProcedure tsoAtts
tsoFree: procedure expose m.
parse arg dd, ggRet
call adrTso 'free dd('dd')', ggRet
call errRmCleanup 'call tsoFree' dd', "*"'
return
endProcedure tsoFree
dsnCreateAtts: procedure expose m.
parse arg dsn, atts, forCsm
forCsm = forCsm == 1
aU = ' 'translate(atts)
if abbrev(atts, ':') then do
parse var atts a1 atts
bl = 32760
rl = substr(a1, 3)
if abbrev(a1, ':F') then do
if rl = '' then
rl = 80
recfm='f b'
bl = bl - (bl // rl)
end
else do
if rl = '' then
rl = bl-4
recfm = substr(a1, 2, 1) 'b'
end
if forCsm then
atts = atts "recfm("space(recfm, 0)") lrecl("rl")",
"blkSize("bl")"
else
atts = atts "recfm("recfm") lrecl("rl") block("bl")"
end
if pos('(', dsn) > 0 & pos(' DSNTYPE(', aU) < 1 ,
& pos(' DSORG(', aU) < 1 then
atts = atts 'dsntype(library) dsorg(po)'
dsn = dsnSetMbr(dsn)
if pos(' MGMTCLAS(', aU) < 1 then
atts = atts 'mgmtclas(COM#A091)'
if pos(' SPACE(', aU) < 1 then
if forCsm then
atts = atts 'space(10, 1000) cylinder'
else
atts = atts 'space(10, 1000) cyl'
return "dataset('"dsn"')" atts
endProcedure dsnCreateAtts
/*--- read the dataset specified in ggDsnSpec to stem ggSt -----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
interpret subword(ggAlloc, 2)
return
endSubroutine readDsn
/*--- write the dataset specified in ggDsnSpec from stem ggSt
write ggCnt records if not empty otherwise ggst0
if ggSay 1 then say ... records written to ... -------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'open finis)'
interpret subword(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
copyDSN: procedure expose m.
parse arg frSpec, toSpec, ggSay
frDD = dsnAlloc(frSpec, 'SHR', 'FRDD')
toDD = dsnAlloc(toSpec, 'OLD', 'TODD')
call readDDBegin word(frDD, 1)
call writeDDBegin word(toDD, 1)
cnt = 0
do while readDD(word(frDD, 1), r.)
call writeDD word(toDD, 1), r.
cnt = cnt + r.0
end
call readDDEnd word(frDD, 1)
call writeDDEnd word(toDD, 1)
interpret ';' subword(frDD, 2) '; ; ;' subword(toDD, 2)
if ggSay == 1 | m.debug == 1 then
say cnt 'records copied from' frSpec 'to' to toSpec
return
endSubroutine writeDsn
/* copy adrTso end ****************************************************/
}¢--- A540769.WK.REXX(QCSBESXP) cre=2014-03-31 mod=2016-04-29-09.46.39 A540769 ---
$#@
$=distTst = 0 $** 1 distribute to oLib, 0 to dsn.besenWag...
$=oLib=- userid()'.tst.tecsv'
$=oLib= DSN.SOURCE.TECSV.GEN
$<>
$>. fEdit($-oLib'(##besenw) ::f', 'v')
$$ $'$#@'
$$ $'$** distribute qcsBesXP'
$** $@%¢oneJob rz1 dboc$!
$@%¢oneJob rzz de0g$!
$@%¢oneJob rzz devg$!
$@%¢oneJob rzz dpzg$!
$@%¢oneJob rr2 dbof$!
$@%¢oneJob rq2 dbof$!
$@%¢oneJob rz2 dbof$!
$@%¢oneJob rz4 dp4g$!
$*( history
19. 4.16 auch txc52* exclud't
27.10.15 mit term step und neuem mail
9. 3.15 neue Syntax, mit plexChar, lctl(QZT00*) entfernt ==> conSumGe
19.12.14 nur user explain tables excluden
3.12.14 mit RQ2
27.11.14 mit defineNo auf space statt spaceF
18.9.14 mit icType=R/Z --> fullCopy, AC04 excluded
$*)
$proc oneJob $@/oneJob/
parse upper arg , rz dbSys
$= rz =- rz
$= rzD =- iiRz2Dsn(rz)
$= dbSys =- dbSys
$= pd =- iiRz2P(rz)iiDbSys2C(dbSys)
$= job = qcsBe${pd}P
$= JOB =- translate($job)
$= hh =- if(dbSys='DBOF', 5, 3)
$= tst =- f('%t s')
$=partLim=- if(rz=='RR2' | rz='RQ2', 500, 999999)
$$ call dsnCopy '$oLib($job)' ,
if $distTst then
$$ $' ' , '$rz/$oLib($job)'
else
$$ $' ' , '$rz/dsn.besenWag.$dbSys(qcsBesXP)'
$<>
$>$oLib($job)
$@=/oneJob1/
//$JOB JOB (ADM27506,0241,,3628),'DB2 TECSV BESENWAGEN',
// MSGCLASS=E,CLASS=P2,TIME=1440,SCHENV=DB2ALL
//*********************************************************************
//* tecSV der DB2 Tabellen - Besenwagen $rz/$dbSys
//* version vom 19. 4.16 auch txc52* exclud't
//* generiert am $tst
//* durch rz4/dsn.source.tecsv(qcsBesXP)
//* ||| alle Aenderung dortDrin ||||||||||||
//* hh = $hh (Stunden zurück)
//* partLim = $partLim (maximale Part Copies pro Typ)
//************************************* generate copy statements *******
//GEN EXEC PGM=IKJEFT01,DYNAMNBR=200,TIME=99,
// PARM='WSH'
//SYSPROC DD DSN=DSN.DB2.EXEC,DISP=SHR
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTSPRT DD SYSOUT=*
//SYSTSIN DD DUMMY
//WSH DD *
$'$#@'
$'$= dbSys =' $dbSys
$'$= rz =' $rz
$'$= hh =' $hh
$'$= partLim =' $partLim
$/oneJob1/
$@#/oneJob2/
$=previewOnly=0
call sqlConnect $dbSys
$;
$<=/sql/
$/oneJob2/
$@=/oneJobSql/
$= vh = $'$hh'
with cx as
(
select dbName db, tsName ts, dsNum part, instance
, max(case when ICTYPE not IN ('I')
then char(timestamp) || icType || strip(dsNum)
else '' end) laFu
, max(char(timestamp) || icType || strip(dsNum)) laInc
, max(case when timestamp < current timestamp - $vh hours then ''
when icType in ('I', 'F') then 'new' || icType
else '' end) newCo
from sysibm.sysCopy
where ICTYPE not IN ('A', 'B', 'C', 'D', 'M', 'Q')
group by dbName, tsName, dsNum, instance
)
, ci(i) as
( select 1 from sysibm.sysDummy1
union all select 2 from sysibm.sysDummy1
)
, p as
(
SELECT PT.DBNAME, pt.tsName, pt.partition, ci.i, ts.clone, ts.instance,
pt.space ptSpace,
case when ts.instance = i then 'base' else 'clone' end baCl,
value(max(c1.laFu, c0.laFu) , c1.laFu, c0.laFu, '') laFu,
value(max(c1.laInc, c0.laInc), c1.laInc, c0.laInc, '') laInc,
value( c1.newCo, c0.newCo, '') newCo,
r.nActive,
updateStatstime ,
loadrLasttime ,
reorgLasttime ,
copyLasttime,
copyUpdatedPages,
copyChanges,
copyUpdateTime,
copyUpdateLRSN
FROM SYSIBM.SYSDATABASE DB
join SYSIBM.SYSTABLESPACE TS
on DB.NAME = PT.DBNAME
join SYSIBM.SYSTABLEPART PT
on DB.NAME = TS.DBNAME
AND TS.NAME = PT.TSNAME
join ci on ci.i=ts.instance or ts.clone = 'Y'
left join cx c1 on c1.db = pt.dbName and c1.ts = pt.tsName
and c1.part = pt.partition and c1.instance = ci.i
and c1.part <> 0
left join cx c0 on c0.db = pt.dbName and c0.ts = pt.tsName
and c0.part = 0 and c0.instance = ci.i
left join SYSIBM.SYSTABLESpaceStats r
on r.dbid = db.dbid
and r.psid = ts.psid
and r.partition = pt.partition
and r.instance = ci.i
WHERE 0 = 0
----- exludes ----------------------------------------------------------
AND NOT (PT.DBNAME like 'DSNDB%') -- DB2 CATALOG
AND NOT (PT.DBNAME LIKE 'DSN8%') -- IBM TEST DB
AND NOT (PT.DBNAME LIKE 'WKDBD%') -- DB2 WORK DATABASE
AND NOT (PT.DBNAME = 'DSNTESQ') -- DB2 CATALOG CLONE
AND NOT (PT.DBNAME LIKE 'DB2MAPP%') -- REORG MAPPING TABLES
AND NOT (pt.dbName LIKE 'DB2PLAN%' -- explain tables
and translate(left(pt.tsName, 7), '999999999AA', '012345678FG')
= 'A999999') -- user explain tables
and not translate(PT.dbName, '999999999AAAAAA', '012345678FISWXY')
= 'DA999999' -- user datenbanken
AND NOT (PT.DBNAME LIKE 'DB2ALA%') -- marec generated
AND NOT (PT.DBNAME LIKE '%MAREC%') -- marec generated
AND NOT (PT.DBNAME LIKE 'DACME%') -- Mail Heinz Bühler
AND NOT (PT.DBNAME LIKE 'DGDB%') -- PROTOTYPEN
AND NOT (PT.DBNAME LIKE 'DGO%') -- PROTOTYPEN
AND NOT (PT.DBNAME LIKE '%A1X%') -- Neue Prototypen
AND NOT (PT.DBNAME LIKE 'DAU%') -- Schulung Gerrit
AND NOT (PT.DBNAME LIKE 'IDT%') -- ibm tools
AND NOT (PT.DBNAME LIKE 'OE02%') -- Mail Ivo Eichmann
AND NOT (PT.DBNAME LIKE 'CSQ%' -- M-QUEUE DATENBANK
AND PT.TSNAME like 'TSBLOB%' )
$@¢
if wordPos($dbSys, 'DBOF DE0G') > 0 then $@=¢
and not
( (PT.dbName = 'XC01A1P' and PT.tsName <> 'A500A'
and (PT.tsName LIKE 'A2%'or PT.tsName LIKE 'A5%'))
-- EOS: Armin Breyer
or (PT.dbName = 'XR01A1P' AND PT.tsName LIKE 'A2%' )
) -- ERET: Armin Breyer
$! else if wordPos($dbSys, 'DVBP DEVG') > 0 then $@=¢
AND PT.DBNAME not like 'XB%' -- elar macht saves selbst
$! else if wordPos($dbSys, 'DBOC DP4G') > 0 then $@=¢
AND PT.DBNAME not in ('AC04A1P' -- ACF2 macht saves selbst
, 'DB2PDB','DB2PDB2', 'DB2PDB3') -- performance DB
AND NOT (PT.DBNAME like 'DSN%')
$!
if wordPos($rz, 'RZX RZY RZZ') > 0 then $@=¢
AND NOT (PT.DBNAME LIKE 'OE02%') -- Mail Ivo Eichmann
AND NOT (PT.DBNAME LIKE 'CSQ%') -- M-QUEUE DATENBANK
$!
$!
AND DB.TYPE NOT IN ('T','W')
AND TS.NTABLES <> 0
)
, q as
(
select case when ptSpace = -1 then 'no defineNo'
when laFu is null then 'full null'
when substr(laFu, 27, 1) <> 'F' then 'full icType'
when laFu < char(current timestamp $*+
- $'$-¢168+'$vh$'$!' hours)
then 'full week'
when copyLasttime is null then 'full rtsCo'
when copyLasttime < loadrLastTime then 'full rtsLo'
when copyLasttime < reorgLastTime then 'full rtsRe'
when copyUpdateTime <= current timestamp - $vh hours
and nActive * 0.1 <= COPYUPDATEDPAGES then 'full upda'
when substr(laInc, 27, 1) not in('F','I') then 'inc icType'
when copyUpdateTime > current timestamp - $vh hours
then 'no updTime'
when COPYUPDATEDPAGES <> 0 then 'inc updPag'
when copyChanges <> 0 then 'inc updCha'
when copyUpdateTime is not null then 'inc updTim'
when copyUpdateLRSN is not null then 'inc updLrs'
else 'no changes'
end copy,
p.*
from p
)
select *
from q
where left(copy, 2) <> 'no'
ORDER BY DBNAME, TSNAME, PARTITION, i
WITH UR
$/oneJobSql/
$@#/oneJob3/
$/sql/
call sqlSel
m.sum.NBF = 0 0 0
m.sum.NBI = 0 0 0
m.sum.YBF = 0 0 0
m.sum.YBI = 0 0 0
m.sum.YCF = 0 0 0
m.sum.YCI = 0 0 0
m.NBF.0 = 0
m.NBI.0 = 0
m.YBF.0 = 0
m.YBI.0 = 0
m.YCF.0 = 0
m.YCI.0 = 0
cAll = 0
$| $@forWith c $@¢
cAll = cAll + 1
kk = translate($CLONE || left($BACL, 1) || left($COPY, 1))
say left($COPY $NEWCO, 15) left($DBNAME, 8) left($TSNAME, 8) ,
right($PARTITION, 5) 'clone' $CLONE $BACL right($INSTANCE, 2) ,
'rtsUpdT' $UPDATESTATSTIME
say ' fu' left($LAFU, 32) 'inc' left($LAINC, 32) kk
say ' rts chag' strip($COPYCHANGES),
'upPg' strip($COPYUPDATEDPAGES),
'acPg' strip($NACTIVE),
'coUp' $COPYUPDATETIME,
'coLa' $COPYLASTTIME
if datatype($NACTIVE, 'n') then
nn = word(m.sum.kk, 1) + $NACTIVE
else
nn = word(m.sum.kk, 1)
if datatype($COPYUPDATEDPAGES, 'n') then
nn = nn (word(m.sum.kk, 2) + $COPYUPDATEDPAGES)
else
nn = nn word(m.sum.kk, 2)
m.sum.kk = nn
if wordPos(strip(kk),'NBF NBI YBF YBI YCF YCI') < 1 then
call err 'not supported kk='kk
if m.kk.0 <= $partLim then
call mAdd kk,
, ' INCLUDE TABLESPACE' strip($DBNAME)'.'strip($TSNAME),
'PARTLEVEL' if($PARTITION <> 0, $PARTITION)
$!
$<>
$>DSN.BESENWAG.$dbSys(GENINC)
$@%¢makeList - NBI, FULL NO, 'not cloned', YBI, 'cloned base'$!
$<>
$>DSN.BESENWAG.$dbSys(GENFUL)
$@%¢makeList - NBF, FULL YES, 'not cloned',YBF, 'cloned base'$!
$<>
$>DSN.BESENWAG.$dbSys(GENCLINC)
$@%¢makeList - YCI, FULL NO CLONE, 'cloned clone'$!
$<>
$>DSN.BESENWAG.$dbSys(GENCLFUL)
$@%¢makeList - YCF, FULL YES CLONE, 'cloned clone'$!
$<>
$@proc makeList $@/makeList/
parse arg ,lst, full, tit, l2, t2
tfu = if(substr(lst, 3, 1)=='I', 'incremental', 'full')
$$- '--' sysvar('sysnode') $dbSys date('s') time()
$$- '--' left(tit tfu, 30) 'copy: ' m.lst.0 'parts'
say left(tit tfu, 30) right(m.lst.0, 10) right(word(m.sum.lst, 1), 14),
right(word(m.sum.lst, 2), 14)
if m.lst.0 > 0 | m.l2.0 > 0 then $@¢
if $previewOnly then
$$ OPTIONS(PREVIEW)
else
$$ OPTIONS EVENT(ITEMERROR,SKIP)
$$- ' LISTDEF LST'lst
$!
$@do ix=1 to m.lst.0 $$- m.lst.ix
if l2 \== '' then $@¢
say left(t2 tfu, 30) right(m.l2.0, 10) right(word(m.sum.l2, 1), 14),
right(word(m.sum.l2, 2), 14)
$$- '--' left(t2 tfu, 30) 'copy: ' m.l2.0 'parts'
$@do ix=1 to m.l2.0 $$- m.l2.ix
$!
if m.lst.0 > 0 | m.l2.0 > 0 then $@=¢
COPY LIST LST$-¢lst$! COPYDDN(TCOPYD)
PARALLEL
$-¢full$!
SHRLEVEL CHANGE
$!
$/makeList/
$/oneJob3/
$@=/oneJob4/
//************************************* copy ***************************
// IF GEN.RUN AND GEN.RC < 8 THEN
// IF (ABEND OR NOT ABEND) THEN
//COPYINC EXEC PGM=DSNUTILB,REGION=0000M,COND=(8,LT),
// DYNAMNBR=99,PARM=($dbSys,'$JOB.COPY')
//SYSPRINT DD SYSOUT=*
//SYSOUT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSTEMPL DD DISP=SHR,DSN=$dbSys.DBAA.LISTDEF(TEMPL)
//SYSIN DD DISP=SHR,DSN=DSN.BESENWAG.$dbSys(GENINC)
// ENDIF
//************************************* copy ***************************
// IF (ABEND OR NOT ABEND) THEN
//COPYFUL EXEC PGM=DSNUTILB,REGION=0000M,COND=(8,LT),
// DYNAMNBR=99,PARM=($dbSys,'$JOB.COPY')
//SYSPRINT DD SYSOUT=*
//SYSOUT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSTEMPL DD DISP=SHR,DSN=$dbSys.DBAA.LISTDEF(TEMPL)
//SYSIN DD DISP=SHR,DSN=DSN.BESENWAG.$dbSys(GENFUL)
// ENDIF
//************************************* copy ***************************
// IF (ABEND OR NOT ABEND) THEN
//COPYCLIN EXEC PGM=DSNUTILB,REGION=0000M,COND=(8,LT),
// DYNAMNBR=99,PARM=($dbSys,'$JOB.COPY')
//SYSPRINT DD SYSOUT=*
//SYSOUT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSTEMPL DD DISP=SHR,DSN=$dbSys.DBAA.LISTDEF(TEMPL)
//SYSIN DD DISP=SHR,DSN=DSN.BESENWAG.$dbSys(GENCLINC)
// ENDIF
//************************************* copy ***************************
// IF (ABEND OR NOT ABEND) THEN
//COPYCLFU EXEC PGM=DSNUTILB,REGION=0000M,COND=(8,LT),
// DYNAMNBR=99,PARM=($dbSys,'$JOB.COPY')
//SYSPRINT DD SYSOUT=*
//SYSOUT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSTEMPL DD DISP=SHR,DSN=$dbSys.DBAA.LISTDEF(TEMPL)
//SYSIN DD DISP=SHR,DSN=DSN.BESENWAG.$dbSys(GENCLFUL)
// ENDIF
// ENDIF
//*
// IF (ABEND OR RC GT 7 OR RC LT 0) THEN
//************************************* term utility if error **********
//TERM EXEC PGM=IKJEFT1A,REGION=0000M
//SYSTSPRT DD SYSOUT=*
//SYSTSIN DD *
DSN SYSTEM($dbSys)
-TERM UTILITY('$JOB.COPY')
END
//************************************* send mail if error *************
//EMAIL EXEC PGM=OS3560
//STEPLIB DD DSN=PCL.U0000.P0.${rzD}AKT.PERM.@008.LLB,DISP=SHR
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//MAILIN DD *
sender=db-administration.db2@credit-suisse.com
to=db-administration.db2@credit-suisse.com
subject=$rz/$dbSys Besenwagen: ABEND in $job
testInfo=Y
info=Y
send=Y
text=ABEND or bad rc in Besenwagen
text= rz = $rz
text= dbSys = $dbSys
text= job = $job
// ENDIF
//*
//************************************* create member to mark finish ***
// IF (ABEND OR NOT ABEND) THEN
//FINISH EXEC PGM=IEBGENER
//SYSPRINT DD SYSOUT=*
//SYSUT1 DD *
job $job finished $rz/$dbSys
//SYSUT2 DD DISP=SHR,DSN=DSN.BESENWAG.$dbSys(FINISH)
// ENDIF
$/oneJob4/
$/oneJob/
$#out 20160419 13:20:13
}¢--- A540769.WK.REXX(QUERYDEL) cre=2010-04-06 mod=2010-04-07-12.05.34 A540769 ---
/* rexx ****************************************************************
delete old rows from dsn_query_table
with commits for each queryNo
--- history ------------------------------------------------------------
6. 4.10 w.keller neud
***********************************************************************/
call jIni
call errReset 'hI'
call sqlConnect DBTF
tb = 'CMNBATCH.DSN_QUERY_TABLE_REORG'
qFirst = -999000
qNo = qFirst
del = 0
do forever
c = sqlPreAllCl(1, 'select queryno from' tb ,
'where queryNo >' qNo ,
'order by queryNo fetch first row only',
, st, ':qNo')
if c \== 1 then
leave
call sqlExec 'delete from' tb ,
'where queryNo =' qNo,
'and explain_time < current timestamp - 1 month',
, 100
call sqlCommit
del = del + sqlErrd.3
say 'qNo' qNo 'deleted' sqlErrd.3 'total' del
end
call sqlDisconnect
say 'qNo' qFirst '-' qNo 'deleted' del
exit
/*--- main code wsh --------------------------------------------------*/
call errReset 'hI'
parse arg spec
os = errOS()
if spec = '' & os == 'TSO' then do /* z/OS edit macro */
parse value wshEditMacro() with done spec
if done then
return
end
spec = wshFun(spec)
if spec == '$' then
return
call wshIni
inp = ''
out = ''
if os == 'TSO' then do
if sysvar('sysEnv') = 'FORE' then do
end
else do
inp = '-wsh'
useOut = listDsi('OUT FILE')
if \ (useOut = 16 & sysReason = 2) then
out = '-out'
end
end
else if os == 'LINUX' then do
inp = '&in'
out = '&out'
end
else
call err 'implemnt wsh for os' os
call compRun spec, inp, out
exit 0
wshFun: procedure expose m.
parse arg fun rest
call scanIni
f1 = translate(fun)
sx = verify(f1, m.scan.alfNum)
if sx = 2 | sx = 1 then do
f1 = left(f1, 1)
rest = substr(fun, 2) rest
end
if f1 = 'T' then
call wshTst rest
else if f1 = 'I' then
call wshInter rest
else if f1 = '?' then
return 'call pipePreSuf' rest '$<$#='
else
return arg(1)
return '$'
endProcedure wshFun
tstSqlO1: procedure expose m.
call sqlOIni
call sqlConnect dbaf
sq = sqlSel("select strip(name) from sysibm.sysTables",
"where creator='SYSIBM' and name like 'SYSTABL%'",
"order by 1")
do 2
call jOpen sq, m.j.cRead
do while jRead(sq, abc)
call outO abc
end
call jClose sq
end
call sqlDisconnect
return 0
endProcedure tstSqlO1
/*--- actual test case ----------------------------------------------*/
wshIni: procedure expose m.
call compIni
call sqlOIni
return
endProcedure wshIni
wshTst: procedure expose m.
parse arg rest
if rest = '' then do /* default */
call tstSqlO1
return 0
end
c = ''
do wx=1 to words(rest)
c = c 'call tst'word(rest, wx)';'
end
if wx > 2 then
c = c 'call tstTotal;'
say 'wsh interpreting' c
interpret c
return 0
endProcedure wshTst
/*--- compRun: compile shell or data from inp and
run it to output out -----------------------------------*/
compRun: procedure expose m.
parse arg spec, inp, out
return compRunO(spec, s2oNull(inp), s2oNull(out))
endProcedure compRun
compRunO: procedure expose m.
parse arg spec, inO, ouO
cmp = comp(o2File(inO))
r = compile(cmp, spec)
if ouO \== '' then
call pipeBeLa '>' ouO
call oRun r
if ouO \== '' then
call pipeEnd
return 0
endProcedure compRun
/*--- interpret user input: rexx, expr, data or shell ---------------*/
wshInter: procedure expose m.
parse arg inp
call wshIni
inp = strip(inp)
mode = '*'
do forever
if pos(left(inp, 1), '|:*@.-=') > 0 then
parse var inp mode 2 inp
if mode == '|' then
return
if inp <> '' then do
say 'as' mode 'interpreting' inp
if mode = ':' then
interpret inp
else if mode = '*' then
interpret 'say' inp
else do
call errReset 'h', 'say "******* intercepting error";',
'call errSay ggTxt; return "";'
call oRun compile(comp(jBuf(inp)),
, translate(mode, 'ds', 'DS'))
call errReset 'h'
end
end
say 'enter' mode 'expression, | for end, : or * for Rexx' ,
'@ . - = for wsh'
parse pull inp
end
endProcedure wshInter
/*--- batch under tso: input dd(WSH), output dd(OUT) if allocated ---*/
wshBatchTSO: procedure expose m.
parse upper arg ty
useOut = listDsi('OUT FILE')
if \ (useOut = 16 & sysReason = 2) then
out = '-out'
else
out = ''
call wshBatch ty, '-wsh', out
return 0
endProcedure wshBatchTso
/*--- if we are called
not as editmacro return 0
as an editmacro with arguments: return 0 arguments
without arguments: run editMacro interface ------------------*/
wshEditMacro: procedure expose m.
if sysvar('sysISPF') \= 'ACTIVE' then
return 0
if adrEdit('macro (mArgs) NOPROCESS', '*') \== 0 then
return 0
spec = wshFun(mArgs)
if spec == '$' then
return 1
if spec == '' & dsnSetMbr(d, m) = 'A540769.WK.REXX(WSH)' then do
call tstAct
return 0
end
call wshIni
o = jOpen(jBuf(), '>')
call adrEdit '(d) = dataset'
call adrEdit '(m) = member'
pc = adrEdit("process dest range Q", 0 4 8 12 16)
if pc = 16 then
call err 'bad range must be q'
if pc = 0 | pc = 8 then do
call adrEdit "(rFi) = lineNum .zFrange"
call adrEdit "(rLa) = lineNum .zLrange"
say 'range' rFi '-' rLa
end
else do
rFi = ''
say 'no range'
end
if pc = 0 | pc = 4 then do
call adrEdit "(dst) = lineNum .zDest"
say 'dest' dst
end
else do
dst = ''
say 'no dest'
if adrEdit("find first '$#out' 1", 4) = 0 then do
call adrEdit "(dst) = cursor"
call adrEdit "(li) = line" dst
call jWrite o, left(li, 50) date('s') time()
end
end
if rFi == '' then do
call adrEdit "(zLa) = lineNum .zl"
if adrEdit("find first '$#' 1", 4) = 0 then do
call adrEdit "(rFi) = cursor"
call adrEdit "(li) = line" rFi
if abbrev(li, '$#out') | abbrev(li, '$#end') then
rFi = 1
if rFi < dst & dst \== '' then
rLa = dst-1
else
rLa = zLa
end
else do
rFi = 1
rLa = zLa
end
end
/* say 'range' c1 'rc' pc':' rFi '-' rLa 'after' dst */
i = jOpen(jBuf(), m.j.cWri)
do lx=rFi to rLa
call adrEdit "(li) = line" lx
call jWrite i, li
end
cmp = comp(jClose(i))
call errReset 'h',
, 'return wshEditCompErrH(ggTxt, ' rFi',' rLa')'
r = compile(cmp, spec)
call errReset 'h',
, 'return wshEditRunErrH(ggTxt, ' quote(o)',' dst')'
call pipeBegin
call oRun r
call pipeLast '>' o
do while inO(obj)
call objOut(obj)
end
call pipeEnd
lab = wshEditInsLinSt(dst, 0, , o'.BUF')
if dst \= '' then
call wshEditLocate max(1, dst-7)
return 1
endProcedure wshEditMacro
wshEditLocate: procedure
parse arg ln
call adrEdit '(la) = linenum .zl'
if la < 40 then
return
if ln < 7 then
ln = 1
else
ln = min(ln, la - 40)
call adrEdit 'locate ' ln
return
endProcedure wshEditLocate
wshEditCompErrH: procedure expose m.
parse arg ggTxt, rFi, rLa
call errReset 'h'
call outPush mCut(ggStem, 0)
call errSay 'compErr' ggTxt
call outPop
do sx=1 to m.ggStem.0
call out m.ggStem.sx
end
parse var m.ggStem.3 "pos " pos . " in line " lin":"
if pos = '' then do
parse var m.ggStem.3 " line " lin":"
pos = 0
end
lab = rFi + lin
if pos \= '' then
lab = wshEditInsLin(lab, 'msgline', right('*',pos))
lab = wshEditInsLinSt((rFi+lin),0, 'msgline', ggStem)
call wshEditLocate rFi+lin-25
exit 0
endSubroutine wshEditCompErrH
wshEditRunErrH: procedure expose m.
parse arg ggTxt, so, dst
call errReset 'h'
call errSay ggTxt, '*** run error'
lab = wshEditInsLinSt(dst, 1, , so'.BUF')
call outPush mCut(ggStem, 0)
call errSay ggTxt, '*** run error'
call wshEditInsLinSt dst, 1, msgline, ggStem
exit 0
endSubroutine wshEditRunErrH
wshEditInsLinCmd: procedure
parse arg wh
if dataType(wh, 'n') then do
if adrEdit("label" wh "= .a", 0 8 12) \= 12 then
return 'line_before .a ='
else
return 'line_after .zl ='
end
else if left(wh, 1) == '.' then
return 'line_before' wh '='
else
return wh
endProcedure wshEditInsLinCmd
wshEditInsLin: procedure
parse arg wh, type
cmd = wshEditInsLinCmd(wh)
do ax=3 to arg()
li = strip(arg(ax), 't')
if li == '' then
iterate
if translate(type) = 'MSGLINE' then do while length(li) > 72
sx = lastPos(' ', li, 72)
if sx < 10 then
sx = 72
one = left(li, sx)
li = ' 'strip(substr(li, sx))
call adrEdit cmd type "(one)"
end
call adrEdit cmd type "(li)", 0 4
end
return cmd
endProcedure wshEditInsLin
wshEditInsLinSt: procedure expose m.
parse arg wh, pl, type, st
if wh == '' then do
do ox=1 to m.st.0
say m.st.ox
end
return ''
end
wh = wh + pl
cmd = wshEditInsLinCmd(wh)
do ax=1 to m.st.0
call wshEditInsLin cmd, type, m.st.ax
end
return cmd
endProcedure wshEditInsLinSt
/*** end wsh, begin all copies ****************************************/
/* copy tstAll begin *************************************************/
tstAll: procedure expose m.
call tstBase
call tstComp
call tstDiv
call tstZos
return 0
endProcedure tstAll
/* copx tstZos begin **************************************************/
tstZOs:
call sqlIni
call tstSql /* wkTst??? noch einbauen|||
call tstSqlO
call tstSqlEnv */
call tstTotal
return
endProcedure tstZOs
tstWshBatch:
call adrTso 'alloc dd(WSH) shr dsn(WK.TEXT(WSHBATCH))'
call wshBatch
return adrTso('free dd(WSH)')
tstLmdTiming:
parse arg lev
say timing() lev
call lmdBegin abc, lev
c = 0
do while lmdNext(abc, st.)
c = c + st.0
end
call lmdEnd abc
say timing() lev 'with group - without reading' c
call adrIsp 'lmdinit listid(lmdId) level('lev')'
do c=0 while adrIsp('lmdlist listid(&lmdId) dataset(abc)', 8) = 0
end
call adrIsp 'lmdfree listid(&lmdId)'
say timing() lev 'with list' c
return
endProcedure lmdTiming
tstCsi: procedure expose m.
if 0 then do
call lmd 'A540769.*K'
call tstCsiCla 'A540769.WK.REXX'
call tstCsiCla 'A540769.AAA.DATASETS'
call tstCsiCla 'A540769.RRR.DATASETS'
end
if 0 then do
call tstCsiOpNx 'A540769.WK.*E*'
call tstCsiOpNx 'A540769.AAA.DATASETS'
call tstCsiOpNx 'A540769.RRR.DATASETS'
end
if 1 then do
call tstCsiNxCl 'A540769.WK.**'
call tstCsiNxCl 'DBTF.M*.**'
call tstCsiNxCl 'DBTF.BE*.**'
end
return
tstCsi: procedure expose m.
/* call lmd 'A540769.*K' */
call tstCsi1 'A540769.WK.REXX'
call tstCsi1 'A540769.AAA.DATASETS'
call tstCsi1 'A540769.RRR.DATASETS'
return
tstCsiCla:
parse arg ds
say ds '-->' csiCla(ds)
return
tstCsiOpNx: procedure expose m.
parse arg ds
m = 'NUE123'
s = 'res89'
flds = 'devtyp volser mgmtclas comudsiz NOBYTTRK UDATASIZ HARBA'
say 'csiOpen' ds
call csiOpen m, ds, flds
do while csiNext(m, s)
say m.s 'dev' c2x(m.s.devTyp) ,
'vol' m.s.volSer 'cla' m.s.mgmtclas,
'comuDsiz' m.s.comuDsiz 'noBytTrk' m.s.noBytTrk,
'udatasiz' c2x(m.s.udatasiz) ,
'harba' c2x(m.s.harba)
end
return
tstCsiNxCl: procedure expose m.
parse arg ds
m = 'ABC123'
s = 'efg89'
flds = 'devtyp volser mgmtclas'
say 'csiOpen' ds
call csiOpen m, ds, flds
say timing() 'begin'
do i=1 while csiNext(m, s)
nn = csiArcTape(m.s.volser, m.s.mgmtClas, m.s.devtyp, m.s)
/* oo = csiCla(strip(m.s))
if oo <> nn then
say nn '<>' oo m.s
*/ if i // 1000 = 0 then
say timing() i nn m.s
end
say timing() (i-1) nn m.s
return
endProcedure tstCsiNxCl
listCatClass: procedure expose m.
parse upper arg dsn
call outtrap x., '*'
call adrTso "listcat volume entry('"dsn"')", 4
rt = rc
call outtrap off
/* say 'listct rc =' rt 'lines' x.0 */
cl = ''
vo = ''
if word(x.1, 3) \== dsn then
call out 'err ??? for dsn' dsn 'bad first line' x.1
else if pos('NOT FOUND', x.1) > 0 then
return 'notFound'
else if word(x.1, 1)\== 'NONVSAM' then
call out 'err ??? for dsn' dsn 'bad first line' x.1
do x=2 to x.0 while vo = '' & left(x.x, 1) = ' '
/* say x.x */
p = pos('MANAGEMENTCLASS-', x.x)
if p > 0 then
vo = strip(word(substr(x.x, p+16), 1), 'l', '-')
p = pos('VOLSER--', x.x)
if p > 0 then
vo = strip(word(substr(x.x, p+6), 1), 'l', '-')
p = pos('DEVCLASS--', x.x)
dt = strip(word(substr(x.x, p+8), 1), 'l', '-')
end
/* say 'lc' cl 'vo' vo 'dt' dt 'dsn' dsn */
if vo = '' then
call out '??? err no volume for dsn' dsn
else if vo = 'ARCIVE' then
res = 'arcive'
else if cl = '' then
res = 'tape'
else
res = cl
if abbrev(res, 'ar') \= abbrev(dt, "X'0") ,
| abbrev(res, 'ta') \= abbrev(dt, "X'7") ,
| (left(res, 1) >= 'A') \= abbrev(dt, "X'3") then
call out 'err ??? mismatch cl' cl 'vo' vo 'dt' dt 'dsn' dsn
return res
endProcedure listCatClass
/* copx tstZos end **************************************************/
/* copx tstZos begin **************************************************/
tstZOs:
call sqlIni
call tstSql
call tstSqlO
call tstSqlEnv
call tstTotal
return
endProcedure tstZOs
tstWshBatch:
call adrTso 'alloc dd(WSH) shr dsn(WK.TEXT(WSHBATCH))'
call wshBatch
return adrTso('free dd(WSH)')
tstLmdTiming:
parse arg lev
say timing() lev
call lmdBegin abc, lev
c = 0
do while lmdNext(abc, st.)
c = c + st.0
end
call lmdEnd abc
say timing() lev 'with group - without reading' c
call adrIsp 'lmdinit listid(lmdId) level('lev')'
do c=0 while adrIsp('lmdlist listid(&lmdId) dataset(abc)', 8) = 0
end
call adrIsp 'lmdfree listid(&lmdId)'
say timing() lev 'with list' c
return
endProcedure lmdTiming
tstCsi: procedure expose m.
if 0 then do
call lmd 'A540769.*K'
call tstCsiCla 'A540769.WK.REXX'
call tstCsiCla 'A540769.AAA.DATASETS'
call tstCsiCla 'A540769.RRR.DATASETS'
end
if 0 then do
call tstCsiOpNx 'A540769.WK.*E*'
call tstCsiOpNx 'A540769.AAA.DATASETS'
call tstCsiOpNx 'A540769.RRR.DATASETS'
end
if 1 then do
call tstCsiNxCl 'A540769.WK.**'
call tstCsiNxCl 'DBTF.M*.**'
call tstCsiNxCl 'DBTF.BE*.**'
end
return
tstCsi: procedure expose m.
/* call lmd 'A540769.*K' */
call tstCsi1 'A540769.WK.REXX'
call tstCsi1 'A540769.AAA.DATASETS'
call tstCsi1 'A540769.RRR.DATASETS'
return
tstCsiCla:
parse arg ds
say ds '-->' csiCla(ds)
return
tstCsiOpNx: procedure expose m.
parse arg ds
m = 'NUE123'
s = 'res89'
flds = 'devtyp volser mgmtclas comudsiz NOBYTTRK UDATASIZ HARBA'
say 'csiOpen' ds
call csiOpen m, ds, flds
do while csiNext(m, s)
say m.s 'dev' c2x(m.s.devTyp) ,
'vol' m.s.volSer 'cla' m.s.mgmtclas,
'comuDsiz' m.s.comuDsiz 'noBytTrk' m.s.noBytTrk,
'udatasiz' c2x(m.s.udatasiz) ,
'harba' c2x(m.s.harba)
end
return
tstCsiNxCl: procedure expose m.
parse arg ds
m = 'ABC123'
s = 'efg89'
flds = 'devtyp volser mgmtclas'
say 'csiOpen' ds
call csiOpen m, ds, flds
say timing() 'begin'
do i=1 while csiNext(m, s)
nn = csiArcTape(m.s.volser, m.s.mgmtClas, m.s.devtyp, m.s)
/* oo = csiCla(strip(m.s))
if oo <> nn then
say nn '<>' oo m.s
*/ if i // 1000 = 0 then
say timing() i nn m.s
end
say timing() (i-1) nn m.s
return
endProcedure tstCsiNxCl
listCatClass: procedure expose m.
parse upper arg dsn
call outtrap x., '*'
call adrTso "listcat volume entry('"dsn"')", 4
rt = rc
call outtrap off
/* say 'listct rc =' rt 'lines' x.0 */
cl = ''
vo = ''
if word(x.1, 3) \== dsn then
call out 'err ??? for dsn' dsn 'bad first line' x.1
else if pos('NOT FOUND', x.1) > 0 then
return 'notFound'
else if word(x.1, 1)\== 'NONVSAM' then
call out 'err ??? for dsn' dsn 'bad first line' x.1
do x=2 to x.0 while vo = '' & left(x.x, 1) = ' '
/* say x.x */
p = pos('MANAGEMENTCLASS-', x.x)
if p > 0 then
vo = strip(word(substr(x.x, p+16), 1), 'l', '-')
p = pos('VOLSER--', x.x)
if p > 0 then
vo = strip(word(substr(x.x, p+6), 1), 'l', '-')
p = pos('DEVCLASS--', x.x)
dt = strip(word(substr(x.x, p+8), 1), 'l', '-')
end
/* say 'lc' cl 'vo' vo 'dt' dt 'dsn' dsn */
if vo = '' then
call out '??? err no volume for dsn' dsn
else if vo = 'ARCIVE' then
res = 'arcive'
else if cl = '' then
res = 'tape'
else
res = cl
if abbrev(res, 'ar') \= abbrev(dt, "X'0") ,
| abbrev(res, 'ta') \= abbrev(dt, "X'7") ,
| (left(res, 1) >= 'A') \= abbrev(dt, "X'3") then
call out 'err ??? mismatch cl' cl 'vo' vo 'dt' dt 'dsn' dsn
return res
endProcedure listCatClass
/* copx tstZos end **************************************************/
/* copx tstDiv begin **************************************************/
tstDiv:
call tstSorQ
call tstSort
call tstMatch
call tstTotal
return
endProcedure tstDiv
tstSorQ: procedure expose m. /* wkTst??? remove once upon a time */
/*<<tstSorQ
### start tst tstSorQ #############################################
sort 29 c ACHT DREI DREIZEHN EINS ELF FUENF M.I.25 M.I.26 M.I.27 M+
..I.29 NEUN SECHS SIEBEN VIER VIERZEHN ZEHN ZWEI ZWOELF 0 1 1 1 2 2+
. 3 3 4 4
sort 22 c ACHT DREIZEHN ELF M.I.25 M.I.26 M.I.27 M.I.29 NEUN VIERZ+
EHN ZEHN ZWOELF 0 1 1 1 2 2 3 3 4 4
sort 15 c M.I.25 M.I.26 M.I.27 M.I.29 0 1 1 1 2 2 3 3 4 4
sort 8 c M.I.25 M.I.26 M.I.27 M.I.29 0 1 1
sort 1 M.I.29
tstSorQ */
/*<<tstSorQAscii
### start tst tstSorQAscii ########################################
sort 29 0 1 1 1 2 2 3 3 4 4 ACHT DREI DREIZEHN EINS ELF FUENF M.I.+
25 M.I.26 M.I.27 M.I.29 NEUN SECHS SIEBEN VIER VIERZEHN ZEHN ZWEI Z+
WOELF c
sort 22 0 1 1 1 2 2 3 3 4 4 ACHT DREIZEHN ELF M.I.25 M.I.26 M.I.27+
. M.I.29 NEUN VIERZEHN ZEHN ZWOELF c
sort 15 0 1 1 1 2 2 3 3 4 4 M.I.25 M.I.26 M.I.27 M.I.29 c
sort 8 0 1 1 M.I.25 M.I.26 M.I.27 M.I.29 c
sort 1 M.I.29
tstSorQAscii */
if errOS() == 'LINUX' then
call tst t, "tstSorQAscii"
else
call tst t, "tstSorQ"
call mAdd mCut(i, 0), eins, zwei, drei, vier, fuenf, sechs,
,sieben, acht, neun, zehn, elf, zwoelf, dreizehn, vierzehn
call mAdd i, 1, 2, 3, 4, 4, 3, 2, 1, 0, 1,
, 'M.I.25', 'M.I.26', 'M.I.27', 'c', 'M.I.29'
do yy = m.i.0 by -1 to 1
do x = 0 to yy
m.i.0 = x
call sort i, o
m = ''
la = ''
if x <> m.o.0 then
call err 'size mismatch' x '<>' m.o.0
do y=1 to m.o.0
m = m m.o.y
if \ (la << m.o.y) then
call err 'sort mismatch' yy x y '\' la '<<' m.o.y
end
end
if yy // 7 = 1 then
call tstOut t, 'sort' yy m
do x = 2 to yy
x1 = x-1
m.i.x1 = m.i.x
end
end
call tstEnd t
return
endProcedure tstSorQ
tstSort: procedure expose m.
call tstSortComp
call tstSortComp '<<='
call tstSortComp 'm.aLe <<= m.aRi'
call tstSortComp 'if 1 then cmp = m.aLe <<= m.aRi; else call err sd'
return
endProcedure tstSort
tstSortComp: procedure expose m.
parse arg cmp
/*<<tstSort
### start tst tstSort #############################################
sort 29 c ACHT DREI DREIZEHN EINS ELF FUENF M.I.25 M.I.26 M.I.27 M+
..I.29 NEUN SECHS SIEBEN VIER VIERZEHN ZEHN ZWEI ZWOELF 0 1 1 1 2 2+
. 3 3 4 4
sort 22 c ACHT DREIZEHN ELF M.I.25 M.I.26 M.I.27 M.I.29 NEUN VIERZ+
EHN ZEHN ZWOELF 0 1 1 1 2 2 3 3 4 4
sort 15 c M.I.25 M.I.26 M.I.27 M.I.29 0 1 1 1 2 2 3 3 4 4
sort 8 c M.I.25 M.I.26 M.I.27 M.I.29 0 1 1
sort 1 M.I.29
tstSort */
/*<<tstSortAscii
### start tst tstSortAscii ########################################
sort 29 0 1 1 1 2 2 3 3 4 4 ACHT DREI DREIZEHN EINS ELF FUENF M.I.+
25 M.I.26 M.I.27 M.I.29 NEUN SECHS SIEBEN VIER VIERZEHN ZEHN ZWEI Z+
WOELF c
sort 22 0 1 1 1 2 2 3 3 4 4 ACHT DREIZEHN ELF M.I.25 M.I.26 M.I.27+
. M.I.29 NEUN VIERZEHN ZEHN ZWOELF c
sort 15 0 1 1 1 2 2 3 3 4 4 M.I.25 M.I.26 M.I.27 M.I.29 c
sort 8 0 1 1 M.I.25 M.I.26 M.I.27 M.I.29 c
sort 1 M.I.29
tstSortAscii */
say '### start with comparator' cmp '###'
if errOS() == 'LINUX' then
call tst t, "tstSortAscii"
else
call tst t, "tstSort"
call mAdd mCut(i, 0), eins, zwei, drei, vier, fuenf, sechs,
,sieben, acht, neun, zehn, elf, zwoelf, dreizehn, vierzehn
call mAdd i, 1, 2, 3, 4, 4, 3, 2, 1, 0, 1,
, 'M.I.25', 'M.I.26', 'M.I.27', 'c', 'M.I.29'
do yy = m.i.0 by -1 to 1
do x = 0 to yy
m.i.0 = x
call sort i, o, cmp
m = ''
la = ''
if x <> m.o.0 then
call err 'size mismatch' x '<>' m.o.0
do y=1 to m.o.0
m = m m.o.y
if \ (la << m.o.y) then
call err 'sort mismatch' yy x y '\' la '<<' m.o.y
end
end
if yy // 7 = 1 then
call tstOut t, 'sort' yy m
do x = 2 to yy
x1 = x-1
m.i.x1 = m.i.x
end
end
call tstEnd t
return
endProcedure tstSort
tstMatch: procedure expose m.
/*<<tstMatch
### start tst tstMatch ############################################
match(eins, e?n*) 1 1 2,i,s trans(E?N*) EiNs
match(eins, eins) 1 1 0 trans(EINS) EINS
match(e1nss, e?n*) 1 1 2,1,ss trans(?*) 1ss
match(eiinss, e?n*) 0 0 -9
match(einss, e?n *) 0 0 -9
match(ein s, e?n *) 1 1 2,i,s trans(E?N *) EiN s
match(ein abss , ?i*b*) 1 1 3,e,n a,ss trans(?I*B*) eIn aBss .
match(ein abss wie gehtsssxdirx und auch , ) 0 0 -9
match(ies000, *000) 1 1 1,ies trans(*000) ies000
match(xx0x0000, *000) 1 1 1,xx0x0 trans(*000) xx0x0000
match(000x00000xx, 000*) 1 1 1,x00000xx trans(000*) 000x00000xx
match(000xx, *0*) 1 1 2,00,xx trans(ab*cd*ef) ab00cdxxef
tstMatch */
call tst t, "tstMatch"
call tstOut t, matchTest1('eins', 'e?n*' )
call tstOut t, matchTest1('eins', 'eins' )
call tstOut t, matchTest1('e1nss', 'e?n*', '?*' )
call tstOut t, matchTest1('eiinss', 'e?n*' )
call tstOut t, matchTest1('einss', 'e?n *' )
call tstOut t, matchTest1('ein s', 'e?n *' )
call tstOut t, matchTest1('ein abss ', '?i*b*' )
call tstOut t, matchTest1('ein abss wie gehtsssxdirx und auch ' )
call tstOut t, matchTest1('ies000', '*000' )
call tstOut t, matchTest1('xx0x0000', '*000' )
call tstOut t, matchTest1('000x00000xx', '000*' )
call tstOut t, matchTest1('000xx', '*0*', 'ab*cd*ef' )
call tstEnd t
return
matchTest1:
parse arg w, m, m2
r = 'match('w',' m')' match(w, m) match(w, m, vv) m.vv.0
do x=1 to m.vv.0
r = r','m.vv.x
end
if m2 = '' then
m2 = translate(m)
if m.vv.0 >= 0 then
r = r 'trans('m2')' matchTrans(m2, vv)
return r
endProcedure matchTest1
/* copx tstDiv end **************************************************/
/* copx tstSql begin **************************************************/
tstSqlUtils: procedure expose m.
call sqlConnect 'DBAF'
id = 'A540769.dsnUtils'
rst = 'NO'
retcode = -9876
e = ''
z = 0
st = "TEMPLATE TCOPYD",
"DSN('&SSID..&JO..&US..P&PART(2)..D&DATE(3)..T&TIME.')",
"DATACLAS(NULL12) MGMTCLAS(COM#A011) STORCLAS(FAR$N)",
"SPACE (150,3750) TRK UNCNT 59;",
"listdef abc include tablespace DA540769.A002* partlevel;",
"listdef mf include tablespace MF01A1A.A110A partlevel;",
"copy list abc copyddn(tcopyd) shrlevel change;"
st = translate(st)
call sqlExec "call SYSPROC.DSNUTILS ( :id, :rst,",
":st,:retcode, :ANY" copies(',:e,:e,:z',12) ")"
call sqlExec ,
'ASSOCIATE LOCATOR (:RESULTS) WITH PROCEDURE SYSPROC.DSNUTILS'
say 'results' results
call sqlExec 'ALLOCATE C111 CURSOR FOR RESULT SET :RESULTS'
say 'allocated c111'
do while sqlExec('fetch c111 into :seq, :txt', 0 100) = 0
say 'sysPrint' seq strip(txt, 't')
end
call sqlExec 'close c111'
say 'closed'
call sqlDisconnect
exit
endProcedure tstSqlUtils
tstSqlStored: procedure expose m.
call sqlConnect 'DBAF'
rst = 'NO'
retcode = -9876
e = ''
z = 0
st = "abc"
call sqlExec "call SYSPROC.COMMAND ( :st, :rst)"
say 'after call st='st 'rst='rst
call sqlExec ,
'ASSOCIATE LOCATOR (:RESULTS) WITH PROCEDURE SYSPROC.COMMAND'
say 'results' results
call sqlExec 'ALLOCATE C111 CURSOR FOR RESULT SET :RESULTS'
say 'allocated c111'
do while sqlExec('fetch c111 into :seq, :txt', 0 100) = 0
say 'sysPrint' seq strip(txt, 't')
end
call sqlExec 'close c111'
say 'closed'
call sqlDisconnect
return
endProcedure tstSqlStored
tstSqlStoredWK: procedure expose m.
call sqlConnect 'DBAF'
/* st = "direct wkUtiSub"
rst = 'NO'
say 'before call st='st 'rst='rst
call sqlExec "call A540769.WKUTILSUB ( :st, :rst)"
say 'after call st='st 'rst='rst
*/ rst = 'NO'
retcode = -9876
e = ''
z = 0
prc = 'DB2UTIL.DB2UTIL'
st = "DA540769.A2*" /* DA540769.A1*" */
say "call" prc "("st", ...)"
call sqlExec "call" prc "(:st, :rst)"
say 'after call st='st 'rst='rst
call sqlExec ,
'ASSOCIATE LOCATOR (:RESULTS) WITH PROCEDURE' prc
/* say 'results' results */
call sqlExec 'ALLOCATE C111 CURSOR FOR RESULT SET :RESULTS'
say ''
say '***** utility output'
do while sqlExec('fetch c111 into :seq, :txt', 0 100) = 0
say 'sysPrint' seq strip(txt, 't')
end
call sqlExec 'close c111'
say '***** end output'
call sqlDisconnect
return 0
endProcedure tstSqlStoredWK
tstSqlStoredSQL1: procedure expose m.
call sqlConnect 'DBIA'
rst = 'NO'
retcode = -9876
e = ''
z = 0
st = "DA540769.A2* DA540769.A1*"
call sqlExec "call A540769.WKSQL1 ( :st, :rst)"
say 'after call st='st 'rst='rst
call sqlExec ,
'ASSOCIATE LOCATOR (:RESULTS) WITH PROCEDURE A540769.WKUTIL'
say 'results' results
call sqlExec 'ALLOCATE C111 CURSOR FOR RESULT SET :RESULTS'
say 'allocated c111'
do while sqlExec('fetch c111 into :seq, :txt', 0 100) = 0
say 'sysPrint' seq strip(txt, 't')
end
call sqlExec 'close c111'
say 'closed'
call sqlDisconnect
return
endProcedure tstSqlStoredSQL1
tstSqlTriggerTiming:
parse upper arg tb ni
m.noInsert = ni == 0
cnt = 200000
if tb = '' then
TB = 'GDB9998.TWK511TRI'
call sqlConnect dbaf
say timing() 'noInsert' m.noInsert 'tb' tb
call sql2St 49, '*', cc, 'select max(pri) MX from' tb
if m.cc.1.mx == m.sqlNull then
m.cc.1.mx = 0
von = m.cc.1.mx + 1
bis = m.cc.1.mx + cnt
say m.cc.0 'max' m.cc.1.mx 'von' von 'bis' bis 'count' cnt tb
if right(tb, 2) = 'A1' then do
call sqlPrepare 3, 'insert into' tb '(pri, short, long, par)' ,
'values (?, ?, ?, ?)'
do ax=von to bis
call sqlExecute 3, ax,
, ax 'wsh short', ax 'wsh long long long long long ',
, (ax-1) // 1000 + 1
end
end
else do
call sqlPrepare 3, 'insert into' tb '(pri, short, long)' ,
'values (?, ?, ?)'
do ax=von to bis
call sqlExecute 3, ax,
, ax 'wsh short', ax 'wsh long long long long long ',
, (ax-1) // 1000 + 1
end
end
/* call sqlLn 5,,, 'select * from' tb 'where pri >=' von */
call sqlExImm 'commit'
say timing()
call sqlDisconnect
return
endProcedure tstSqlTriggerTiming
tstSql: procedure expose m.
cx = 2
call sqlIni
call jIni
/*<<tstSql
### start tst tstSql ##############################################
*** err: sqlCode -204 A540769.SYSDUMMY IS AN UNDEFINED NAME .
. e 1: warnings
. e 2: state 42704
. e 3: stmt = execSql prepare s7 from :src
. e 4: with src = select * from sysdummy
fetchA 1 ab= m.abcdef.123.AB abc ef= efg
fetchA 0 ab= m.abcdef.123.AB abc ef= efg
sqlVars :M.STST.A :M.STST.A.SQLIND, :M.STST.B :M.STST.B.SQLIND, :M.+
STST.C :M.STST.C.SQLIND
1 all from dummy1
a=a b=2 c=0
sqlVarsNull 1
a=a b=2 c=---
fetchBT 1 SYSTABLES
fetchBT 0 SYSTABLES
fetchBI 1 SYSINDEXES
fetchBI 0 SYSINDEXES
opAllCl 3
fetchC 1 SYSTABLES
fetchC 2 SYSTABLESPACE
fetchC 3 SYSTABLESPACESTATS
PreAllCl 3
fetchD 1 SYSIBM.SYSTABLES
fetchD 2 SYSIBM.SYSTABLESPACE
fetchD 3 SYSIBM.SYSTABLESPACESTATS
tstSql */
call tst t, "tstSql"
call sqlConnect 'DBAF'
src = 'select * from sysdummy'
call sqlExec 'prepare s7 from :src'
call sqlPrepare cx, "select 'abc' , 'efg'",
'from sysibm.sysDummy1'
call sqlExec 'declare c'cx 'cursor for s'cx
call sqlOpen cx
a = 'abcdef'
b = 123
do i=1 to 2
call out 'fetchA' sqlFetchInto(cx, ':m.a.b.ab, :m.a.b.ef') ,
'ab= m.'a'.' || b'.'ab m.a.b.ab 'ef=' m.a.b.ef
end
call sqlClose cx
drop stst a b c m.stst.a m.stst.b m.stst.c
sv = sqlVars('M.STST', A B C , 1)
call out 'sqlVars' sv
call out sqlPreAllCl(cx,
, "select 'a', 2, case when 1=0 then 1 else null end ",
"from sysibm.sysDummy1",
, stst, sv) 'all from dummy1'
call out 'a='m.stst.a 'b='m.stst.b 'c='m.stst.c
call out 'sqlVarsNull' sqlVarsNull(stst, A B C)
call out 'a='m.stst.a 'b='m.stst.b 'c='m.stst.c
call sqlPreDeclare cx, "select name" ,
"from sysibm.sysTables" ,
"where creator = 'SYSIBM' and name = ?"
call sqlOpen cx, 'SYSTABLES'
call out 'fetchBT' sqlFetchInto(cx, ':NM') nm
call out 'fetchBT' sqlFetchInto(cx, ':NM') nm
call sqlClose cx
call sqlOpen cx, 'SYSINDEXES'
a = 'a b c'
b = 1234565687687234
call out 'fetchBI' sqlFetchInto(cx, ':NM') nm
call out 'fetchBI' sqlFetchInto(cx, ':NM') nm
call sqlClose cx
src = "select name" ,
"from sysibm.sysTables" ,
"where creator = 'SYSIBM' and name like 'SYSTABLES%'",
"fetch first 3 rows only"
call sqlPreDeclare cx, src
st = 'wie geht'' s'
call out 'opAllCl' sqlOpAllCl(cx, st, ':M.ST.SX.NAME')
do x=1 to m.st.0
call out 'fetchC' x m.st.x.name
end
st = 'auch noch'
src = "select strip(creator) || '.' || strip(name)" substr(src,12)
call out 'PreAllCl' sqlPreAllCl(cx+11, src, st, ':M.ST.SX.NAME')
do x=1 to m.st.0
call out 'fetchD' x m.st.x.name
end
call sqlDisconnect
call tstEnd t
return
endProcedure tstSql
tstSqlO: procedure expose m.
call tst t, "tstSqlO",
, "*** err: sqlCode -204 A540769.SYSDUMMY IS AN UNDEFINED NAM",
|| "E ",
, " e 1: warnings",
, " e 2: state 42704",
, " e 3: stmt = execSql prepare s7 from :src",
, " e 4: with src = select * from sysdummy",
, "REQD=Y col=123 case=--- col5=anonym",
, "NAME T DBNAME TSNAME ",
, "SYSTABAUTH T DSNDB06 SYSDBASE ",
, "SYSTABCONST T DSNDB06 SYSOBJ ",
, "SYSTABLEPART T DSNDB06 SYSDBASE ",
, "SYSTABLEPART_HI T DSNDB06 SYSHIST ",
, "SYSTABLES T DSNDB06 SYSDBASE ",
, "NAME T DBNAME TSNAME ",
, "SYSTABAUTH T DSNDB06 SYSDBASE",
, "SYSTABCONST T DSNDB06 SYSOBJ ",
, "SYSTABLEPART T DSNDB06 SYSDBASE",
, "SYSTABLEPART_HIST T DSNDB06 SYSHIST ",
, "SYSTABLES T DSNDB06 SYSDBASE"
call sqlConnect 'DBAF'
src = 'select * from sysdummy'
call sqlExec 'prepare s7 from :src'
call sql2Cursor 13,
, 'select d.*, 123, current timestamp "jetzt und heute",',
'case when 1=0 then 1 else null end caseNull,',
"'anonym'" ,
'from sysibm.sysdummy1 d'
call sqlOpen 13
do while sqlFetch(13, abc)
call out 'REQD='m.ABC.IBMREQD 'col='m.ABC.col2,
'case='m.ABC.CASENULL,
'col5='m.ABC.col5
je = 'jetzt'
jetzt = m.ABC.je
dd = date('s')
dd = left(dd, 4)'-'substr(dd, 5, 2)'-'right(dd, 2)'-' ,
|| left(time(), 2)'.'
say 'jetzt='jetzt 'date time' dd
if \ abbrev(jetzt, dd) then
call err 'date mismatch abbrev' dd
end
call sqlClose 13
call sql2Cursor 13 ,
, 'select name, class, dbName, tsName' ,
/* ,alteredTS, obid, cardf'*/ ,
'from sysibm.systables' ,
"where creator = 'SYSIBM' and name like 'SYSTA%'" ,
"fetch first 5 rows only",
, , 'sl<15'
call sqlOpen 13
call out fmtFldTitle(m.sql.13.fmt)
do while sqlFetchLn(13, li)
call out m.li
end
call sqlClose 13
call sqlGenFmt m.sql.13.fmt, 13, 'sst'
call sqlOpen 13
do ix=1 while sqlFetch(13, fe.ix)
end
m.fe.0 = ix-1
call fmtFldSquash sqFmt, sqlClass(13), fe
call out fmtFldTitle(sqFmt)
do ix=1 to m.fe.0
call out oFldCat(sqlClass(13), fe.ix, sqFmt)
end
call sqlClose 13
if 0 then do
call sql2Cursor 13 ,
, 'select *',
'from sysibm.systables' ,
"where creator = 'SYSIBM' and name like 'SYSTA%'" ,
"fetch first 1 rows only",
, , 'sl<15'
call sqlOpen 13
call out fmtFldTitle(m.sql.13.fmt)
do while sqlFetchLn(13, li)
call out m.li
end
call sqlClose 13
end
call sqlDisconnect
call tstEnd t
return
endProcedure tstSqlO
tstSqlEnv: procedure expose m.
call tst t, "tstSqlEnv",
, "REQD=Y COL2=123 case=--- COL5=anonym",
, "sql fmtFldRw sl<15",
, "NAME T DBNAME TSNAME ",
, "SYSTABAUTH T DSNDB06 SYSDBASE ",
, "SYSTABCONST T DSNDB06 SYSOBJ ",
, "SYSTABLEPART T DSNDB06 SYSDBASE ",
, "SYSTABLEPART_HI T DSNDB06 SYSHIST ",
, "SYSTABLES T DSNDB06 SYSDBASE ",
, "sql fmtFldSquashRW",
, "NAME T DBNAME TSNAME ",
, "SYSTABAUTH T DSNDB06 SYSDBASE",
, "SYSTABCONST T DSNDB06 SYSOBJ ",
, "SYSTABLEPART T DSNDB06 SYSDBASE",
, "SYSTABLEPART_HIST T DSNDB06 SYSHIST ",
, "SYSTABLES T DSNDB06 SYSDBASE",
, "sqlLn sl=",
, "COL1 T DBNAME COL4 ",
, "SYSTABAUTH T DSNDB06 SYSDBASE"
call mAdd t.cmp,
, "SYSTABCONST T DSNDB06 SYSOBJ ",
, "SYSTABLEPART T DSNDB06 SYSDBASE",
, "SYSTABLEPART_ T DSNDB06 SYSHIST ",
, "SYSTABLES T DSNDB06 SYSDBASE",
, "sqlLn ---",
, "NAME T DBNAME TSNAME ",
, "SYSTABAUTH T DSNDB06 SYSDBASE",
, "SYSTABCONST T DSNDB06 SYSOBJ ",
, "SYSTABLEPART T DSNDB06 SYSDBASE",
, "SYSTABLEPART_HIST T DSNDB06 SYSHIST ",
, "SYSTABLES T DSNDB06 SYSDBASE"
call sqlConnect 'DBAF'
call pipeBegin
call out 'select d.*, 123, current timestamp "jetzt und heute",'
call out 'case when 1=0 then 1 else null end caseNull,'
call out "'anonym'"
call out 'from sysibm.sysdummy1 d'
call pipe
call sql 13
call pipeLast
do while envRead(abc)
call out 'REQD='envGet('ABC.IBMREQD'),
'COL2='envGet('ABC.COL2'),
'case='envGet('ABC.CASENULL'),
'COL5='envGet('ABC.COL5')
jetzt = envGet('ABC.jetzt')
say 'jetzt='jetzt
dd = date('s')
dd = left(dd, 4)'-'substr(dd, 5, 2)'-'right(dd, 2)'-' ,
|| left(time(), 2)'.'
if \ abbrev(jetzt, dd) then
call err 'date mismatch abbrev' dd
end
call pipeEnd
call out 'sql fmtFldRw sl<15'
call pipeBegin
call out 'select name, class, dbName, tsName'
/* ,alteredTS, obid, cardf'*/
call out 'from sysibm.systables'
call out "where creator = 'SYSIBM' and name like 'SYSTA%'"
call out "fetch first 5 rows only"
call pipe
call sql 13
call pipeLast
call fmtFldRW sqlGenFmt(fmtAbc, 13, 'sl<15')
call pipeEnd
call out 'sql fmtFldSquashRW'
call pipeBegin
call out 'select name, class, dbName, tsName'
/* ,alteredTS, obid, cardf'*/
call out 'from sysibm.systables'
call out "where creator = 'SYSIBM' and name like 'SYSTA%'"
call out "fetch first 5 rows only"
call pipe
call sql 13
call pipeLast
call fmtFldSquashRW
call pipeEnd
call out 'sqlLn sl='
call pipeBegin
call out 'select char(name, 13), class, dbName, char(tsName, 8)'
/* ,alteredTS, obid, cardf'*/
call out 'from sysibm.systables'
call out "where creator = 'SYSIBM' and name like 'SYSTA%'"
call out "fetch first 5 rows only"
call pipeLast
call sqlLn 13, , ,'sl='
call pipeEnd
call out 'sqlLn ---'
call pipeBegin
call out 'select name, class, dbName, tsName'
/* ,alteredTS, obid, cardf'*/
call out 'from sysibm.systables'
call out "where creator = 'SYSIBM' and name like 'SYSTA%'"
call out "fetch first 5 rows only"
call pipeLast
call sqlLn 13
call pipeEnd
call sqlDisconnect
call tstEnd t
return
endProcedure tstSqlEnv
/* copx tstSql end ***************************************************/
/* copx tstComp begin **************************************************
test the wsh compiler
***********************************************************************/
tstComp: procedure expose m.
call compIni
call tstCompDataConst
call tstCompDataVars
call tstCompShell
call tstCompPrimary
call tstCompExpr
call tstCompFile
call tstCompStmt
call tstCompDir
call tstCompObj
call tstCompDataIO
call tstCompPipe
call tstCompRedir
call tstCompComp
call tstCompSyntax
call tstTotal
return
endProcedure tstComp
tstComp1: procedure expose m.
parse arg ty nm cnt
c1 = 0
if cnt = 0 |cnt = '+' then do
c1 = cnt
cnt = ''
end
call jIni
src = jBuf()
call jOpen src, m.j.cWri
do sx=2 to arg()
call jWrite src, arg(sx)
end
call tstComp2 nm, ty, jClose(src), , c1, cnt
return
endProcedure tstComp1
tstComp2: procedure expose m.
parse arg nm, spec, src, compSt
call compIni
call tst t, nm, compSt
if src == '' then do
src = jBuf()
call tst4dp src'.BUF', mapInline(nm'Src')
end
m.t.moreOutOk = abbrev(strip(arg(5)), '+')
cmp = comp(src)
call out 'compile' spec',' (m.src.buf.0) 'lines:' m.src.buf.1
r = compile(cmp, spec)
noSyn = m.t.errHand = 0
coErr = m.t.err
say if( noSyn, "compiled", "*** syntaxed") r ":" objMet(r, 'oRun')
cnt = 0
do ax = 5 to max(arg(), 5) while m.t.err = coErr & noSyn
a1 = strip(arg(ax))
if a1 == '' & arg() >= 5 then
iterate
if abbrev(a1, '+') then do
m.t.moreOutOk = 1
a1 = strip(substr(a1, 2))
end
if datatype(a1, 'n') then
cnt = a1
else if a1 \== '' then
call err 'tstComp2 bad arg('ax')' arg(ax)
if cnt = 0 then do
call mCut 'T.IN', 0
call out "run without input"
end
else do
call mAdd mCut('T.IN', 0),
,"eins zwei drei", "zehn elf zwoelf?",
, "zwanzig 21 22 23 24 ... 29|"
do lx=4 to cnt
call mAdd 'T.IN', left(lx "line" lx, lx+9, '-')';'
end
call out "run with" cnt "inputs"
end
m.t.inIx = 0
call oRun r
end
call tstEnd t
return
endProcedure tstComp2
tstCompDataConst: procedure expose m.
/*<<tstCompDataConst
### start tst tstCompDataConst ####################################
compile =, 8 lines: Lline one, $** asdf
run without input
. Lline one, .
line two..
line threecontinued on 4
line five fortsetzung
line six fortsetzung
tstCompDataConst */
call tstComp1 '= tstCompDataConst',
, ' Lline one, $** asdf',
, 'line two.',
, 'line three$*+ bla bla' ,
, 'continued on 4',
, 'line five $*( und so',
, 'weiter $abc $? $''$*)'' $"$*)" und weiter $*) fortsetzung',
, 'line six $*( und $*( $** $*( so',
, 'weiter $abc $? $*)'' $"$*)" und weiter $*) fortsetzung'
/*<<tstCompDataConstBefAftComm1
### start tst tstCompDataConstBefAftComm1 #########################
compile =, 3 lines: $*(anfangs com.$*) $*(plus$*) $** x
run without input
the only line;
tstCompDataConstBefAftComm1 */
call tstComp1 '= tstCompDataConstBefAftComm1',
, ' $*(anfangs com.$*) $*(plus$*) $** x',
, 'the only line;',
, ' $*(end kommentar$*) '
/*<<tstCompDataConstBefAftComm2
### start tst tstCompDataConstBefAftComm2 #########################
compile =, 11 lines: $*(anfangs com.$*) $*(plus$*) $*+ x
run without input
the first non empty line;
. .
befor an empty line with comments;
tstCompDataConstBefAftComm2 */
call tstComp1 '= tstCompDataConstBefAftComm2',
, ' $*(anfangs com.$*) $*(plus$*) $*+ x',
, ' $*(forts Zeile com.$*) $*(plus$*) $** x',
, ' $*(comment 2. Zeile$*) $*(plus$*) $*+ x',
, ' $*(forts Zeile com.$*) $*(plus$*) $** x',
, 'the first non empty line;',
, ' ',
, 'befor an empty line with comments;',
, ' $*(comment 4. Zeile$*) $*(plus$*) $*+ x',
, ' $*(forts 4.Zeile com.$*) $*(plus$*) $** x',
, ' $*(end kommentar$*) $*+',
, ' $*(forts end com.$*) $*(plus$*) $** x'
return
endProcedure tstCompDataComm
tstCompDataVars: procedure expose m.
/*<<tstCompDataVars
### start tst tstCompDataVars #####################################
compile =, 5 lines: Lline one, $** asdf
run without input
. Lline one, .
lline zwei output
lline 3 .
variable v1 = valueV1 ${v1}= valueV1; .
. $-$.{""$v1} = valueV1; .
tstCompDataVars */
call tstComp1 '= tstCompDataVars',
, ' Lline one, $** asdf',
, ' $$ lline zwei output',
, 'lline 3 $=v1= valueV1 ' ,
, 'variable v1 = $v1 $"${v1}=" ${ v1 }; ',
, ' $"$-$.{""""$v1} =" $-$.{""$v1}; '
return
endProcedure tstCompDataVars
tstCompShell: procedure expose m.
/*<<tstCompShell
### start tst tstCompShell ########################################
compile @, 12 lines: $$ Lline one, $** asdf
run without input
Lline one,
lline zwei output
v1 = valueV1 ${v1}= valueV1|
REXX OUT L5 CONTINUED L6 CONTINUED L7
L8 ONE
L9 TWO
valueV1
valueV1 valueV2
out valueV1 valueV2
SCHLUSS
tstCompShell */
call tstComp1 '@ tstCompShell',
, ' $$ Lline one, $** asdf',
, ' $$ lline zwei output',
, ' $=v1= valueV1 ' ,
, '$$ v1 = $v1 $"${v1}=" ${ v1 }| ' ,
, 'call out rexx out l5, ' ,
, ' continued l6 , ' ,
, ' continued l7 ' ,
, 'call out l8 one ' ,
, 'call out l9 two$=v2=valueV2 ',
, '$$- $v1 $$- $v1 $v2 ',
, 'call out "out " $v1 $v2 ',
, '$$- schluss '
/*<<tstCompShell2
### start tst tstCompShell2 #######################################
compile @, 13 lines: $@do j=0 to 1 $@¢ $$ do j=$j
run without input
do j=0
after if 0 $@¢ $!
after if 0 $=@¢ $!
do j=1
if 1 then $@¢ a
a2
if 1 then $@=¢ b
b2
after if 1 $@¢ $!
after if 1 $=@¢ $!
end
tstCompShell2 */
call tstComp1 '@ tstCompShell2',
, '$@do j=0 to 1 $@¢ $$ do j=$j' ,
, 'if $j then $@¢ ',
, '$$ if $j then $"$@¢" a $$a2' ,
, '$!',
, 'if $j then $@=¢ ',
, '$$ if $j then $"$@=¢" b $$b2' ,
, '$!',
, 'if $j then $@¢ $!' ,
, '$$ after if $j $"$@¢ $!"' ,
, 'if $j then $@=¢ $!' ,
, '$$ after if $j $"$=@¢ $!"' ,
, '$!',
, '$$ end'
return
endProcedure tstCompShell
tstCompPrimary: procedure expose m.
call compIni
/*<<tstCompPrimary
### start tst tstCompPrimary ######################################
compile =, 16 lines: Strings $"$""$""""$""" $'$''$''''$'''
run without input
Strings $"$""$" $'$''$'
rexx $-{ 3 * 5 } = 15
rexx $-¢ 5 * 7 $! = 35
rexx $-// 7 * 11 $// = 77
rexx $-/abcEf/ 11 * 13 $/abcEf/ = 143
data line three line four bis hier
shell line five line six bis hier
var get v1 value Eins, v1 value Eins .
var isDef v1 1, v2 0 .
#jIn eof 1#
var read >1 0 rr undefined
#jIn eof 2#
var read >2 0 rr undefined
no call abc$-{4*5} $-{efg$-{6*7} abc20 EFG42
brackets $-{$-{1+9}*$-¢7+3$!*$-/b/5+5$/b/} 1000
run with 3 inputs
Strings $"$""$" $'$''$'
rexx $-{ 3 * 5 } = 15
rexx $-¢ 5 * 7 $! = 35
rexx $-// 7 * 11 $// = 77
rexx $-/abcEf/ 11 * 13 $/abcEf/ = 143
data line three line four bis hier
shell line five line six bis hier
var get v1 value Eins, v1 value Eins .
var isDef v1 1, v2 0 .
#jIn 1# eins zwei drei
var read >1 1 rr eins zwei drei
#jIn 2# zehn elf zwoelf?
var read >2 1 rr zehn elf zwoelf?
no call abc$-{4*5} $-{efg$-{6*7} abc20 EFG42
brackets $-{$-{1+9}*$-¢7+3$!*$-/b/5+5$/b/} 1000
tstCompPrimary */
call envRemove 'v2'
call tstComp1 '= tstCompPrimary 3',
, 'Strings $"$""$""""$"""' "$'$''$''''$'''",
, 'rexx $"$-{ 3 * 5 } =" $-{ 3 * 5 }' ,
, 'rexx $"$-¢ 5 * 7 $! =" $-¢ 5 * 7 $!' ,
, 'rexx $"$-// 7 * 11 $// =" $-// 7 * 11 $//' ,
, 'rexx $"$-/abcEf/ 11 * 13 $/abcEf/ ="',
'$-/abcEf/ 11 * 13 $/abcEf/' ,
, 'data $-=¢ line three',
, 'line four $! bis hier' ,
, 'shell $-@¢ $$ line five',
, '$$ line six $! bis hier' ,
, '$= v1 = value Eins $=rr=undefined $= eins = 1 ',
, 'var get v1 $v1, v1 ${ v1 } ',
, 'var isDef v1 ${? v${ eins } }, v2 ${?v2 } ',
, 'var read >1 ${> rr} rr $rr' ,
, 'var read >2 ${> rr} rr $rr',
, 'no call $"abc$-{4*5} $-{efg$-{6*7}"',
'abc$-{4*5} $-{efg$-{6*7}}',
, 'brackets $"$-{$-{1+9}*$-¢7+3$!*$-/b/5+5$/b/}"',
'$-{$-{1+9}*$-¢7+3$!*$-/b/5+5$/b/}'
return
endProcedure tstCompPrimary
tstCompExpr: procedure expose m.
call compIni
/*<<tstCompExprStr
### start tst tstCompExprStr ######################################
compile -, 3 lines: $=vv=vvStr
run without input
vv=vvStr
o2String($.$vv)=vvStr
tstCompExprStr */
call tstComp1 '- tstCompExprStr',
, '$=vv=vvStr' ,
, '"vv="$vv' ,
, '$"o2String($.$vv)="o2String($.$vv)'
/*<<tstCompExprObj
### start tst tstCompExprObj ######################################
compile ., 5 lines: $=vv=vvStr
run without input
vv=
vvStr
s2o($.$vv)=
vvStr
tstCompExprObj */
call tstComp1 '. tstCompExprObj',
, '$=vv=vvStr' ,
, '"!vv="', '$vv',
, '$"s2o($.$vv)="', 's2o($-$vv)'
/*<<tstCompExprDat
### start tst tstCompExprDat ######################################
compile =, 4 lines: $=vv=vvDat
run without input
vv=vvDat
$.$vv= !vvDat
$.$-{"abc"}=!abc
tstCompExprDat */
call tstComp1 '= tstCompExprDat',
, '$=vv=vvDat' ,
, 'vv=$vv',
, '$"$.$vv=" $.$vv',
, '$"$.$-{""abc""}="$.$-{"abc"}'
/*<<tstCompExprRun
### start tst tstCompExprRun ######################################
compile @, 3 lines: $=vv=vvRun
run without input
vv=vvRun
o2string($.$vv)=vvRun
tstCompExprRun */
call tstComp1 '@ tstCompExprRun',
, '$=vv=vvRun' ,
, 'call out "vv="$vv',
, 'call out $"o2string($.$vv)="o2string($.$vv)'
/*<<tstCompExprCon
tstCompExprCon */
/* wkTst sinnvolle Erweiterung ???
call tstComp1 '# tstCompExprCon',
, '$=vv=vvCon' ,
, 'call out "vv="$vv',
, 'call out $"o2string($.$vv)="o2string($.$vv)'
*/
return
endProcedure tstCompExpr
tstCompStmt: procedure expose m.
/*<<tstCompStmt1
### start tst tstCompStmt1 ########################################
compile @, 8 lines: $= v1 = value eins $= v2 =- 3*5*7 .
run without input
data v1 value eins v2 105
eins
zwei
drei
vier
fuenf
elf
zwoelf dreiZ
. vierZ .
fuenfZ
lang v1 value eins v2 945
oRun ouput 1
tstCompStmt1 */
call pipeIni
call envPutO 'oRun', oRunner('call out "oRun ouput" (1*1)')
call envRemove 'v2'
call tstComp1 '@ tstCompStmt1',
, '$= v1 = value eins $= v2 =- 3*5*7 ',
, '$$ data v1 $v1 v2 ${ v2 }',
, '$$eins $@¢$$ zwei $$ drei ',
, ' $@¢ $! $@{ } $@// $// $@/q r s / $/q r s /',
' $@/eins/ $@¢ $$vier $! $/eins/ $! $$fuenf',
, '$$elf $@=¢$@={ zwoelf dreiZ } ',
, ' $@=¢ $! $@=¢ $@=¢ vierZ $! $! $! $$fuenfZ',
, '$$- "lang v1" $v1 "v2" ${v2}*9',
, '$@$oRun""' /* String am schluss -> $$ "" statment||||| */
/*<<tstCompStmt2
### start tst tstCompStmt2 ########################################
compile @, 1 lines: $@for qq $$ loop qq $qq
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
loop qq eins zwei drei
#jIn 2# zehn elf zwoelf?
loop qq zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
loop qq zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
tstCompStmt2 */
call tstComp1 '@ tstCompStmt2 3',
, '$@for qq $$ loop qq $qq'
/*<<tstCompStmt3
### start tst tstCompStmt3 ########################################
compile @, 9 lines: $$ 1 begin run 1
2 ct zwei
ct 4 mit assign .
run without input
1 begin run 1
3 run 3 ctV = ct 4 assign ctV|
run 5 procCall $@$prCa
out in proc at 8
run 6 vor call $@prCa()
out in proc at 8
9 run end
run with 3 inputs
1 begin run 1
3 run 3 ctV = ct 4 assign ctV|
run 5 procCall $@$prCa
out in proc at 8
run 6 vor call $@prCa()
out in proc at 8
9 run end
tstCompStmt3 */
call tstComp1 '@ tstCompStmt3 3',
, '$$ 1 begin run 1',
, '$@ct $$ 2 ct zwei',
, '$$ 3 run 3 ctV = $ctV|',
, '$@ct $@=¢ct 4 mit assign $=ctV = ct 4 assign ctV $!',
, '$$ run 5 procCall $"$@$prCa" $@$prCa',
, '$$ run 6 vor call $"$@prCa()"',
, '$@prCa()',
, '$@proc prCa $$out in proc at 8',
, '$$ 9 run end'
/*<<tstCompStmtDo
### start tst tstCompStmtDo #######################################
compile @, 2 lines: ti=0$@do y=3 to 4 $@do 2 $@¢
run without input
y=3 ti1 z=7
y=3 ti1 z=8
y=3 ti2 z=7
y=3 ti2 z=8
y=4 ti3 z=7
y=4 ti3 z=8
y=4 ti4 z=7
y=4 ti4 z=8
tstCompStmtDo */
call tstComp1 '@ tstCompStmtDo', 'ti=0$@do y=3 to 4 $@do 2 $@¢',
, 'ti = ti + 1',
'$@do $*(sdf$*) z $*(sdf$*) = 7 to 8 $$ y=$y ti$-{ti} z=$z $!'
/*<<tstCompStmtDo2
### start tst tstCompStmtDo2 ######################################
compile @, 7 lines: $$ $-=/sqlSel/
run without input
select 1 abc select 2 abc after table .
tstCompStmtDo2 */
call tstComp1 '@ tstCompStmtDo2',
, '$$ $-=/sqlSel/',
, '$=ty = abc ',
, '$@do tx=1 to 2 $@=/table/',
, 'select $tx $ty',
, '$/table/',
, '$=ty = abc',
, 'after table',
'$/sqlSel/'
return
endProcedure tstCompStmt
tstCompSyntax: procedure expose m.
call tstCompSynPrimary
call tstCompSynAss
call tstCompSynRun
return
endProcedure tstCompSyntax
tstCompSynPrimary: procedure expose m.
/*<<tstCompSynPri1
### start tst tstCompSynPri1 ######################################
compile @, 1 lines: a $ =
*** err: scanErr pipe or $; expected: compile shell stopped before+
. end of input
. e 1: last token scanPosition $ =
. e 2: pos 3 in line 1: a $ =
tstCompSynPri1 */
call tstComp1 '@ tstCompSynPri1 +', 'a $ ='
/*<<tstCompSynPri2
### start tst tstCompSynPri2 ######################################
compile @, 1 lines: a $. {
*** err: scanErr objRef expected after $. expected
. e 1: last token scanPosition {
. e 2: pos 5 in line 1: a $. {
tstCompSynPri2 */
call tstComp1 '@ tstCompSynPri2 +', 'a $. {'
/*<<tstCompSynPri3
### start tst tstCompSynPri3 ######################################
compile @, 1 lines: b $- ¢ .
*** err: scanErr objRef expected after $- expected
. e 1: last token scanPosition ¢
. e 2: pos 5 in line 1: b $- ¢
tstCompSynPri3 */
call tstComp1 '@ tstCompSynPri3 +', 'b $- ¢ '
/*<<tstCompSynPri4
### start tst tstCompSynPri4 ######################################
compile @, 1 lines: a ${ $*( sdf$*) } =
*** err: scanErr var name expected
. e 1: last token scanPosition } =
. e 2: pos 17 in line 1: a ${ $*( sdf$*) } =
tstCompSynPri4 */
call tstComp1 '@ tstCompSynPri4 +', 'a ${ $*( sdf$*) } ='
/*<<tstCompSynFile
### start tst tstCompSynFile ######################################
compile @, 1 lines: $@$.<$*( co1 $*) $$abc
*** err: scanErr block or expr expected for file expected
. e 1: last token scanPosition $$abc
. e 2: pos 18 in line 1: $@$.<$*( co1 $*) $$abc
tstCompSynFile */
call tstComp1 '@ tstCompSynFile +', '$@$.<$*( co1 $*) $$abc'
return
endProcedure tstCompSynPrimary
tstCompSynAss: procedure expose m.
/*<<tstCompSynAss1
### start tst tstCompSynAss1 ######################################
compile @, 1 lines: $=
*** err: scanErr variable name after $= expected
. e 1: last token scanPosition .
. e 2: pos 3 in line 1: $=
tstCompSynAss1 */
call tstComp1 '@ tstCompSynAss1 +', '$='
/*<<tstCompSynAss2
### start tst tstCompSynAss2 ######################################
compile @, 2 lines: $= .
*** err: scanErr variable name after $= expected
. e 1: last token scanPosition .
. e 2: pos 6 in line 1: $=
tstCompSynAss2 */
call tstComp1 '@ tstCompSynAss2 +', '$= ', 'eins'
/*<<tstCompSynAss3
### start tst tstCompSynAss3 ######################################
compile @, 2 lines: $= $$
*** err: scanErr variable name after $= expected
. e 1: last token scanPosition $$
. e 2: pos 6 in line 1: $= $$
tstCompSynAss3 */
call tstComp1 '@ tstCompSynAss3 +', '$= $$', 'eins'
/*<<tstCompSynAss4
### start tst tstCompSynAss4 ######################################
compile @, 1 lines: $= eins
*** err: scanErr = expected after $= "eins"
. e 1: last token scanPosition .
. e 2: pos 10 in line 1: $= eins
tstCompSynAss4 */
call tstComp1 '@ tstCompSynAss4 +', '$= eins'
/*<<tstCompSynAss5
### start tst tstCompSynAss5 ######################################
compile @, 1 lines: $= abc eins $$ = x
*** err: scanErr = expected after $= "abc eins"
. e 1: last token scanPosition $$ = x
. e 2: pos 14 in line 1: $= abc eins $$ = x
tstCompSynAss5 */
call tstComp1 '@ tstCompSynAss5 +', '$= abc eins $$ = x'
/*<<tstCompSynAss6
### start tst tstCompSynAss6 ######################################
compile @, 1 lines: $= abc =
*** err: scanErr block or expression after $= "abc" = expected
. e 1: last token scanPosition .
. e 2: pos 10 in line 1: $= abc =
tstCompSynAss6 */
call tstComp1 '@ tstCompSynAss6 +', '$= abc ='
/*<<tstCompSynAss7
### start tst tstCompSynAss7 ######################################
compile @, 1 lines: $= abc =..
*** err: scanErr block or expression after $= "abc" = expected
. e 1: last token scanPosition .
. e 2: pos 11 in line 1: $= abc =..
tstCompSynAss7 */
call tstComp1 '@ tstCompSynAss7 +', '$= abc =.'
return
endProcedure tstCompSynAss
tstCompSynRun: procedure expose m.
/*<<tstCompSynRun1
### start tst tstCompSynRun1 ######################################
compile @, 1 lines: $@
*** err: scanErr objRef expected after $@ expected
. e 1: last token scanPosition .
. e 2: pos 3 in line 1: $@
tstCompSynRun1 */
call tstComp1 '@ tstCompSynRun1 +', '$@'
/*<<tstCompSynRun2
### start tst tstCompSynRun2 ######################################
compile @, 1 lines: $@=
*** err: scanErr objRef expected after $@ expected
. e 1: last token scanPosition =
. e 2: pos 3 in line 1: $@=
tstCompSynRun2 */
call tstComp1 '@ tstCompSynRun2 +', '$@='
/*<<tstCompSynRun3
### start tst tstCompSynRun3 ######################################
compile @, 1 lines: $@ =
*** err: scanErr objRef expected after $@ expected
. e 1: last token scanPosition =
. e 2: pos 3 in line 1: $@ =
tstCompSynRun3 */
call tstComp1 '@ tstCompSynRun3 +', '$@ ='
/*<<tstCompSynFor4
### start tst tstCompSynFor4 ######################################
compile @, 1 lines: $@for
*** err: scanErr variable name after $@for expected
. e 1: last token scanPosition .
. e 2: pos 6 in line 1: $@for
tstCompSynFor4 */
call tstComp1 '@ tstCompSynFor4 +', '$@for'
/*<<tstCompSynFor5
### start tst tstCompSynFor5 ######################################
compile @, 2 lines: $@for
*** err: scanErr variable name after $@for expected
. e 1: last token scanPosition .
. e 2: pos 6 in line 1: $@for
tstCompSynFor5 */
call tstComp1 '@ tstCompSynFor5 +', '$@for', a
/*<<tstCompSynFor6
### start tst tstCompSynFor6 ######################################
compile @, 2 lines: a
*** err: scanErr variable name after $@for expected
. e 1: last token scanPosition $$q
. e 2: pos 12 in line 2: b $@for $$q
tstCompSynFor6 */
call tstComp1 '@ tstCompSynFor6 +', 'a', ' b $@for $$q'
/*<<tstCompSynFor7
### start tst tstCompSynFor7 ######################################
compile @, 3 lines: a
*** err: scanErr statement after $@for "a" expected
. e 1: last token scanPosition .
. e 2: pos 11 in line 2: b $@for a
tstCompSynFor7 */
call tstComp1 '@ tstCompSynFor7 +', 'a', ' b $@for a', ' $$q'
/*<<tstCompSynCt8
### start tst tstCompSynCt8 #######################################
compile @, 3 lines: a
*** err: scanErr ct statement expected
. e 1: last token scanPosition .
. e 2: pos 8 in line 2: b $@ct
tstCompSynCt8 */
call tstComp1 '@ tstCompSynCt8 +', 'a', ' b $@ct', ' $$q'
/*<<tstCompSynProc9
### start tst tstCompSynProc9 #####################################
compile @, 2 lines: a
*** err: scanErr proc name expected
. e 1: last token scanPosition $$q
. e 2: pos 12 in line 2: b $@proc $$q
tstCompSynProc9 */
call tstComp1 '@ tstCompSynProc9 +', 'a', ' b $@proc $$q'
/*<<tstCompSynProcA
### start tst tstCompSynProcA #####################################
compile @, 2 lines: $@proc p1
*** err: scanErr proc statement expected
. e 1: last token scanPosition .
. e 2: pos 10 in line 1: $@proc p1
tstCompSynProcA */
call tstComp1 '@ tstCompSynProcA +', '$@proc p1', ' $$q'
/*<<tstCompSynCallB
### start tst tstCompSynCallB #####################################
compile @, 1 lines: $@call (roc p1)
*** err: scanErr procCall, for, do, ct, proc or objRef expected aft+
er $@
. e 1: last token scanPosition (roc p1)
. e 2: pos 7 in line 1: $@call (roc p1)
tstCompSynCallB */
call tstComp1 '@ tstCompSynCallB +', '$@call (roc p1)'
/*<<tstCompSynCallC
### start tst tstCompSynCallC #####################################
compile @, 1 lines: $@call( roc p1 )
*** err: scanErr closing ) expected after $@call(
. e 1: last token scanPosition roc p1 )
. e 2: pos 9 in line 1: $@call( roc p1 )
tstCompSynCallC */
call tstComp1 '@ tstCompSynCallC +', '$@call( roc p1 )'
/*<<tstCompSynCallD
### start tst tstCompSynCallD #####################################
compile @, 2 lines: $@call( $** roc
*** err: scanErr closing ) expected after $@call(
. e 1: last token scanPosition .
. e 2: pos 16 in line 1: $@call( $** roc
tstCompSynCallD */
call tstComp1 '@ tstCompSynCallD +',
,'$@call( $** roc' , ' $*( p1 $*) )'
return
endProcedure tstCompSynRun
tstCompObj: procedure expose m.
call tstReset t
call oIni
cl = classNew('n tstCompCla u v, f FEINS v, f FZWEI v')
do rx=1 to 10
o = oNew(cl)
m.tstComp.rx = o
m.o = 'o'rx
if rx // 2 = 0 then do
m.o.fEins = 'o'rx'.1'
m.o.fZwei = 'o'rx'.fZwei'rx
end
else do
m.o.fEins = 'o'rx'.fEins'
m.o.fZwei = 'o'rx'.2'
end
call mAdd 'T.TRANS', m.tstComp.rx '<o'rx'>'
end
/*<<tstCompObjRef
### start tst tstCompObjRef #######################################
compile @, 13 lines: o1=m.tstComp.1
run without input
out .$"string" o1
string
out . o1
tstR: @<o1> isA :tstCompCla union = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
out .{ o2 }
tstR: @<o2> isA :tstCompCla union = o2
tstR: .FEINS = o2.1
tstR: .FZWEI = o2.fZwei2
out .¢ o3 $!
tstR: @<o3> isA :tstCompCla union = o3
tstR: .FEINS = o3.fEins
tstR: .FZWEI = o3.2
out .¢ o4 $!
tstR: @<o4> isA :tstCompCla union = o4
tstR: .FEINS = o4.1
tstR: .FZWEI = o4.fZwei4
out ./-/ o5 $/-/
tstR: @<o5> isA :tstCompCla union = o5
tstR: .FEINS = o5.fEins
tstR: .FZWEI = o5.2
tstCompObjRef */
call tstComp1 '@ tstCompObjRef' ,
, 'o1=m.tstComp.1',
, 'o2 = m.tstComp.2' ,
, '$$ out $".$""string""" o1 $$.$"string"',
, '$$ out . o1 $$. o1',
, '$$ out .{ o2 } $$.{ o2 }',
, '$$ out .¢ o3 $"$!" $$.¢ ', ' m.tstComp.3 ', ' $!',
, '$$ out .¢ o4 $"$!" $$.¢ ', ' m.tstComp.4 ', ' $!',
, '$$ out ./-/ o5 $"$/-/" $$./-/ m.tstComp.5 ', ' $/-/'
/*<<tstCompObjRefPri
### start tst tstCompObjRefPri ####################################
compile @, 9 lines: $$ out .$"$.{o1}" $$.$.{ m.tstComp.1 }
run without input
out .$.{o1}
tstR: @<o1> isA :tstCompCla union = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
out .$.-{o2}
<o2>
out .$.={o3}
m.tstComp.3
out .$.@{out o4}
tstWriteO kindOf ORun oRun begin <<<
tstR: @<o4> isA :tstCompCla union = o4
tstR: .FEINS = o4.1
tstR: .FZWEI = o4.fZwei4
tstWriteO kindOf ORun oRun end >>>
out .$.@¢$$abc $$efg$!
tstWriteO kindOf ORun oRun begin <<<
abc
efg
tstWriteO kindOf ORun oRun end >>>
out .$.@¢o5$!
tstWriteO kindOf ORun oRun begin <<<
tstR: @<o5> isA :tstCompCla union = o5
tstR: .FEINS = o5.fEins
tstR: .FZWEI = o5.2
abc
tstWriteO kindOf ORun oRun end >>>
tstCompObjRefPri */
call tstComp1 '@ tstCompObjRefPri' ,
, '$$ out .$"$.{o1}" $$.$.{ m.tstComp.1 }',
, '$$ out .$"$.-{o2}" $$.$.-{ m.tstComp.2 }',
, '$$ out .$"$.={o3}" $$.$.={ m.tstComp.3 }',
, '$$ out .$"$.@{out o4}" $$.$.@{ call outO m.tstComp.4 }',
, '$$ out .$"$.@¢$$abc $$efg$!" $$.$.@¢ $$abc ', ' ', ' $$efg $!',
, '$$ out .$"$.@¢o5$!" $$.$.@¢ $$.m.tstComp.5', '$$abc $!'
/*<<tstCompObjRefFile
### start tst tstCompObjRefFile ###################################
compile @, 7 lines: $$ out .$".<.¢o1!" $$.$.<.¢ m.tstComp.1 $!
run without input
out ..<.¢o1!
tstWriteO kindOf JRW jWriteNow begin <<<
tstR: @LINE isA :tstCompCla union = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
tstWriteO kindOf JRW jWriteNow end >>>
out .<$.-{o2}
tstWriteO kindOf JRW jWriteNow begin <<<
tstR: @LINE isA :tstCompCla union = o2
tstR: .FEINS = o2.1
tstR: .FZWEI = o2.fZwei2
tstWriteO kindOf JRW jWriteNow end >>>
out .$.<{o3}
tstWriteO kindOf JRW jWriteNow begin <<<
m.tstComp.3
tstWriteO kindOf JRW jWriteNow end >>>
out .$.<@{out o4}
tstWriteO kindOf JRW jWriteNow begin <<<
tstR: @LINE isA :tstCompCla union = o4
tstR: .FEINS = o4.1
tstR: .FZWEI = o4.fZwei4
tstWriteO kindOf JRW jWriteNow end >>>
out .$<@¢$$abc $$efg$!
tstWriteO kindOf JRW jWriteNow begin <<<
abc
efg
tstWriteO kindOf JRW jWriteNow end >>>
tstCompObjRefFile */
call tstComp1 '@ tstCompObjRefFile' ,
, '$$ out .$".<.¢o1!" $$.$.<.¢ m.tstComp.1 $!',
, '$$ out .$"<$.-{o2}" $$.$.<.{ m.tstComp.2 }',
, '$$ out .$"$.<{o3}" $$.$.<{ m.tstComp.3 }',
, '$$ out .$"$.<@{out o4}" $$.$.<@{ call outO m.tstComp.4 }',
, '$$ out .$"$<@¢$$abc $$efg$!" $$.$.<@¢ $$abc ', ' ', ' $$efg $!'
/*<<tstCompObjRun
### start tst tstCompObjRun #######################################
compile @, 4 lines: $$ out .$"$@¢o1!" $$.$.@¢ $$. m.tstComp.1 $!
run without input
out .$@¢o1!
tstWriteO kindOf ORun oRun begin <<<
tstR: @<o1> isA :tstCompCla union = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
tstWriteO kindOf ORun oRun end >>>
out .$<@¢$$abc $$efg$!
tstWriteO kindOf JRW jWriteNow begin <<<
abc
efg
tstWriteO kindOf JRW jWriteNow end >>>
tstCompObjRun */
call tstComp1 '@ tstCompObjRun' ,
, '$$ out .$"$@¢o1!" $$.$.@¢ $$. m.tstComp.1 $!',
, '$$ out .$"$<@¢$$abc $$efg$!" $$.$.<@¢ $$abc ', ' ', ' $$efg $!'
m.t.trans.0 = 0
return
/*<<tstCompObj
### start tst tstCompObj ##########################################
compile @, 8 lines: o1=m.tstComp.1
run without input
out . o1
tstR: @<o1> isA :tstCompCla union = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
out .{ o2 }
tstR: @<o2> isA :tstCompCla union = o2
tstR: .FEINS = o2.1
tstR: .FZWEI = o2.fZwei
out .¢ o1, o2!
tstR: @<o1> isA :tstCompCla union = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
tstR: @<o2> isA :tstCompCla union = o2
tstR: .FEINS = o2.1
tstR: .FZWEI = o2.fZwei
tstCompObj */
call tstComp1 '@ tstCompObj' ,
, 'o1=m.tstComp.1',
, 'o2 = m.tstComp.2' ,
, '$$ out . o1 $$. o1',
, '$$ out .{ o2 } $$.{ o2 }',
, '$$ out .¢ o1, o2!$; $@<.¢ m.tstComp.1 ', ' m.tstComp.2 $!'
return
m.t.trans.0 = 0
endProcedure tstCompObj
tstCompDataIO: procedure expose m.
/*<<tstCompDataHereData
### start tst tstCompDataHereData #################################
compile =, 13 lines: herdata $@#/stop/ .
run without input
. herdata .
heredata 1 $x
heredata 2 $y
nach heredata
. herdata ¢ .
heredata 1 xValue
heredata 2 yValueY
nach heredata ¢
. herdata { .
HEREDATA 1 xValue
heredata 2 yValueY
nach heredata {
tstCompDataHereData */
call tstComp1 '= tstCompDataHereData',
, ' herdata $@#/stop/ ',
, 'heredata 1 $x',
, 'heredata 2 $y',
, '$/stop/ $$ nach heredata',
, ' herdata ¢ $@=/stop/ ',
, '$=x=xValue$=y=yValueY',
, 'heredata 1 $x',
, 'heredata 2 $y',
, '$/stop/ $$ nach heredata ¢',
, ' herdata { $@/st/',
, '; call out heredata 1 $x',
, '$$heredata 2 $y',
, '$/st/ $$ nach heredata {'
/*<<tstCompDataIO
### start tst tstCompDataIO #######################################
compile =, 5 lines: input 1 $@$.<$dsn $*+.
run without input
. input 1 .
readInp line 1 .
readInp line 2 .
. nach dsn input und nochmals mit & .
readInp line 1 .
readInp line 2 .
. und schluiss..
tstCompDataIO */
dsn = word(tstPdsMbr(tstFilename('lib37', 'r'), 'readInp'), 1)
dsnFB = dsn tstFB('::F37', 0)
b = jBuf(tstFB('readInp line 1', 37),
,tstFB('readInp line 2', 37))
extFd = tstFB('&dsn('dsn') dd(xyz)', 0)
extFd = tstFB(dsn 'dd(xyz) ::f', 0)
if extFd = '' then
extFd = dsn
call jCat file(dsnFB), b
call envPut 'dsn', dsn
call tstComp1 '= tstCompDataIO',
, ' input 1 $@$.<$dsn $*+',
, tstFB('::f', 0),
, ' nach dsn input und nochmals mit & ' ,
, ' $@$.<' extFD,
, ' und schluiss.'
return
endProcedure tstCompDataIO
tstObjVF: procedure expose m.
parse arg v, f
obj = oNew(classNew('n TstClassVF u v, f FLD1 v'))
m.obj = if(f=='','val='v, v)
m.obj.fld1 = if(f=='','FLD1='v, f)
return obj
endProcedure tstObjVF
tstCompFile: procedure expose m.
/*<<tstCompFileBloSrc
$=vv=value-of-vv
###file from empty # block
$@<#¢
$!
###file from 1 line # block
$@<#¢
the only $ix+1/0 line $vv
$!
###file from 2 line # block
$@<#¢
first line /0 $*+ no comment
second and last line $$ $wie
$!
===file from empty = block
$@<=¢ $*+ comment
$!
===file from 1 line = block
$@<=¢ the only line $!
===file from 2 line = block
$@<=¢ first line$** comment
second and last line $!
---file from empty - block
$@<-/s/
$/s/
---file from 1 line - block
$@<-/s/ the only "line" (1*1) $/s/
---file from 2 line = block
$@<-// first "line" (1+0)
second and "last line" (1+1) $//
...file from empty . block
$@<.¢
$!
...file from 1 line . block
$@<.¢ tstObjVF('v-Eins', '1-Eins') $!
...file from 2 line . block
$@<.¢ tstObjVF('v-Elf', '1-Elf')
tstObjVF('zwoelf') $!
...file from 3 line . block
$@<.¢ tstObjVF('einUndDreissig')
s2o('zweiUndDreissig' o2String($vv))
tstObjVF('dreiUndDreissig') $!
@@@file from empty @ block
$@<@¢
$!
$=noOutput=before
@@@file from nooutput @ block
$@<@¢ nop
$=noOutput = run in block $!
@@@nach noOutput=$noOutput
@@@file from 1 line @ block
$@<@¢ $$. tstObjVF('w-Eins', 'w1-Eins') $!
@@@file from 2 line @ block
$@<@¢ $$.tstObjVF('w-Elf', 'w1-Elf')
y='zwoelf' $$-y $!
@@@file from 3 line @ block
$@<@¢ $$.tstObjVF('w einUndDreissig') $$ +
zweiUndDreissig $$ 33 $vv$!
{{{ empty { block
$@<{ }
{{{ empty { block with comment
$@<{ $*+.
}
{{{ one line { block
$@<{ the only $"{...}" line $*+.
$vv }
{{{ one line -{ block
$@<-{ the only $"-{...}" "line" $vv }
{{{ empty #{ block
$@<#{ }
{{{ one line #{ block
$@<#{ the only $"-{...}" "line" $vv ${vv${x}} }
tstCompFileBloSrc */
/*<<tstCompFileBlo
### start tst tstCompFileBlo ######################################
compile =, 70 lines: $=vv=value-of-vv
run without input
###file from empty # block
###file from 1 line # block
the only $ix+1/0 line $vv
###file from 2 line # block
first line /0 $*+ no comment
second and last line $$ $wie
===file from empty = block
===file from 1 line = block
. the only line .
===file from 2 line = block
. first line
second and last line .
---file from empty - block
---file from 1 line - block
THE ONLY line 1
---file from 2 line = block
FIRST line 1
SECOND AND last line 2
...file from empty . block
...file from 1 line . block
tstR: @LINE isA :TstClassVF union = v-Eins
tstR: .FLD1 = 1-Eins
...file from 2 line . block
tstR: @LINE isA :TstClassVF union = v-Elf
tstR: .FLD1 = 1-Elf
tstR: @LINE isA :TstClassVF union = val=zwoelf
tstR: .FLD1 = FLD1=zwoelf
...file from 3 line . block
tstR: @LINE isA :TstClassVF union = val=einUndDreissig
tstR: .FLD1 = FLD1=einUndDreissig
zweiUndDreissig value-of-vv
tstR: @LINE isA :TstClassVF union = val=dreiUndDreissig
tstR: .FLD1 = FLD1=dreiUndDreissig
@@@file from empty @ block
@@@file from nooutput @ block
@@@nach noOutput=run in block
@@@file from 1 line @ block
tstR: @LINE isA :TstClassVF union = w-Eins
tstR: .FLD1 = w1-Eins
@@@file from 2 line @ block
tstR: @LINE isA :TstClassVF union = w-Elf
tstR: .FLD1 = w1-Elf
zwoelf
@@@file from 3 line @ block
tstR: @LINE isA :TstClassVF union = val=w einUndDreissig
tstR: .FLD1 = FLD1=w einUndDreissig
zweiUndDreissig
33 value-of-vv
{{{ empty { block
{{{ empty { block with comment
{{{ one line { block
the only {...} line value-of-vv
{{{ one line -{ block
THE ONLY -{...} line value-of-vv
{{{ empty #{ block
. .
{{{ one line #{ block
. the only $"-{...}" "line" $vv ${vv${x}} .
tstCompFileBlo */
call tstComp2 'tstCompFileBlo', '='
m.t.trans.0 = 0
/*<<tstCompFileObjSrc
$=vv=value-vv-1
$=fE=.$.<¢ $!
$=f2=.$.<.¢s2o("f2 line 1" o2String($vv))
tstObjVF("f2 line2") $!
---empty file $"$@<$fE"
$@$fE
---file with 2 lines $"$@<$f2"
$@<.$f2
$=vv=value-vv-2
---file with 2 lines $"$@<$f2"
$@<.$f2
$= dsn =- word(tstPdsMbr(tstFilename('libvb', 'r'), 'fileObj'),1) +
tstFB('::V', 0)
$@¢
fi=jOpen(file($dsn),'>')
call jWrite fi, 'line one on' $"$dsn"
call jWrite fi, 'line two on' $"$dsn"
call jClose fi
$!
---file on disk out
$@$.<$dsn
tstCompFileObjSrc */
/*<<tstCompFileObj
### start tst tstCompFileObj ######################################
compile =, 20 lines: $=vv=value-vv-1
run without input
---empty file $@<$fE
---file with 2 lines $@<$f2
f2 line 1 value-vv-1
tstR: @LINE isA :TstClassVF union = val=f2 line2
tstR: .FLD1 = FLD1=f2 line2
---file with 2 lines $@<$f2
f2 line 1 value-vv-2
tstR: @LINE isA :TstClassVF union = val=f2 line2
tstR: .FLD1 = FLD1=f2 line2
---file on disk out
line one on $dsn
line two on $dsn
tstCompFileObj */
call tstComp2 'tstCompFileObj', '='
return
endProcedure tstCompFile
tstCompPipe: procedure expose m.
/*<<tstCompPipe1
### start tst tstCompPipe1 ########################################
compile @, 1 lines: call pipePreSuf "(1 ", " 1)"
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
(1 eins zwei drei 1)
#jIn 2# zehn elf zwoelf?
(1 zehn elf zwoelf? 1)
#jIn 3# zwanzig 21 22 23 24 ... 29|
(1 zwanzig 21 22 23 24 ... 29| 1)
#jIn eof 4#
tstCompPipe1 */
call tstComp1 '@ tstCompPipe1 3',
, ' call pipePreSuf "(1 ", " 1)"'
/*<<tstCompPipe2
### start tst tstCompPipe2 ########################################
compile @, 2 lines: call pipePreSuf "(1 ", " 1)"
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
#jIn 2# zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
¢2 (1 eins zwei drei 1) 2!
¢2 (1 zehn elf zwoelf? 1) 2!
¢2 (1 zwanzig 21 22 23 24 ... 29| 1) 2!
tstCompPipe2 */
call tstComp1 '@ tstCompPipe2 3',
, ' call pipePreSuf "(1 ", " 1)"' ,
, ' $| call pipePreSuf "¢2 ", " 2!"'
/*<<tstCompPipe3
### start tst tstCompPipe3 ########################################
compile @, 3 lines: call pipePreSuf "(1 ", " 1)"
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
#jIn 2# zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
<3 ¢2 (1 eins zwei drei 1) 2! 3>
<3 ¢2 (1 zehn elf zwoelf? 1) 2! 3>
<3 ¢2 (1 zwanzig 21 22 23 24 ... 29| 1) 2! 3>
tstCompPipe3 */
call tstComp1 '@ tstCompPipe3 3',
, ' call pipePreSuf "(1 ", " 1)"' ,
, ' $| call pipePreSuf "¢2 ", " 2!"',
, ' $| call pipePreSuf "<3 ", " 3>"'
/*<<tstCompPipe4
### start tst tstCompPipe4 ########################################
compile @, 7 lines: call pipePreSuf "(1 ", " 1)"
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
#jIn 2# zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
<3 ¢222 ¢221 ¢21 ¢20 (1 eins zwei drei 1) 20! 21! 221! 222! 3>
<3 ¢222 ¢221 ¢21 ¢20 (1 zehn elf zwoelf? 1) 20! 21! 221! 222! 3>
<3 ¢222 ¢221 ¢21 ¢20 (1 zwanzig 21 22 23 24 ... 29| 1) 20! 21! 221!+
. 222! 3>
tstCompPipe4 */
call tstComp1 '@ tstCompPipe4 3',
, ' call pipePreSuf "(1 ", " 1)"' ,
, ' $| $@¢ call pipePreSuf "¢20 ", " 20!"',
, ' $| call pipePreSuf "¢21 ", " 21!"',
, ' $| $@¢ call pipePreSuf "¢221 ", " 221!"',
, ' $| call pipePreSuf "¢222 ", " 222!"',
, '$! $! ',
, ' $| call pipePreSuf "<3 ", " 3>"'
return
endProcedure tstCompPipe
tstCompRedir: procedure expose m.
/*<<tstCompRedir
### start tst tstCompRedir ########################################
compile @, 6 lines: $>}eins $@for vv $$<$vv> $; .
run without input
#jIn eof 1#
output eins .
output piped zwei .
run with 3 inputs
#jIn 1# eins zwei drei
#jIn 2# zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
output eins <eins zwei drei> <zehn elf zwoelf?> <zwanzig 21 22 23 2+
4 ... 29|>
output piped zwei ab<eins zwei drei>yz ab<zehn elf zwoelf?>yz ab<zw+
anzig 21 22 23 24 ... 29|>yz
tstCompRedir */
call pipeIni
call envRemove 'eins' /* alte Variable loswerden */
dsn = word(tstPdsMbr(tstFilename('libvb', 'r'), 'redir1'), 1)
call envPut 'dsn', dsn
call tstComp1 '@ tstCompRedir 3' ,
, ' $>}eins $@for vv $$<$vv> $; ',
, ' $$ output eins $-=¢$@$eins$!$; ',
, ' $@for ww $$b${ww}y ',
, ' $>$-{ $dsn } 'tstFB('::v', 0),
, '$| call pipePreSuf "a", "z" $<}eins',
, ' $; $$ output piped zwei $-=¢$@<$dsn$! '
return
endProcedure tstCompRedir
tstCompComp: procedure expose m.
/*<<tstCompCompShell
### start tst tstCompCompShell ####################################
compile @, 5 lines: $$compiling shell $; $= rrr =. $.compile@ $<#/+
aaa/
run without input
compiling shell
running einmal
RUN 1 COMPILED einmal
#jIn eof 1#
running zweimal
RUN 1 COMPILED zweimal
#jIn eof 2#
run with 3 inputs
compiling shell
running einmal
RUN 1 COMPILED einmal
#jIn 1# eins zwei drei
compRun eins zwei dreieinmal
#jIn 2# zehn elf zwoelf?
compRun zehn elf zwoelf?einmal
#jIn 3# zwanzig 21 22 23 24 ... 29|
compRun zwanzig 21 22 23 24 ... 29|einmal
#jIn eof 4#
running zweimal
RUN 1 COMPILED zweimal
#jIn eof 5#
tstCompCompShell */
call tstComp1 '@ tstCompCompShell 3',
, "$$compiling shell $; $= rrr =. $.compile@ $<#/aaa/",
, "call out run 1*1*1 compiled $cc; $@for v $$ compRun $v$cc",
, "$/aaa/ $;",
, "$=cc=einmal $$ running $cc $@$rrr",
, "$=cc=zweimal $$ running $cc $@$rrr"
/*<<tstCompCompData
### start tst tstCompCompData #####################################
compile @, 5 lines: $$compiling data $; $= rrr =. $.compile= +
$<#/aaa/
run without input
compiling data
running einmal
call out run 1*1*1 compiled einmal
running zweimal
call out run 1*1*1 compiled zweimal
run with 3 inputs
compiling data
running einmal
call out run 1*1*1 compiled einmal
running zweimal
call out run 1*1*1 compiled zweimal
tstCompCompData */
call tstComp1 '@ tstCompCompData 3',
, "$$compiling data $; $= rrr =. $.compile= $<#/aaa/",
, "call out run 1*1*1 compiled $cc",
, "$/aaa/ $;",
, "$=cc=einmal $$ running $cc $@$rrr",
, "$=cc=zweimal $$ running $cc $@$rrr"
return
endProcedure tstCompComp
tstCompDir: procedure expose m.
/*<<tstCompDirSrc
'in src v1='$v1
$#@ call out 'src @ out v1='$v1
$#. s2o('src . v1=')
$v1
$#- 'src - v1='$v1
$#= src = v1=$v1
tstCompDirSrc */
/*<<tstCompDir
### start tst tstCompDir ##########################################
compile call out 'before v1='$v1 $=v1=eins $#. s2o('. v1='$-$v1) $#+
@ call out '@ v1='$v1 $#= = v1=$v1 $#- '- v1='$v1, 6 lines: 'in src+
. v1='$v1
run without input
before v1=v1Before
.. v1=eins
@ v1=eins
. = v1=eins .
- v1=eins
in src v1=eins
src @ out v1=eins
src . v1=
eins
src - v1=eins
. src = v1=eins
tstCompDir */
call envPut 'v1', 'v1Before'
call tstComp2 'tstCompDir', "call out 'before v1='$v1 $=v1=eins" ,
"$#. s2o('. v1='$-$v1) $#@ call out '@ v1='$v1" ,
"$#= = v1=$v1 $#- '- v1='$v1"
/*<<tstCompDirPiSrc
zeile 1 v1=$v1
zweite Zeile vor $"$@$#-"
$@$#-
$'zeile drei nach $@$#- v1='v1
vierte und letzte Zeile
tstCompDirPiSrc */
/*<<tstCompDirPi
### start tst tstCompDirPi ########################################
compile call pipePreSuf '<','>' $=v1=eiPi $<.$.$#=, 5 lines: zeile +
1 v1=$v1
run without input
<zeile 1 v1=eins>
<zweite Zeile vor $@$#->
<zeile drei nach $@$#- v1=V1>
<VIERTE UND LETZTE ZEILE>
tstCompDirPi */
call tstComp2 'tstCompDirPi',
, "call pipePreSuf '<','>' $=v1=eiPi $<.$.$#="
return
endProcedure tstCompDir
/* copx tstComp end *************************************************/
/* copx tstBase begin **************************************************
test the basic classes
***********************************************************************/
tstBase: procedure expose m.
call tstTstSay
call oIni
call tstM
call tstMap
call tstMapVia
call tstClass
call tstClass2
call tstO
call jIni
call tstJSay
call tstJ
call tstJ2
call catIni
call tstCat
call pipeIni
CALL TstEnv
CALL TstEnvCat
call tstPipe
call tstEnvVars
call tstTotal
call tstPipeLazy
call tstEnvClass
call tstFile /* reimplent zOs ||| */
call tstFileList
call tstFmt
call tstTotal
call scanIni
call tstScan
call ScanReadIni
call tstScanRead
call tstScanWin
call tstScanSQL
call tstTotal
return
endProcedure tstBase
/*--- test the tst Module, check the output visually ----------------*/
tstTstSay: procedure expose m.
call tstIni
oldErr = m.tst.err
oldNames = m.tst.errNames
say '+++ tstTstSay start with' oldErr 'totErrs and',
m.tst.tests 'tests'
/*<<tstTstSayEins
### start tst tstTstSayEins #######################################
test eins einzige testZeile
tstTstSayEins */
call tst x, 'tstTstSayEins'
call tstOut x, "test eins einzige testZeile"
call tstEnd x, 'err 0'
/*<<tstTstSayZwei
### start tst tstTstSayZwei #######################################
zwei 1. testZeile
zwei 2. und letzte testZeile
tstTstSayZwei */
call tst x, 'tstTstSayZwei'
call tstOut x, "zwei 1. testZeile"
call tstOut x, "zwei 2. und letzte testZeile"
call tstEnd x, 'err 0'
call tst x, 'tstTstSayZwei'
call tstOut x, "zwei 1. testZeile " /* ein space zuviel */
call tstOut x, "zwei 2. und letzte testZeile"
call tstOut x, "zwei 3. zuviel"
call tstEnd x, 'err 3'
/*<<tstTstSayDrei
### start tst tstTstSayDrei #######################################
drei 1. testZeile vor empty Zeile
..
drei 3. testZeile vor 10 space
. .
drei 5. testZeile ziemlich lang 66 +
. 77 5 10 15++++++++++++++++++++
.+++++++++++++++++++++++++++++++++++++++++++.
tstTstSayDrei */
call tst y, 'tstTstSayDrei'
call tstOut y, 'drei 1. testZeile vor empty Zeile'
call tstOut y, ''
call tstOut y, 'drei 3. testZeile vor 10 space'
call tstOut y, left('', 10)
call tstOut y, 'drei 5. testZeile ziemlich lang',
left(66, 66) left('77 5 10 15', 77, '+')
call tstEnd y, 'err 0'
if m.y.err <> 0 then
call err '+++ tstTstSay errs' m.x.err 'expected' 0
if m.tst.err <> oldErr + 3 then
call err '+++ tstTstSay totErrs' m.tst.err 'expected' 3
say '+++ tstTstSay end Ok with' m.tst.err 'totErrs and' ,
m.tst.tests 'tests'
m.tst.err = oldErr
m.tst.errNames = oldNames
return
endProcedure tstTstSay
tstM: procedure expose m.
/*<<tstM
### start tst tstM ################################################
symbol m.b LIT
mInc b 2 m.b 2
symbol m.a LIT
mAdd a A.2
mAdd a A.3
m.a: 3: 1=eins 2=zwei 3=drei 4=M.A.4
m.c: 5: 1=c vorAddSt a 2=eins 3=zwei 4=drei 5=c nacAddSt a 6=M.C.6
tstMSubj1 tstMSubj1 added listener 1
tstMSubj1 notified list1 1 arg tstMSubj1 registered list
tstMSubj1 notified list1 1 arg tstMSubj1 notify 11
tstMSubj1 tstMSubj1 added listener 2
tstMSubj1 notified list2 2 arg tstMSubj1 registered list
tstMSubj1 notified list1 1 arg tstMSubj1 notify 12
tstMSubj1 notified list2 2 arg tstMSubj1 notify 12
tstMSubj2 tstMSubj2 added listener 1
tstMSubj2 notified list1 1 arg tstMSubj2 registered list
tstMSubj2 tstMSubj2 added listener 2
tstMSubj2 notified list2 2 arg tstMSubj2 registered list
tstMSubj1 notified list1 1 arg tstMSubj1 notify 13
tstMSubj1 notified list2 2 arg tstMSubj1 notify 13
tstMSubj2 notified list1 1 arg tstMSubj2 notify 24
tstMSubj2 notified list2 2 arg tstMSubj2 notify 24
tstM */
drop m.b m.a m.a.0 m.a.1 m.a.2
call tst t, 'tstM'
call tstOut t, 'symbol m.b' symbol('m.b')
m.b = 1
call tstOut t, 'mInc b' mInc(b) 'm.b' m.b
call tstOut t, 'symbol m.a' symbol('m.a')
call tstOut t, 'mAdd a' mAdd(mCut(a, 0), 'eins', 'zwei')
call tstOut t, 'mAdd a' mAdd(a, 'drei')
call tstOut t, 'm.a:' m.a.0': 1='m.a.1 '2='m.a.2 '3='m.a.3 '4='m.a.4
call mAdd mCut(c, 0), 'c vorAddSt a'
call mAddSt c, a
call mAdd c, 'c nacAddSt a'
call tstOut t, 'm.c:' m.c.0': 1='m.c.1 '2='m.c.2 '3='m.c.3,
'4='m.c.4 '5='m.c.5 '6='m.c.6
s1 = 'tstMSubj1'
s2 = 'tstMSubj2'
/* we must unregister for the second test */
drop m.m.subLis.s1 m.m.subLis.s1.0 m.m.subLis.s2 m.m.subLis.s2.0
call mRegisterSubject s1,
, 'call tstOut t, "'s1'" subject "added listener" listener;',
'call mNotify1 "'s1'", listener, "'s1' registered list"'
call mRegister s1,
, 'call tstOut t, subject "notified list1" listener "arg" arg'
call mNotify s1, s1 'notify 11'
call mRegister s1,
, 'call tstOut t, subject "notified list2" listener "arg" arg'
call mRegister s2,
, 'call tstOut t, subject "notified list1" listener "arg" arg'
call mRegister s2,
, 'call tstOut t, subject "notified list2" listener "arg" arg'
call mNotify s1, s1 'notify 12'
call mRegisterSubject s2,
, 'call tstOut t, "'s2'" subject "added listener" listener;',
'call mNotify1 "'s2'", listener, "'s2' registered list"'
call mNotify s1, s1 'notify 13'
call mNotify s2, s2 'notify 24'
call tstEnd t
return
endProcedure tstM
tstMap: procedure expose m.
/*<<tstMap
### start tst tstMap ##############################################
mapNew m keys m-keys 0
map m zwei --> 2
map m Zwei is not defined
map stem m-keys 4
map m eins --> 1
map m zwei --> 2
map m drei --> 3
map m vier --> 4
*** err: duplicate key eins in map m
map m zwei is not defined
q 2 zw dr
map stem Q 2
map Q zw --> 2Q
map Q dr --> 3Q
map stem m 3
map m eins --> 1
map m zwei --> 2PUT
map m vier --> 4PUT
*** err: duplicate key zwei in map m
tstMapLong eins keys 3
tstMapLong zweiMal keys 48
tstMapLong dreiMal keys 93
tstMapLong vier keys 138
tstMapLong <fuenf> keys 188
tstMap clear keys 0
inline1 3
inline1 1 == inline1 eins==
inline1 2 ====
inline1 3 == inline1 drei==
inline2 1 1 == inline2 eins==
inline3 nicht gefunden
tstMap */
/*<<tstMapInline1
inline1 eins
inline1 drei
tstMapInline1 */
/*<<tstMapInline2
inline2 eins
tstMapInline2 */
call tst t, 'tstMap'
m = mapNew('K')
ky = mapKeys(m)
call mAdd t'.TRANS', m 'm', ky 'm-keys'
call tstOut t, 'mapNew' m 'keys' ky m.ky.0
call mapAdd m, 'eins', 1
call mapAdd m, 'zwei', 2
call mapAdd m, 'drei', 3
call mapAdd m, 'vier', 4
call tstMapShow m, 'zwei'
call tstMapShow m, 'Zwei'
call tstMapShowSt m, mapKeys(m)
call mapAdd m, 'eins', 1
call mapReset m, '='
call tstMapShow m, 'zwei'
call mapAdd m, 'eins', 1
call mapAdd m, 'zwei', 2
call mapPut m, 'zwei', 2Put
call mapPut m, 'vier', 4Put
call mapReset q, '='
call mapAdd q, 'zw', 2q
call mapAdd q, 'dr', 3q
call tstOut t, 'q' m.q.0 m.q.1 m.q.2
call tstMapShowSt q, mapKeys(q)
call tstMapShowSt m, mapKeys(m)
call mapAdd m, 'zwei', 2addDup
call tstMapLong m, 'eins' ,201, 2000, -2, 2
call tstMapLong m, 'zweiMal' ,201, 2000, -2, 2
call tstMapLong m, 'dreiMal' ,201, 2000, 2,-2
call tstMapLong m, 'vier ' ,2010, 201, -2, 2
call tstMapLong m, '<fuenf>' ,2010, 201, 2,-2
call mapClear m
keys = mapKeys(m)
call tstOut t, 'tstMap clear keys' m.keys.0
i = mapInline('tstMapInline1')
call tstOut t, 'inline1' m.i.0
do x=1 to m.i.0
call tstOut t, 'inline1' x '=='m.i.x'=='
end
i = mapInline('tstMapInline2')
call tstOut t, 'inline2' m.i.0 '1 =='m.i.1'=='
call tstOut t, 'inline3' mapInline('tstMapInline3',
, 'nicht gefunden')
call tstEnd t
return
endProcedure tstMap
tstMapLong: procedure expose m.
parse arg m, w, f1, t1, f2, t2
if f1 < t1 then
b1 = 201
else
b1 = -201
if f2 < t2 then
b2 = 1
else
b2 = -1
lo = copies(w, 2100 % length(w))
keys = mapKeys(m)
keyCn = m.keys.0
call tstOut t, 'tstMapLong' w 'keys' keyCn
do x = f1 by b1 to t1
do y = x+f2 by b2 to x+t2
k = left(lo, y)
if mapHasKey(m, k) then
call err 'mapLong hasKey before' w y
call mapAdd m, k, w y
if \ mapHasKey(m, k) then
call err 'mapLong \ hasKey after' w y
if mapGet(m, k) \== w y then
call err 'mapLong \ get <> ' w y
keys = mapKeys(m)
if keyCn + 1 \= m.keys.0 then
call err 'mapLong keys .0 <> ' w y
keyCn = m.keys.0
if k \== m.keys.keyCn then
call err 'mapLong keys . ' keyCn '<>' w y
end
end
return
endProcedure tstMapLong
tstMapVia: procedure expose m.
/*<<tstMapVia
### start tst tstMapVia ###########################################
map M K --> A
mapVia(m, K) A
*** err: missing m.A at 3 in mapVia(M, K|)
mapVia(m, K|) M.A
mapVia(m, K|) valAt m.a
mapVia(m, K|) valAt m.a
*** err: missing m.A.aB at 5 in mapVia(M, K|aB)
mapVia(m, K|aB) M.A.aB
mapVia(m, K|aB) valAt m.A.aB
*** err: missing m.valAt m.a at 4 in mapVia(M, K||)
mapVia(m, K||) M.valAt m.a
mapVia(m, K||) valAt m.valAt m.a
mapVia(m, K||F) valAt m.valAt m.a.F
tstMapVia */
call tst t, 'tstMapVia'
u = 'A.aB'
v = 'valAt m.a'
drop m.a m.u m.v m.v.f
call mapReset m, 'K'
call mapAdd m, k, a
call tstMapShow m, k
call tstOut t, 'mapVia(m, K) ' mapVia(m, 'K')
call tstOut t, 'mapVia(m, K|) ' mapVia(m, 'K|')
m.a = v
call tstOut t, 'mapVia(m, K|) ' mapVia(m, 'K|')
call tstOut t, 'mapVia(m, K|) ' mapVia(m, 'K|')
call tstOut t, 'mapVia(m, K|aB) ' mapVia(m, 'K|aB')
m.u = 'valAt m.'u
call tstOut t, 'mapVia(m, K|aB) ' mapVia(m, 'K|aB')
call tstOut t, 'mapVia(m, K||) ' mapVia(m, 'K||')
v = m.a
m.v = 'valAt m.'v
m.v.f = 'valAt m.'v'.F'
call tstOut t, 'mapVia(m, K||) ' mapVia(m, 'K||')
call tstOut t, 'mapVia(m, K||F) ' mapVia(m, 'K||F')
call tstEnd t
return
endProcedure tstMapVia
tstMapShow: procedure expose m.
parse arg a, key
if mapHasKey(a, key) then
call tstOut t, 'map' a key '-->' mapGet(a, key)
else
call tstOut t, 'map' a key 'is not defined'
return
endProcedure tstMapShow
tstMapShowSt: procedure expose m.
parse arg a, st
call tstOut t, 'map stem' st m.st.0
do wx=1 to m.st.0
call tstMapShow a, m.st.wx
end
return
endProcedure tstMapShow
tstClass2: procedure expose m.
/*<<tstClass2old
### start tst tstClass2 ###########################################
@CLASS.8 isA :class union
. choice n union
. .NAME = class
. .CLASS refTo @CLASS.7 :class union
. choice u stem 9
. .1 refTo @CLASS.15 :class union
. choice c union
. .NAME = v
. .CLASS refTo @CLASS.3 :class union
. choice v = v
. .2 refTo @CLASS.16 :class union
. choice c union
. .NAME = r
. .CLASS refTo @CLASS.11 :class union
. choice f union
. .NAME = CLASS
. .CLASS refTo @CLASS.10 :class union
. choice r .CLASS refTo @CLASS.8 done :class @CLASS.8
. .3 refTo @CLASS.17 :class union
. choice c union
. .NAME = s
. .CLASS refTo @CLASS.11 done :class @CLASS.11
. .4 refTo @CLASS.19 :class union
. choice c union
. .NAME = u
. .CLASS refTo @CLASS.18 :class union
. choice s .CLASS refTo @CLASS.10 done :class @CLASS.10
. .5 refTo @CLASS.20 :class union
. choice c union
. .NAME = f
. .CLASS refTo @CLASS.12 :class union
. choice u stem 2
. .1 refTo @CLASS.9 :class union
. choice f union
. .NAME = NAME
. .CLASS refTo @CLASS.3 done :class @CLASS.3
. .2 refTo @CLASS.11 done :class @CLASS.11
. .6 refTo @CLASS.21 :class union
. choice c union
. .NAME = n
. .CLASS refTo @CLASS.12 done :class @CLASS.12
. .7 refTo @CLASS.22 :class union
. choice c union
. .NAME = c
. .CLASS refTo @CLASS.12 done :class @CLASS.12
. .8 refTo @CLASS.23 :class union
. choice c union
. .NAME = m
. .CLASS refTo @CLASS.14 :class union
. choice u stem 2
. .1 refTo @CLASS.9 done :class @CLASS.9
. .2 refTo @CLASS.13 :class union
. choice f union
. .NAME = MET
. .CLASS refTo @CLASS.3 done :class @CLASS.3
. .9 refTo @CLASS.26 :class union
. choice c union
. .NAME = w
. .CLASS refTo @CLASS.25 :class union
. choice n union
. .NAME = w
. .CLASS refTo @CLASS.24 :class union
. choice r .CLASS refTo @CLASS.3 done :class @CLASS.3
tstClass2old */
/*<<tstClass2
### start tst tstClass2 ###########################################
@CLASS.13 isA :class union
. choice n union
. .NAME = class
. .CLASS refTo @CLASS.12 :class union
. choice u stem 10
. .1 refTo @CLASS.20 :class union
. choice c union
. .NAME = v
. .CLASS refTo @CLASS.3 :class union
. choice v = v
. .2 refTo @CLASS.22 :class union
. choice c union
. .NAME = w
. .CLASS refTo @CLASS.21 :class union
. choice w } LASS.21
. .3 refTo @CLASS.23 :class union
. choice c union
. .NAME = o
. .CLASS refTo @CLASS.10 :class union
. choice o obj has no class @o
. .4 refTo @CLASS.24 :class union
. choice c union
. .NAME = r
. .CLASS refTo @CLASS.16 :class union
. choice f union
. .NAME = CLASS
. .CLASS refTo @CLASS.15 :class union
. choice r .CLASS refTo @CLASS.13 done :class @CLASS.13
. .5 refTo @CLASS.25 :class union
. choice c union
. .NAME = s
. .CLASS refTo @CLASS.16 done :class @CLASS.16
. .6 refTo @CLASS.27 :class union
. choice c union
. .NAME = u
. .CLASS refTo @CLASS.26 :class union
. choice s .CLASS refTo @CLASS.15 done :class @CLASS.15
. .7 refTo @CLASS.28 :class union
. choice c union
. .NAME = f
. .CLASS refTo @CLASS.17 :class union
. choice u stem 2
. .1 refTo @CLASS.14 :class union
. choice f union
. .NAME = NAME
. .CLASS refTo @CLASS.3 done :class @CLASS.3
. .2 refTo @CLASS.16 done :class @CLASS.16
. .8 refTo @CLASS.29 :class union
. choice c union
. .NAME = n
. .CLASS refTo @CLASS.17 done :class @CLASS.17
. .9 refTo @CLASS.30 :class union
. choice c union
. .NAME = c
. .CLASS refTo @CLASS.17 done :class @CLASS.17
. .10 refTo @CLASS.31 :class union
. choice c union
. .NAME = m
. .CLASS refTo @CLASS.19 :class union
. choice u stem 2
. .1 refTo @CLASS.14 done :class @CLASS.14
. .2 refTo @CLASS.18 :class union
. choice f union
. .NAME = MET
. .CLASS refTo @CLASS.3 done :class @CLASS.3
tstClass2 */
call oIni
call tst t, 'tstClass2'
call classOut , m.class.class
call tstEnd t
return
endProcedure tstClass2
tstClass: procedure expose m.
/*<<tstClass
### start tst tstClass ############################################
Q n =className= tstClassTf12
Q.eins.zwei v ==> M.Q.eins.zwei
*** err: basicClass v end of Exp expected: v tstClassTf12 .
R n =className= uststClassTf12
R n =className= uststClassTf12in
R n =className= tstClassTf12
R.eins.zwei v ==> M.R.eins.zwei
R s =stem.0= 2
R.1 r ==> M.R.1
R.1 n =className= tstClassTf12
R.1.eins.zwei v ==> M.R.1.eins.zwei
R.2 r ==> M.R.2
R.2 n =className= tstClassTf12
R.2.eins.zwei v ==> M.R.2.eins.zwei
S s =stem.0= 2
S.1.eins v ==> M.S.1.eins
S.1 m =met-metA--> say "metA"
S.1 m =met-metB--> say "metB"
S.2.zwei v ==> M.S.2.zwei
S.2 m =met-metA--> say "metA"
S.2 m =met-metB--> say "metB"
class of mutate qq tstClassTf12
tstClass */
f = 'eins.zwei'
e = 'eins'
z = 'zwei'
drop m.q.f m.r.f m.r.0 m.r.1 m.r.1.f m.r.2 m.r.2.f
drop m.s.0 m.s.1 m.s.1.e m.s.2 m.s.2.z
call classIni
call tst t, 'tstClass'
t1 = classNew('n tstClassTf12 f eins f zwei v')
call tstClassOut t, t1, q
z = m.class.0
errDef = 'n tstClassB n tstClassC u tstClassTf12,' ,
's u v tstClassTf12'
if class4name(errDef, ' ') == ' ' then
t2 = classNew(errDef)
else /* the second time we do not get the error anymore,
because the err did not abend | */
call tstOut t,'*** err: basicClass v' ,
'end of Exp expected: v tstClassTf12 '
t2 = classNew('n uststClassTf12 n uststClassTf12in u tstClassTf12',
, classNew('s u r, tstClassTf12'))
m.r.0 = 2
call tstClassOut t, t2, r
t3 = classNew('s u c 1 f eins v, c 2 f zwei v',
,'m', 'metA say "metA"', 'metB say "metB"')
m.s.0 = 2
m.s.1 = 1
m.s.2 = 2
call tstClassOut t, t3, s
call oMutate qq, 'tstClassTf12'
tt = objClass(qq)
call tstOut t, 'class of mutate qq' m.tt.name
call tstEnd t
return
endProcedure tstClass
tstClassOut: procedure expose m.
parse arg o, t, a
if pos(m.t, 'vr') > 0 then
return tstOut(o, a m.t '==>' m.a)
if m.t == 'n' then do
call tstOut o, a m.t '=className=' m.t.name
return tstClassOut(o, m.t.class, a)
end
if m.t == 'f' then
return tstClassOut(o, m.t.class, a'.'m.t.name)
if m.t = 'u' then do
do ux=1 to m.t.0
call tstClassOut o, m.t.ux, a
end
return 0
end
if m.t = 's' then do
call tstOut o, a m.t '=stem.0=' m.a.0
do ux=1 to m.a.0
call tstClassOut o, m.t.class, a'.'ux
end
return 0
end
if m.t = 'c' then do
if m.t.name = m.a then
call tstClassOut o, m.t.class, a
return 0
end
if m.t = 'm' then
return tstOut(o, a m.t '=met-'m.t.name'-->' m.t.met)
call err 'bad class type' m.t
endProcedure tstClassOut
tstO: procedure expose m.
/*<<tstO
### start tst tstO ################################################
class method calls of TstOEins
. met Eins.eins M
FLDS of <obj e of TstOEins> .FEINS, .FZWEI
methodcalls of object e of TstOEins
. met Eins.eins <obj e of TstOEins>
. met Eins.zwei <obj e2 of TstOEins>
*** err: no method nein in class TstOEins of object <obj e+
. of TstOEins>
*** err: no class found for object noObj
class method calls of TstOEins
. met Elf.zwei M
FLDS of <obj f of TstOElf> .FEINS, .FZWEI, .FELF
methodcalls of object f of TstOElf
. met Eins.eins <obj f of TstOElf>
. met Elf.zwei <obj f of TstOElf>
. met Elf.drei <obj f of TstOElf>
methodcalls of object f cast To TstOEins
. met Eins.eins <obj f of TstOElf>
. met Eins.zwei <obj f of TstOElf>
FLDS of <cast(f, TstOEins)> .FEINS, .FZWEI
oCopy c1 of class TstOEins, c2
C1 n =className= TstOEins
C1.FEINS v ==> M.C1.FEINS
C1.FZWEI v ==> M.C1.FZWEI
C1 m =met-eins--> call tstOut t, " met Eins.eins" m
C1 m =met-zwei--> call tstOut t, " met Eins.zwei" m
C2 n =className= TstOEins
C2.FEINS v ==> M.C1.FEINS
C2.FZWEI v ==> M.C1.FZWEI
C2 m =met-eins--> call tstOut t, " met Eins.eins" m
C2 m =met-zwei--> call tstOut t, " met Eins.zwei" m
oCopy c3 of class TstOElf, c4
C4 n =className= TstOElf
C4 n =className= TstOEins
C4.FEINS v ==> M.C3.FEINS
C4.FZWEI v ==> M.C3.FZWEI
C4 m =met-eins--> call tstOut t, " met Eins.eins" m
C4 m =met-zwei--> call tstOut t, " met Eins.zwei" m
C4.FELF r ==> M.C3.FELF
C4 m =met-zwei--> call tstOut t, " met Elf.zwei" m
C4 m =met-drei--> call tstOut t, " met Elf.drei" m
tEinsDop <class TstOEins>
oRun 7*3 21
oRun 12*12 144
tstO */
call tst t, 'tstO'
tEins = classNew('n TstOEins u f FEINS v,f FZWEI v', 'm',
, 'eins call tstOut t, " met Eins.eins" m',
, 'zwei call tstOut t, " met Eins.zwei" m')
call mAdd t.trans, tEins '<class TstOEins>'
call tstOut t, 'class method calls of TstOEins'
interpret classMet('TstOEins', 'eins')
e = oNew('TstOEins')
e2 = oNew('TstOEins')
call mAdd t.trans, e '<obj e of TstOEins>'
call mAdd t.trans, e2 '<obj e2 of TstOEins>'
tEins = classNew('n TstOEins u f FEINS v,f FZWEI v', 'm',
, 'eins call tstOut t, " met Eins.eins" m',
, 'zwei call tstOut t, " met Eins.zwei" m')
call tstOut t, 'FLDS of' e mCat(oFlds(e), ', ')
call tstOut t, 'methodcalls of object e of TstOEins'
call tstOmet e, 'eins'
call tstOmet e2, 'zwei'
call tstOmet e, 'nein'
call tstOmet 'noObj', 'nein'
tElf = classNew('n TstOElf u TstOEins, f FELF r', 'm',
, 'zwei call tstOut t, " met Elf.zwei" m',
, 'drei call tstOut t, " met Elf.drei" m')
call tstOut t, 'class method calls of TstOEins'
interpret classMet('TstOElf', 'zwei')
f = oNew('TstOElf')
call mAdd t.trans, f '<obj f of TstOElf>'
call tstOut t, 'FLDS of' f mCat(oFlds(f), ', ')
call tstOut t, 'methodcalls of object f of TstOElf'
call tstOmet f, 'eins'
call tstOmet f, 'zwei'
call tstOmet f, 'drei'
call tstOut t, 'methodcalls of object f cast To TstOEins'
call tstOmet oCast(f, 'TstOEins'), 'eins'
call tstOmet oCast(f, 'TstOEins'), 'zwei'
call tstOut t, 'FLDS of <cast(f, TstOEins)>',
mCat(oFlds(oCast(f, 'TstOEins')), ', ')
call oMutate c1, 'TstOEins'
call tstOut t, 'oCopy c1 of class TstOEins, c2'
call tstClassOut t, tEins, c1
call oCopy c1, c2
call tstClassOut t, tEins, c2
call tstOut t, 'oCopy c3 of class TstOElf, c4'
call oMutate c3, 'TstOElf'
call oCopy c3, c4
call tstClassOut t, tElf, c4
tEinsDop = classNew('n TstOEins u f FEINS v,f FZWEI v', 'm',
, 'eins call tstOut t, " met Eins.eins" m',
, 'zwei call tstOut t, " met Eins.zwei" m')
call tstOut t, 'tEinsDop' tEinsDop
e3 = oNew('TstOEins')
if e3 <<= e | e3 <<= e2 then
call err 'doppelt reinitialised objects'
rr = oRunner('return 7 * 3')
call tstOut t, 'oRun 7*3' oRun(rr)
r12 = oRunner('return 12 * 12')
call tstOut t, 'oRun 12*12' oRun(r12)
call tstEnd t
return
endProcedure tstO
tstOmet: procedure expose m.
parse arg m, met
interpret objMet(m, met)
return
endProcedure tstOmet
tstJSay: procedure expose m.
/*<<tstJSay
### start tst tstJSay #############################################
*** err: call of abstract method jOpen(<obj j of JRW>, openArg)
*** err: jWrite(<obj j of JRW>, writeArg) but not opened w
*** err: can only write JRWOut.jOpen(<obj s of JRWOut>, open<Arg)
*** err: jWrite(<obj s of JRWOut>, write s vor open) but not opened+
. w
*** err: can only read JRWEof.jOpen(<obj e of JRWEof>, open>Arg)
*** err: jRead(<obj e of JRWEof>, XX) but not opened r
read e vor open 0 m.xx valueBefore
read e nach open 0 m.xx M.XX
out eins
#jIn 1# tst in line 1 eins ,
out zwei in 1 vv=readAdrVV
#jIn 2# tst in line 2 zwei ; .
out drei in 1 vv=readAdrVV Schluss
tstJSay */
call jIni
call tst t, 'tstJSay'
j = oNew('JRW')
call mAdd t'.TRANS', j '<obj j of JRW>'
call jOpen j, 'openArg'
call jWrite j, 'writeArg'
s = oNew('JRWOut')
call mAdd t'.TRANS', s '<obj s of JRWOut>'
call jOpen s, 'open<Arg'
call jWrite s, 'write s vor open'
call jOpen s, '>'
call jWrite s, 'write s nach open'
e = oNew('JRWEof')
call mAdd t'.TRANS', e '<obj e of JRWEof>'
call jOpen e, 'open>Arg'
m.xx = 'valueBefore'
call tstOut t, 'read e vor open' jRead(e, xx) 'm.xx' m.xx
call jOpen e
call tstOut t, 'read e nach open' jRead(e, xx) 'm.xx' m.xx
call out 'out eins'
vv = 'readAdrVV'
m.vv = 'readAdrVVValueBefore'
call out 'out zwei in' in(vv) 'vv='vv
m.vv = 'readAdrVVValueBefore'
call out 'out drei in' in(vv) 'vv='vv 'Schluss'
call tstEnd t
return
endProcedure tstJSay
tstJ: procedure expose m.
/*<<tstJ
### start tst tstJ ################################################
out eins
#jIn 1# tst in line 1 eins ,
1 in() tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
2 in() tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
3 in() tst in line 3 drei .schluss..
#jIn eof 4#
in() 3 reads vv VV
*** err: already opened jOpen(<buf b>, <)
line buf line one
line buf line two
line buf line three
line buf line four
*** err: jWrite(<buf b>, buf line five while reading) but not opene+
d w
tstJ */
call jIni
call tst t, "tstJ"
b = jOpen(jBuf(), '>')
call mAdd t'.TRANS', b '<buf b>'
call out 'out eins'
do lx=1 by 1 while in(var)
call out lx 'in()' m.var
end
call out 'in()' (lx-1) 'reads vv' vv
call jWrite b, 'buf line one'
call mAdd m.b.stem, 'buf line two', 'buf line three'
call jWrite b, 'buf line four'
call jOpen b, '<'
call jClose b
call jOpen b, '<'
do while (jRead(b, line))
call out 'line' m.line
end
call jWrite b, 'buf line five while reading'
call jClose b
call tstEnd t
return
endProcedure tstJ
tstJ2: procedure expose m.
/*<<tstJ2
### start tst tstJ2 ###############################################
class1 <Tst?1 class> <Tst?1 name>
class2 <Tst?1 class> <Tst?1 name>
class3 <Tst?1 class> <Tst?1 name>
b read EINS feld eins, ZWEI feld zwei, DREI feld drei
b read EINS feld eins, ZWEI feld zwei 2, DREI feld drei
c read EINS feld eins, ZWEI feld zwei, DREI drei cat 1
tstR: @CCC isA :<Tst?1 name> union
tstR: .EINS = feld eins
tstR: .ZWEI = feld zwei
tstR: .DREI = drei cat 1
c read EINS feld eins, ZWEI feld zwei 2, DREI drei cat 2
tstR: @CCC isA :<Tst?1 name> union
tstR: .EINS = feld eins
tstR: .ZWEI = feld zwei 2
tstR: .DREI = drei cat 2
tstJ2 */
call tst t, "tstJ2"
ty = classNew('n Tst* u f EINS v, f ZWEI v, f DREI v')
call mAdd t'.TRANS', ty '<Tst?1 class>'
call mAdd t'.TRANS', m.ty.name '<Tst?1 name>'
call tstOut t, 'class1' ty m.ty.name
ty = classNew('n Tst* u f EINS v, f ZWEI v, f DREI v')
call tstOut t, 'class2' ty m.ty.name
ty = classNew('n Tst* u f EINS v, f ZWEI v, f DREI v')
call tstOut t, 'class3' ty m.ty.name
call oMutate qq, m.ty.name
m.qq.eins = 'feld eins'
m.qq.zwei = 'feld zwei'
m.qq.drei = 'feld drei'
b = jBuf()
call jOpen b, '>'
call jWriteO b, qq
m.qq.zwei = 'feld zwei 2'
call jWriteO b, qq
call jOpen jClose(b), '<'
c = jOpen(jBuf(), '>')
do xx=1 while jReadO(b, res)
call out 'b read EINS' m.res.eins', ZWEI' m.res.zwei,
|| ', DREI' m.res.drei
m.res.drei = 'drei cat' xx
call jWriteO c, res
end
call jOpen jClose(c), '<'
do while jReadO(c, ccc)
call out 'c read EINS' m.ccc.eins', ZWEI' m.ccc.zwei,
|| ', DREI' m.ccc.drei
call outO ccc
end
call tstEnd t
return
endProcedure tstJ2
tstCat: procedure expose m.
/*<<tstCat
### start tst tstCat ##############################################
catRead 1 line 1
catRead 2 line 2
catRead 3 line 3
appRead 1 line 1
appRead 2 line 2
appRead 3 line 3
appRead 4 append 4
appRead 5 append 5
tstCat */
call catIni
call tst t, "tstCat"
i = cat(jBuf('line 1', 'line 2'), jBuf('line 3'))
call jOpen i, m.j.cRead
do lx=1 by 1 while jRead(i, v)
call tstOut t, 'catRead' lx m.v
end
call jOpen jClose(i), m.j.cApp
call jWrite i, 'append 4'
call jWrite i, 'append 5'
call jOpen jClose(i), m.j.cRead
do lx=1 by 1 while jRead(i, v)
call tstOut t, 'appRead' lx m.v
end
call tstEnd t
return
endProcedure tstCat
tstEnv: procedure expose m.
call pipeIni
/*<<tstEnv
### start tst tstEnv ##############################################
before pipeBeLa
after pipeEnd
*** err: jWrite(<jBuf c>, write nach pop) but not opened w
#jIn 1# tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
before writeNow 2 c --> std
before writeNow 1 b --> c
b line eins
b zwei |
nach writeNow 1 b --> c
add nach pop
after push c only
tst in line 1 eins ,
tst in line 2 zwei ; .
tst in line 3 drei .schluss..
nach writeNow 2 c --> std
*** err: jWrite(<jBuf c>, ) but not opened w
tstEnv */
call tst t, "tstEnv"
c = jBuf()
call mAdd t'.TRANS', c '<jBuf c>'
call out 'before pipeBeLa'
b = jBuf("b line eins", "b zwei |")
call pipeBeLa '<' b, '>' c
call out 'before writeNow 1 b --> c'
call pipeWriteNow
call out 'nach writeNow 1 b --> c'
call pipeEnd
call out 'after pipeEnd'
call jWrite c, 'write nach pop'
call mAdd c'.BUF', 'add nach pop'
call pipeBeLa '>>' c
call out 'after push c only'
call pipeWriteNow
call pipeEnd
call pipeBeLa '<' c
call out 'before writeNow 2 c --> std'
call pipeWriteNow
call out 'nach writeNow 2 c --> std'
call pipeEnd
call jWrite c
call tstEnd t
return
endProcedure tstEnv
tstEnvCat: procedure expose m.
call pipeIni
/*<<tstEnvCat
### start tst tstEnvCat ###########################################
c1 contents
c1 line eins |
before writeNow 1 b* --> c*
b1 line eins|
b2 line eins
b2 zwei |
c2 line eins |
after writeNow 1 b* --> c*
c2 contents
c2 line eins |
tstEnvCat */
call tst t, "tstEnvCat"
b0= jBuf()
b0= jBuf()
b1= jBuf("b1 line eins|")
b2 = jBuf("b2 line eins", "b2 zwei |")
c1 = jBuf("c1 line eins |")
c2 = jBuf("c2 line eins |")
call pipeBeLa '<' b0, '<' b1, '<' b2, '<' c2,'>>' c1
call out 'before writeNow 1 b* --> c*'
call pipeWriteNow
call out 'after writeNow 1 b* --> c*'
call pipeEnd
call out 'c1 contents'
call pipeBeLa '<' c1
call pipeWriteNow
call pipeEnd
call pipeBeLa '<' c2
call out 'c2 contents'
call pipeWriteNow
call pipeEnd
call tstEnd t
return
endProcedure tstEnvCat
tstPipe: procedure expose m.
call pipeIni
/*<<tstPipe
### start tst tstPipe #############################################
.+0 vor pipeBegin
#jIn 1# tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
.+7 nach pipeLast
¢7 +6 nach pipe 7!
¢7 +2 nach pipe 7!
¢7 +4 nach nested pipeLast 7!
¢7 (4 +3 nach nested pipeBegin 4) 7!
¢7 (4 (3 +1 nach pipeBegin 3) 4) 7!
¢7 (4 (3 tst in line 1 eins , 3) 4) 7!
¢7 (4 (3 tst in line 2 zwei ; 3) 4) 7!
¢7 (4 (3 tst in line 3 drei .schluss. 3) 4) 7!
¢7 (4 (3 +1 nach writeNow vor pipe 3) 4) 7!
¢7 (4 +3 nach preSuf vor nested pipeLast 4) 7!
¢7 +4 nach preSuf vor nested pipeEnd 7!
¢7 +5 nach nested pipeEnd vor pipe 7!
¢7 +6 nach writeNow vor pipeLast 7!
.+7 nach writeNow vor pipeEnd
.+8 nach pipeEnd
tstPipe */
say 'x0' m.pipe.0
call tst t, 'tstPipe'
call out '+0 vor pipeBegin'
say 'x1' m.pipe.0
call pipeBegin
call out '+1 nach pipeBegin'
call pipeWriteNow
call out '+1 nach writeNow vor pipe'
call pipe
call out '+2 nach pipe'
call pipeBegin
call out '+3 nach nested pipeBegin'
call pipePreSuf '(3 ', ' 3)'
call out '+3 nach preSuf vor nested pipeLast'
call pipeLast
call out '+4 nach nested pipeLast'
call pipePreSuf '(4 ', ' 4)'
call out '+4 nach preSuf vor nested pipeEnd'
call pipeEnd
call out '+5 nach nested pipeEnd vor pipe'
call pipe
call out '+6 nach pipe'
call pipeWriteNow
say 'out +6 nach writeNow vor pipeLast'
call out '+6 nach writeNow vor pipeLast'
call pipeLast
call out '+7 nach pipeLast'
call pipePreSuf '¢7 ', ' 7!'
call out '+7 nach writeNow vor pipeEnd'
call pipeEnd
call out '+8 nach pipeEnd'
say 'xx' m.pipe.0
call tstEnd t
return
endProcedure tstPipe
tstEnvVars: procedure expose m.
call pipeIni
/*<<tstEnvVars
### start tst tstEnvVars ##########################################
put v1 value eins
v1 hasKey 1 get value eins
v2 hasKey 0
via v1.fld via value
one to theBur
two to theBuf
tstEnvVars */
call tst t, "tstEnvVars"
call envRemove 'v2'
m.tst.adr1 = 'value eins'
put1 = envPutO('v1', oMutate(tst'.'adr1, m.class.classV))
call tstOut t, 'put v1' m.put1
call tstOut t, 'v1 hasKey' envHasKey('v1') 'get' envGet('v1')
call tstOut t, 'v2 hasKey' envHasKey('v2')
if 0 then
call tstOut t, 'v2 get' envGet('v2')
m.put1.fld = 'via value'
call tstOut t, 'via v1.fld' envVia('v1|FLD')
call pipeBeLa '>' s2o('}theBuf')
call out 'one to theBur'
call out 'two to theBuf'
call pipeEnd
call pipeBeLa '<' s2o('}theBuf')
call pipeWriteNow
call pipeEnd
call tstEnd t
return
endProcedure tstEnvVars
tstPipeLazy: procedure expose m.
call pipeIni
/*<<tstPipeLazy
### start tst tstPipeLazy #########################################
a1 vor pipeBegin loop lazy 0 writeNow *** <class TstPipeLazyBuf>
bufOpen <
bufClose
#jIn 2# tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
a5 vor 2 writeNow in inIx 4
a2 vor writeNow jBuf
jBuf line 1
jBuf line 2
a3 vor writeNow in inIx 1
tst in line 2 zwei ; .
tst in line 3 drei .schluss..
a4 vor barLast inIx 4
a6 vor barEnd inIx 4
a7 nach barEnd lazy 0 writeNow ***
b1 vor barBegin lazy 0 writeNow *** <class TstPipeLazyRdr>
RdrOpen <
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
rdrClose
b4 vor writeNow
b2 vor writeNow rdr inIx 2
jRead lazyRdr
tst in line 3 drei .schluss..
jRead lazyRdr
b3 vor barLast inIx 4
b5 vor barEnd inIx 4
b6 nach barEnd lazy 0 writeNow ***
a1 vor pipeBegin loop lazy 1 writeAllFramed *** +
.<class TstPipeLazyBuf>
a5 vor 2 writeAllFramed in inIx 0
a2 vor writeAllFramed jBuf
bufOpen <
jBuf line 1
jBuf line 2
bufClose
a3 vor writeAllFramed in inIx 0
#jIn 1# tst in line 1 eins ,
tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
tst in line 3 drei .schluss..
#jIn eof 4#
a4 vor barLast inIx 0
a6 vor barEnd inIx 4
a7 nach barEnd lazy 1 writeAllFramed ***
b1 vor barBegin lazy 1 writeAllFramed *** <class TstPipeLazyRdr>
b4 vor writeAllFramed
b2 vor writeAllFramed rdr inIx 1
RdrOpen <
*** err: jWrite(PIPE.framedNoOut, jRead lazyRdr) but not opened w
#jIn 2# tst in line 2 zwei ; .
tst in line 2 zwei ; .
*** err: jWrite(PIPE.framedNoOut, jRead lazyRdr) but not opened w
#jIn 3# tst in line 3 drei .schluss..
tst in line 3 drei .schluss..
*** err: jWrite(PIPE.framedNoOut, jRead lazyRdr) but not opened w
#jIn eof 4#
rdrClose
b3 vor barLast inIx 1
b5 vor barEnd inIx 4
b6 nach barEnd lazy 1 writeAllFramed ***
tstPipeLazy */
call tst t, "tstPipeLazy"
do lz=0 to 1
if lz then
w = 'writeAllFramed'
else
w = 'writeNow'
m.t.inIx = 1-lz
ty = classNew('n TstPipeLazyBuf u JBuf', 'm',
, 'jOpen call tstOut "T", "bufOpen" opt;',
'return jOpen(oCast(m, "JBuf"), opt)',
, 'jClose call tstOut "T", "bufClose";',
'return jClose(oCast(m, "JBuf"), opt)')
if \ lz then
call mAdd t'.TRANS', ty '<class TstPipeLazyBuf>'
call out 'a1 vor pipeBegin loop lazy' lz w '***' ty
call pipeBegin
call out 'a2 vor' w 'jBuf'
b = oMutate(jBuf('jBuf line 1','jBuf line 2'),
,'TstPipeLazyBuf')
interpret 'call pipe'w 'b'
call out 'a3 vor' w 'in inIx' m.t.inIx
interpret 'call pipe'w
call out 'a4 vor barLast inIx' m.t.inIx
call pipeLast
call out 'a5 vor 2' w 'in inIx' m.t.inIx
interpret 'call pipe'w
call out 'a6 vor barEnd inIx' m.t.inIx
call pipeEnd
call out 'a7 nach barEnd lazy' lz w '***'
ty = classNew('n TstPipeLazyRdr u JRW', 'm',
, 'jOpen call tstOut "T", "RdrOpen" opt;m.m.jReading=1',
, 'jRead call out "jRead lazyRdr"; return in(var);',
, 'jClose call tstOut "T", "rdrClose";')
if \ lz then
call mAdd t'.TRANS', ty '<class TstPipeLazyRdr>'
r = oNew('TstPipeLazyRdr')
if lz then
call mAdd t'.TRANS', r '<lazyRdr>'
m.t.inIx = 2-lz
call out 'b1 vor barBegin lazy' lz w '***' ty
call pipeBegin
if lz then
call mAdd t'.TRANS', m.j.out '<barBegin out>'
call out 'b2 vor' w 'rdr inIx' m.t.inIx
interpret 'call pipe'w 'r'
call out 'b3 vor barLast inIx' m.t.inIx
call pipeLast
call out 'b4 vor' w
interpret 'call pipe'w
call out 'b5 vor barEnd inIx' m.t.inIx
call pipeEnd
call out 'b6 nach barEnd lazy' lz w '***'
end
call tstEnd t
return
endProcedure tstPipeLazy
tstEnvClass: procedure expose m.
call pipeIni
/*<<tstEnvClass
### start tst tstEnvClass #########################################
a0 vor pipeBegin loop lazy 0 writeNow *** TY
#jIn 2# tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
a5 vor writeNow
a1 vor jBuf()
a2 vor writeNow b
tstR: @LINE isA :TstEnvClass10 union
tstR: .f11 = M.<o20 of TstEnvClass10>.f11
tstR: .F12 = value F12 of o1 <o20 of TstEnvClass10>
tstR: .f13 = M.<o20 of TstEnvClass10>.f13
WriteO o2
tstR: @LINE isA :TstEnvClass20 union = valueO2Lazy0
tstR: .f24 = M.<o20 of TstEnvClass20>.f24
tstR: .F25 = value F25 of o20 <o20 of TstEnvClass20>
a3 vor writeNow
tst in line 2 zwei ; .
tst in line 3 drei .schluss..
a4 vor barLast inIx 4
a6 vor barEnd
a7 nach barEnd lazy 0 writeNow ***
a0 vor pipeBegin loop lazy 1 writeAllFramed *** TY
a5 vor writeAllFramed
a1 vor jBuf()
a2 vor writeAllFramed b
tstR: @LINE isA :TstEnvClass10 union
tstR: .f11 = M.<o21 of TstEnvClass10>.f11
tstR: .F12 = value F12 of o1 <o21 of TstEnvClass10>
tstR: .f13 = M.<o21 of TstEnvClass10>.f13
WriteO o2
tstR: @LINE isA :TstEnvClass20 union = valueO2Lazy1
tstR: .f24 = M.<o21 of TstEnvClass20>.f24
tstR: .F25 = value F25 of o21 <o21 of TstEnvClass20>
a3 vor writeAllFramed
#jIn 1# tst in line 1 eins ,
tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
tst in line 3 drei .schluss..
#jIn eof 4#
a4 vor barLast inIx 0
a6 vor barEnd
a7 nach barEnd lazy 1 writeAllFramed ***
tstEnvClass */
call tst t, "tstEnvClass"
do lz=0 to 1
if lz then
w = 'writeAllFramed'
else
w = 'writeNow'
m.t.inIx = 1-lz
t10 = classNew('n TstEnvClass10 u f f11 v, f F12 v, f f13 v')
t20 = classNew('n TstEnvClass20 u v, f f24 v, f F25 v')
call out 'a0 vor pipeBegin loop lazy' lz w '***' ty
call pipeBegin
call out 'a1 vor jBuf()'
b = jOpen(jBuf(), m.j.cWri)
o1 = oNew('TstEnvClass10')
m.o1.F12 = 'value F12 of o1' o1
call mAdd t'.TRANS', o1 '<o2'lz 'of TstEnvClass10>'
call jWriteO b, o1
call jWrite b, 'WriteO o2'
o2 = oNew('TstEnvClass20')
m.o2 = 'valueO2Lazy'lz
m.o2.F25 = 'value F25 of o2'lz o2
oc = oCopyNew(oCopyNew(o2))
call mAdd t'.TRANS', o2 '<o2'lz 'of TstEnvClass20>'
call mAdd t'.TRANS', oc '<oc'lz 'of TstEnvClass20>'
call jWriteO b, oc
call out 'a2 vor' w 'b'
interpret 'call pipe'w jClose(b)
call out 'a3 vor' w
interpret 'call pipe'w
call out 'a4 vor barLast inIx' m.t.inIx
call pipeLast
call out 'a5 vor' w
interpret 'call pipe'w
call out 'a6 vor barEnd'
call pipeEnd
call out 'a7 nach barEnd lazy' lz w '***'
end
call tstEnd t
m.t.trans.0 = 0
return
endProcedure tstEnvClass
tstFile: procedure expose m.
call catIni
/*<<tstFile
### start tst tstFile #############################################
write read 0 last 10 vor anfang
write read 1 last 80 links1 1 und rechts | ..
write read 2 last 80 liinks2 2 und rechts | ..
write read 5 last 80 links5 5 rechts5
write read 99 last 80 links99 99 rechts
write read 100 last 80 links100 100 rechts
write read 101 last 80 links101 101 rechts
write read 999 last 80 links999 999 rechts
write read 1000 last 80 links1000 1000 rechts
write read 1001 last 80 links1001 1001 rechts
write read 2109 last 80 links2109 2109 rechts
out > eins 1 +
. .
out > eins 2 schluss. +
. .
buf eins
buf zwei
buf drei
out > zwei mit einer einzigen Zeile +
. .
. links1 1 und rechts | . +
. .
tstFile */
call tst t, "tstFile"
pds = tstFilename('lib', 'r')
call tstFileWr pds, 0, ' links0', ' und rechts | . '
call tstFileWr pds, 1, ' links1', ' und rechts | . '
call tstFileWr pds, 2, 'liinks2', ' und rechts | . '
call tstFileWr pds, 5, 'links5', 'rechts5'
call tstFileWr pds, 99, 'links99', 'rechts'
call tstFileWr pds, 100, 'links100', 'rechts'
call tstFileWr pds, 101, 'links101', 'rechts'
call tstFileWr pds, 999, 'links999', 'rechts'
call tstFileWr pds, 1000, 'links1000', 'rechts'
call tstFileWr pds, 1001, 'links1001', 'rechts'
call tstFileWr pds, 2109, 'links2109', 'rechts'
pd2 = tstFilename('li2', 'r')
call pipeIni
call pipeBeLa '>' s2o(tstPdsMbr(pd2, 'eins'))
call out tstFB('out > eins 1') /* simulate fixBlock on linux */
call out tstFB('out > eins 2 schluss.')
call pipeEnd
call pipeBeLa '>' s2o(tstPdsMbr(pd2, 'zwei'))
call out tstFB('out > zwei mit einer einzigen Zeile')
call pipeEnd
b = jBuf("buf eins", "buf zwei", "buf drei")
call pipeBeLa '<' s2o(tstPdsMbr(pd2, 'eins')), '<' b,
,'<' jBuf(),
,'<' s2o(tstPdsMbr(pd2, 'zwei')),
,'<' s2o(tstPdsMbr(pds, 'wr0')),
,'<' s2o(tstPdsMbr(pds, 'wr1'))
call pipeWriteNow
call pipeEnd
call tstEnd t
return
endProcedure tstFile
/*--- simulate fixBlock 80 on linux ---------------------------------*/
tstFB: procedure expose m.
parse arg line, recL
if errOS() \== 'LINUX' then
return line
else if recL == '' then
return left(line, 80)
else
return left(line, recL)
endProcedure tstFB
tstPdsMbr: procedure expose m.
parse arg pds, mbr
os = errOS()
if os = 'TSO' then
return pds'('mbr') ::F'
if os = 'LINUX' then
return pds'.'mbr
call err 'tstPdsMbr implement os' os
endProcedure tstPdsMbr
tstFileWR: procedure expose m.
parse arg dsn, num, le, ri
io = file(tstPdsMbr(dsn, 'wr'num))
call jOpen io, m.j.cWri
do x = 1 to num /* simulate fixBlock 80 on LINUX*/
call jWrite io, tstFB(le x ri)
end
call jClose io
if num > 100 then
call jReset io, tstPdsMbr(dsn, 'wr'num)
call jOpen io, m.j.cRead
m.vv = 'vor anfang'
do x = 1 to num
if \ jRead(io, vv) then
call err x 'not jRead'
else if m.vv <> le x ri then
call err x 'read mismatch' m.vv
end
if jRead(io, vv) then
call err x 'jRead but should be eof 1'
if jRead(io, vv) then
call err x'+1 jjRead but should be eof 2'
call jClose io
call tstOut t, 'write read' num 'last' length(m.vv) strip(m.vv,'t')
return
endProcedure tstFileRW
tstFileList: procedure expose m.
call catIni
/*<<tstFileList
### start tst tstFileList #########################################
empty dir
filled dir
<<pref 2 List>>drei
<<pref 2 List>>eins
<<pref 2 List>>zwei
<<pref 2 List>>vier
filled dir recursive
<<pref 2 List>>drei
<<pref 2 List>>eins
<<pref 2 List>>zwei
<<pref 2 List>>vier
<<pref 1 vier>>drei
<<pref 1 vier>>eins
<<pref 1 vier>>zwei
tstFileList */
/*<<tstFileListTSO
### start tst tstFileListTSO ######################################
empty dir
filled dir
<<pref 2 LIST>>DREI
<<pref 2 LIST>>EINS
<<pref 2 LIST>>ZWEI
filled dir recursive
<<pref 2 LIST>>DREI
<<pref 2 LIST>>EINS
<<pref 1 VIER>>DREI
<<pref 1 VIER>>EINS
<<pref 1 VIER>>ZWEI
<<pref 2 LIST>>ZWEI
tstFileListTSO */
if errOS() = 'TSO' then
call tst t, "tstFileListTSO"
else
call tst t, "tstFileList"
fi = file(tstFileName('FileList', 'r'))
call fileMkDir fi
fl = fileList(fi)
call tstOut t, 'empty dir'
call jWriteNow t, fl
call tstFileListMake t, fi, 2
call tstOut t, 'filled dir'
call jWriteNow t, fl
call tstOut t, 'filled dir recursive'
call jWriteNow t, fileList(fi, 'r')
call tstEnd t
return
endProcedure tstFileList
tstFileListMake: procedure expose m.
parse arg t, fi, lev
if \ fileIsDir(fi) then
call fileMkDir fi
call mAdd t'.TRANS', filePath(fi) || m.file.sep ,
'<<pref' lev right(filePath(fi),4)'>>'
call jCat fileChild(fi, 'eins','::F'),jBuf('zeile eins','eins' lev)
call jCat fileChild(fi, 'zwei','::F'),jBuf('zeile zwei','zwei' lev)
call jCat fileChild(fi, 'drei','::F'),jBuf('zeile drei','drei' lev)
if lev > 1 then
call tstFileListMake t, fileChild(fi, 'vier'), lev-1
return
endProcedure tstFileListMake
tstFmt: procedure expose m.
call pipeIni
/*<<tstFmt
### start tst tstFmt ##############################################
= a2i b3b d4 fl5 ex6
-11 -11 b3 d4-11+d4++++ -111.1000000 -1.11000E-12
-1 -10 b d4-10+d4+++ null1 null3
- -9 b3b-9 d4-9+d4+++ -11.0000000 -1.11900E-10
-8+ -8 b3b- d4-8+d4++ -18.0000000 -1.18000E010
-7 -7 b3b d4-7+d4+ -7.0000000 -1.70000E-07
- -6 b3 d4-6+d4 -0.1111160 -6.00000E006
-5+ -5 b d4-5+d null2 null2
-4 -4 b3b-4 d4-4+ -11114.0000000 -1.11140E008
- -3 b3b- d4-3 -0.1130000 -1.13000E-04
-2+ -2 b3b d4- -0.1200000 -1.20000E001
-1 -1 b3 d4 -0.1000000 -1.00000E-02
0 0 b d null1 null1
1+ 1 b3 d4 0.1000000 1.00000E-02
2++ 2 b3b d42 0.1200000 1.20000E001
3 3 b3b3 d43+ 0.1130000 1.13000E-04
4+ 4 b3b4+ d44+d 11114.0000000 1.11140E008
5++ 5 b d45+d4 null2 null2
6 6 b3 d46+d4+ 0.1111160 1.11116E005
7+ 7 b3b d47+d4++ 0.1111117 7.00000E-08
8++ 8 b3b8 d48+d4+++ 8.0000000 1.80000E009
9 9 b3b9+ d49+d4++++ 0.9000000 1.19000E-08
10 10 b d410+d4++++ null1 null3
11+ 11 b3 d411+d4+++++ 0.1110000 1.00000E-12
1 12 b3b d412+d4++++++ 11112.0000000 2.00000E012
13 13 b3b1 d 1111.3000000 1.13000E-12
14+ 14 b3b14 d4 111111.0000000 1.40000E013
1 15 b d41 null2 null1
16 16 b3 d416 6.0000000 1.16000E003
17+ 17 b3b d417+ 0.7000000 1.11170E-03
1 18 b3b1 d418+d 11.0000000 1.11800E003
19 19 b3b19 d419+d4 0.1190000 9.00000E-05
20+ 20 b d420+d4+ null1 null2
2 21 b3 d421+d4++ 11.1210000 1.11000E-05
22 22 b3b d422+d4+++ 11111.2000000 2.00000E007
23+ 23 b3b2 d423+d4++++ 0.1111123 1.11230E-09
c3L a2i drei d4 fl5 ex6
-11 -1.10E01 b3 d4-11+d -111.1000000 -1.11000E-12
-1 -1.00E01 b d4-10+d null1 null3
- -9.00E00 b3b-9 d4-9+d4 -11.0000000 -1.11900E-10
-8+ -8.00E00 b3b- d4-8+d4 -18.0000000 -1.18000E010
-7 -7.00E00 b3b d4-7+d4 -7.0000000 -1.70000E-07
- -6.00E00 b3 d4-6+d4 -0.1111160 -6.00000E006
-5+ -5.00E00 b d4-5+d null2 null2
-4 -4.00E00 b3b-4 d4-4+ -11114.0000000 -1.11140E008
- -3.00E00 b3b- d4-3 -0.1130000 -1.13000E-04
-2+ -2.00E00 b3b d4- -0.1200000 -1.20000E001
-1 -1.00E00 b3 d4 -0.1000000 -1.00000E-02
0 0.00E00 b d null1 null1
1+ 1.00E00 b3 d4 0.1000000 1.00000E-02
2++ 2.00E00 b3b d42 0.1200000 1.20000E001
3 3.00E00 b3b3 d43+ 0.1130000 1.13000E-04
4+ 4.00E00 b3b4+ d44+d 11114.0000000 1.11140E008
5++ 5.00E00 b d45+d4 null2 null2
6 6.00E00 b3 d46+d4+ 0.1111160 1.11116E005
7+ 7.00E00 b3b d47+d4+ 0.1111117 7.00000E-08
8++ 8.00E00 b3b8 d48+d4+ 8.0000000 1.80000E009
9 9.00E00 b3b9+ d49+d4+ 0.9000000 1.19000E-08
10 1.00E01 b d410+d4 null1 null3
11+ 1.10E01 b3 d411+d4 0.1110000 1.00000E-12
1 1.20E01 b3b d412+d4 11112.0000000 2.00000E012
13 1.30E01 b3b1 d 1111.3000000 1.13000E-12
14+ 1.40E01 b3b14 d4 111111.0000000 1.40000E013
1 1.50E01 b d41 null2 null1
16 1.60E01 b3 d416 6.0000000 1.16000E003
17+ 1.70E01 b3b d417+ 0.7000000 1.11170E-03
1 1.80E01 b3b1 d418+d 11.0000000 1.11800E003
19 1.90E01 b3b19 d419+d4 0.1190000 9.00000E-05
20+ 2.00E01 b d420+d4 null1 null2
2 2.10E01 b3 d421+d4 11.1210000 1.11000E-05
22 2.20E01 b3b d422+d4 11111.2000000 2.00000E007
23+ 2.30E01 b3b2 d423+d4 0.1111123 1.11230E-09
tstFmt */
call tst t, "tstFmt"
b = jBuf()
st = b'.BUF'
call pipeBeLa m.j.cWri b
call tstDataClassOut '. c3 a2i i b3b c5 d4 c13 fl5 f8n2 ex6 e9n3',
, -11, + 23
call pipeEnd
call fmtFWriteAll fmtFreset(abc), b
call fmtFAddFlds fmtFReset(abc), oFlds(st'.'1)
m.abc.1.tit = 'c3L'
m.abc.2.fmt = 'e'
m.abc.3.tit = 'drei'
m.abc.4.fmt = 'l7'
call fmtFWriteAll abc, b
call tstEnd t
return
endProcedure tstFmt
tstScan: procedure expose m.
/*<<tstScan.1
### start tst tstScan.1 ###########################################
scan src a034,Und hr123sdfER"st1" 'str2''mit''apo''s' .
scan n tok 4: a034 key val .
scan , tok 1: , key val .
scan n tok 3: Und key val .
scan v tok 1: key val .
scan n tok 10: hr123sdfER key val .
scan q tok 5: "st1" key val st1
scan v tok 1: key val st1
scan a tok 19: 'str2''mit''apo''s' key val str2'mit'apo's
scan v tok 1: key val str2'mit'apo's
tstScan.1 */
call tst t, 'tstScan.1'
call tstScan1 ,'l"litEins"l"litZwei"ndv" "aq1' ,
,"a034,Und hr123sdfER""st1"" 'str2''mit''apo''s' "
call tstEnd t
/*<<tstScan.2
### start tst tstScan.2 ###########################################
scan src a034,Und hr123sdfER"st1" 'str2''mit''apo''s' .
scan n tok 4: a034 key val .
scan , tok 1: , key val .
scan n tok 3: Und key val .
scan b tok 0: key val .
scan n tok 10: hr123sdfER key val .
scan " tok 5: "st1" key val st1
scan b tok 0: key val st1
scan ' tok 19: 'str2''mit''apo''s' key val str2'mit'apo's
scan b tok 0: key val str2'mit'apo's
tstScan.2 */
call tst t, 'tstScan.2'
call tstScan1 , 'ndsb1' ,
,"a034,Und hr123sdfER""st1"" 'str2''mit''apo''s' "
call tstEnd t
/*<<tstScan.3
### start tst tstScan.3 ###########################################
scan src a034,'wie 789abc
scan n tok 4: a034 key val .
scan , tok 1: , key val .
*** err: scanErr ending Apostroph(') missing
. e 1: last token scanPosition 'wie 789abc
. e 2: pos 6 in string a034,'wie 789abc
scan ' tok 1: ' key val .
scan n tok 3: wie key val .
scan s tok 0: key val .
*** err: scanErr illegal number end after 789
. e 1: last token 789 scanPosition abc
. e 2: pos 14 in string a034,'wie 789abc
scan d tok 3: 789 key val .
scan n tok 3: abc key val .
tstScan.3 */
call tst t, 'tstScan.3'
call tstScan1 , 'nds1' ,
,"a034,'wie 789abc"
call tstEnd t
/*<<tstScan.4
### start tst tstScan.4 ###########################################
scan src litEinsefr 23 sdfER'str1'litZwei "str2""mit quo"s .
scan l tok 7: litEins key val .
scan n tok 3: efr key val .
scan b tok 0: key val .
scan d tok 2: 23 key val .
scan b tok 0: key val .
scan n tok 5: sdfER key val .
scan a tok 6: 'str1' key val str1
scan l tok 7: litZwei key val str1
scan b tok 0: key val str1
scan q tok 15: "str2""mit quo" key val str2"mit quo
scan n tok 1: s key val str2"mit quo
scan b tok 0: key val str2"mit quo
tstScan.4 */
call tst t, 'tstScan.4'
call tstScan1 , 'l"litEins"l"litZwei"ndbaq1' ,
,"litEinsefr 23 sdfER'str1'litZwei ""str2""""mit quo""s "
call tstEnd t
/*<<tstScan.5
### start tst tstScan.5 ###########################################
scan src aha;+-=f ab=cdEf eF='strIng' .
scan b tok 0: key val .
scan k tok 4: no= key aha val def
scan ; tok 1: ; key aha val def
scan + tok 1: + key aha val def
scan - tok 1: - key aha val def
scan = tok 1: = key aha val def
scan k tok 4: no= key f val def
scan k tok 4: cdEf key ab val cdEf
scan b tok 4: cdEf key ab val cdEf
scan k tok 8: 'strIng' key eF val strIng
scan b tok 8: 'strIng' key eF val strIng
tstScan.5 */
call tst t, 'tstScan.5'
call tstScan1 , 'bk1'," aha;+-=f ab=cdEf eF='strIng' "
call tstEnd t
return
endProcedure tstScan
tstScanRead: procedure expose m.
/*<<tstScanRead
### start tst tstScanRead #########################################
name erste
space
name Zeile
space
nextLine
nextLine
space
name dritte
space
name Zeile
space
name schluss
space
tstScanRead */
call tst t, 'tstScanRead'
b = jBuf('erste Zeile ',,' dritte Zeile schluss ')
s = jOpen(scanRead(b))
do while \scanAtEnd(s)
if scanName(s) then call tstOut t, 'name' m.s.tok
else if scanVerify(s, ' ') then call tstOut t, 'space'
else if scanReadNL(s) then call tstOut t, 'nextLine'
else if \scanAtEnd(s) then call scanErr s, 'cannot scan'
end
call jClose s
call tstEnd t
/*<<tstScanReadMitSpaceLn
### start tst tstScanReadMitSpaceLn ###############################
name erste
spaceLn
name Zeile
spaceLn
name dritte
spaceLn
name Zeile
spaceLn
name schluss
spaceLn
tstScanReadMitSpaceLn */
call tst t, 'tstScanReadMitSpaceLn'
s = jOpen(scanRead(b))
do forever
if scanName(s) then call out 'name' m.s.tok
else if scanSpaceNL(s) then call out 'spaceLn'
else if \scanAtEnd(s) then call scanErr s, 'cannot scan'
else leave
end
call jClose s
call tstEnd t
/*<<tstScanJRead
### start tst tstScanJRead ########################################
1 jRead n tok erste val .
2 jRead s tok val .
3 jRead n tok Zeile val .
4 jRead s tok val .
5 jRead n tok dritte val .
6 jRead s tok val .
7 jRead n tok Zeile val .
8 jRead s tok val .
9 jRead n tok schluss val .
10 jRead s tok val .
11 jRead 0 tok 1 val 1
12 jRead s tok val 1
13 jRead + tok + val 1
14 jRead s tok val 1
15 jRead 0 tok 2. val 2..
16 jRead s tok val 2..
17 jRead + tok + val 2..
18 jRead . tok . val 2..
19 jRead s tok val 2..
20 jRead 0 tok +.3 val +.3
21 jRead 0 tok -45e-3 val -45E-3
22 jRead s tok val -45E-3
23 jRead " tok "a""b" val a"b
24 jRead s tok val a"b
25 jRead ' tok 'c''d' val c'd
className 1: Scan 18: Scan
tstScanJRead */
call tst t, 'tstScanJRead'
call jWrite jOpen(b,'>>'), '1 + 2. +. +.3-45e-3 "a""b"' "'c''d'"
s = jOpen(scanRead(jClose(b)))
do x=1 while jRead(s, v.x)
call out x 'jRead' m.v.x.type 'tok' m.v.x.tok 'val' m.v.x.val
end
call jClose s
call out 'className 1:' className(objClass(v.1)),
'18:' className(objClass(v.18))
call tstEnd t
return
endProcedure tstScanRead
tstScanWin: procedure expose m.
/*<<tstScanWin
### start tst tstScanWin ##########################################
info 0: last token scanPosition erste Zeile dr+
itteZe\npos 1 in line 1: erste Zeile
name erste
spaceNL
name Zeile
spaceNL
name dritteZeeeile
info 5: last token dritteZeeeile scanPosition zeile4 +
. fuenfueberSechs\npos 1 in line 4: zeile4
spaceNL
name zeile4
spaceNL
name fuenfueberSechsUnddSiebenUNDundUndUAcht
spaceNL
info 10: last token scanPosition undZehnueberElfundNochWeiterZwoel+
fundim1\npos 9 in line 10: undZehn
name undZehnueberElfundNochWeiterZwoelfundim13
spaceNL
name Punkt
infoE 14: last token Punkt scanPosition \natEnd after line 13: im13+
. Punkt
tstScanWin */
call scanWinIni
call tst t, 'tstScanWin'
b = jBuf('?erste Zeile?',,'? dritteZeeeile?', '? zeile4 ',
,'? fuenf?', '?ueberSechsUnddS?', '?iebenUNDundUndU?',
,'?Acht ?', '? ?', '? undZehn?',
,'?ueberElfundNoch?', '?WeiterZwoelfund?', '?im13 Punkt?')
s = jOpen(scanWin(b, , , 2, 15))
call tstOut t, 'info 0:' scanInfo(s)
do sx=1 while \scanAtEnd(s)
if scanName(s) then call tstOut t, 'name' m.s.tok
else if scanSpaceNL(s) then call tstOut t, 'spaceNL'
else if \scanAtEnd(s) then call scanErr s, 'cannot scan'
if sx // 5 = 0 then
call tstOut t, 'info' sx':' scanInfo(s)
end
call tstOut t, 'infoE' sx':' scanInfo(s)
call tstEnd t
/*<<tstScanWinRead
### start tst tstScanWinRead ######################################
info 0: last token scanPosition erste Zeile z3 +
com Ze\npos 1 in line 1: erste Zeile
name erste
spaceNL
name Zeile
spaceNL
name z3
info 5: last token z3 scanPosition com Zeeeile z4 come4 f+
uenf\npos 4 in line 3: z3 com Zeeeile
spaceNL
name z4
spaceNL
name fuenf
spaceNL
info 10: last token scanPosition com Sechs com sieben comAc+
ht com\npos 15 in line 5: fuenf c
name com
spaceNL
tstScanWinRead */
call tst t, 'tstScanWinRead'
call mAdd t.cmp,
, "name Sechs",
, "spaceNL",
, "name com",
, "info 15: last token com scanPosition sieben comAcht c",
|| "om com com\npos 2 in line 7: m sieben com" ,
, "spaceNL",
, "name sieben",
, "spaceNL",
, "name Acht",
, "spaceNL",
, "info 20: last token scanPosition ueberElfundNochWeit com ",
|| "elfundim13\npos 1 in line 11: ueberElfundNoch",
, "name ueberElfundNochWeit",
, "spaceNL",
, "name im13",
, "spaceNL",
, "name Punkt",
, "info 25: last token Punkt scanPosition \natEnd after line ",
|| "13: im13 Punkt",
, "infoE 26: last token Punkt scanPosition \natEnd after line",
|| " 13: im13 Punkt"
b = jBuf('?erste Zeile?',,'? z3 com Zeeeile?', '? z4 come4 ',
,'? fuenf c?', '?om Sechs co?', '?m sieben com?',
,'?Acht com com ?', '? com ?', '? com undZehn?',
,'?ueberElfundNoch?', '?Weit com elfund?', '?im13 Punkt?')
s = scanWin(b, , , 2, 15)
call scanOpts s, , , 'com'
call tstOut t, 'info 0:' scanInfo(jOpen(s))
do sx=1 while \scanAtEnd(s)
if scanName(s) then call tstOut t, 'name' m.s.tok
else if scanSpaceNL(s) then call tstOut t, 'spaceNL'
else if \scanAtEnd(s) then call scanErr s, 'cannot scan'
if sx // 5 = 0 then
call tstOut t, 'info' sx':' scanInfo(s)
end
call tstOut t, 'infoE' sx':' scanInfo(s)
call tstEnd t
return
endProcedure tstScanWin
tstScanSql: procedure expose m.
call scanWinIni
/*<<tstScanSqlId
### start tst tstScanSqlId ########################################
sqlId ABC
spaceNL
sqlId AB__345EF
spaceNL
tstScanSqlId */
call tst t, 'tstScanSqlId'
b = jBuf('abc -- kommentar', right('ab_', 72), '_345ef-- kom')
s = jOpen(scanSql(b))
do sx=1 while \scanAtEnd(s)
if scanSqlID(s) then call tstOut t, 'sqlId' m.s.val
else if scanSpaceNL(s) then call tstOut t, 'spaceNL'
else call scanErr s, 'cannot scan'
end
call tstEnd t
/*<<tstScanSqlDelimited
### start tst tstScanSqlDelimited #################################
sqlDeId ABC
spaceNL
sqlDeId AB_3F
spaceNL
sqlDeId abc
spaceNL
sqlDeId ab_Ef
spaceNL
tstScanSqlDelimited */
call tst t, 'tstScanSqlDelimited'
b = jBuf('abc -- kommentar',,' -- ',,right('ab_', 72),'3F-- kom',
, '"abc" -- ko', ' -- ',,right('"ab_', 72),'Ef"-- kom')
s = jOpen(scanSql(b))
do sx=1 while \scanAtEnd(s)
if scanSqlDeID(s) then call tstOut t, 'sqlDeId' m.s.val
else if scanSpaceNL(s) then call tstOut t, 'spaceNL'
else call scanErr s, 'cannot scan'
end
call tstEnd t
/*<<tstScanSqlQualified
### start tst tstScanSqlQualified #################################
sqlQuId ABC 1 ABC
sqlQuId AB_3F 1 AB_3F
sqlQuId abc 1 abc
sqlQuId ab_Ef 1 ab_Ef
sqlQuId EINS.Zwei.DREI 3 EINS
sqlQuId vi er.fu enf 2 vi er
tstScanSqlQualified */
call tst t, 'tstScanSqlQualified'
b = jBuf('abc -- kommentar',,' -- ',,right('ab_', 72),'3F-- kom',
, '"abc" -- ko', ' -- ',right('"ab_', 72),'Ef"-- kom',
, 'eins."Zwei', '" -- com', ' . -- com', ' -- com',
, 'drei -- ko', '"vi er"."fu enf " -- co')
s = jOpen(scanSql(b))
do sx=1 while \scanAtEnd(s)
if scanSqlQuID(s) then
call tstOut t, 'sqlQuId' m.s.val m.s.val.0 m.s.val.1
else if scanSpaceNL(s) then call tstOut t, 'spaceNL'
else call scanErr s, 'cannot scan'
end
call tstEnd t
/*<<tstScanSqlNum
### start tst tstScanSqlNum #######################################
sqlNum 1
spaceNL
sqlNum 2..
spaceNL
sqlNum .3
spaceNL
sqlNum 4.5
spaceNL
sqlNum +6
spaceNL
sqlNum +7.03
spaceNL
sqlNum -8
spaceNL
sqlNum -.9
spaceNL
sqlNum 1E2
spaceNL
sqlNum -2.E-2
spaceNL
sqlNum +.3E+3
spaceNL
tstScanSqlNum */
call tst t, 'tstScanSqlNum'
b = jBuf('1 2. .3 4.5 +6 + --kom', , ' -- com ', , ' 7.03 -8 - .9',
'1e2 - 2.e-2 + .3e+3')
s = jOpen(scanSql(b))
do sx=1 while \scanAtEnd(s)
if scanSqlNum(s) then
call tstOut t, 'sqlNum' m.s.val
else if scanSpaceNL(s) then call tstOut t, 'spaceNL'
else call scanErr s, 'cannot scan'
end
call tstEnd t
/*<<tstScanSqlNumUnit
### start tst tstScanSqlNumUnit ###################################
sqlNumUnit 1 KB
spaceNL
sqlNumUnit .3 MB
sqlNumUnit .5
sqlNumUnit +6.E-5 B
spaceNL
sqlNumUnit -7
char *
spaceNL
sqlNumUnit -.8
char T
char B
spaceNL
*** err: scanErr scanSqlNumUnit after +9. bad unit TB
. e 1: last token Tb scanPosition .
. e 2: pos 41 in line 1: 1 kb .3mB.5 + 6.e-5B -7* -.8 TB + 9.T+
b
sqlNumUnit +9..
spaceNL
tstScanSqlNumUnit */
call tst t, 'tstScanSqlNumUnit'
b = jBuf('1 kb .3mB.5 + 6.e-5B -7* -.8 TB + 9.Tb')
s = jOpen(scanSql(b))
do sx=1 while \scanAtEnd(s)
if scanSqlNumUnit(s, 0, 'B KB MB') then
call tstOut t, 'sqlNumUnit' m.s.val
else if scanSpaceNL(s) then call tstOut t, 'spaceNL'
else if scanChar(s ,1) then call tstOut t, 'char' m.s.tok
else call scanErr s, 'cannot scan'
end
call tstEnd t
return
endProcedure tstScanSql
/*--- one single test scan with lines to scan in stem ln -------------*/
tstScan1:
parse arg sc, classs, ln
if sc == '' then do
call tstOut t, 'scan src' ln
call scanSrc scanReset(s), ln
end
else do
call tstOut t, 'scan scanner' sc
s = sc
end
do forever
x = tstScanType(s, classs)
if x == '' then
leave
call tstOut t, 'scan' x 'tok' length(m.s.tok)':' m.s.tok ,
'key' m.s.key 'val' m.s.val
end
return
endProcedure tstScan1
tstScanType: procedure expose m.
parse arg s, opt
cx = 1
a2 = ''
res = 0
do while cx <= length(opt)
f = substr(opt, cx, 1)
cx = cx + 1
if pos(substr(opt, cx, 1), "'""") > 0 then do
m.tstScanType.src = opt
m.tstScanType.pos = cx
call scanString tstScanType
a2 = m.tstScanType.val
cx = m.tstScanType.pos
end
if f == 'a' then
res = scanString(s, "'")
else if f == 'b' then
res = scanSpaceNl(s)
else if f == 'c' then
res = scanChar(s, a2)
else if f == 'd' then
res = scanNat(s, a2)
else if f == 'k' then
res = scanKeyValue(s, 'def')
else if f == 'l' then
res = scanLit(s, a2)
else if f == 'q' then
res = scanString(s, '"')
else if f == 'v' then
res = scanVerify(s, a2)
else if f == 'w' then
res = scanWord(s)
else if f == 'y' then
res = scanVerify(s, a2, 'm')
if res then
return f
end
return scanType(s)
endProcedure tstScanType
/* copx tstBase end *************************************************/
/* copx tst begin ****************************************************
test infrastructure
***********************************************************************/
/*--- migrate all compares to new ones:
tstCI input compare
tstCO ouput migrated compares
tstCIO input and output -------------------------------------*/
tstCI: procedure expose m.
parse arg m, nm
m.m.CIO = 0
signal tstCIwork
tstCIO: procedure expose m.
parse arg m, nm
m.m.CIO = 1
tstCIwork:
m.m.name = nm
m.m.cmp.1 = left('### start tst' nm '', 67, '#')
do ix=2 to arg()-1
m.m.cmp.ix = arg(ix+1)
end
m.m.cmp.0 = ix-1
if m.m.CIO then
call tstCO m
return
tstCO: procedure expose m.
parse arg m
call tst2dpSay m.m.name, m'.CMP', 68
return
/*--- initialise m as tester with name nm
use inline input nm as compare lines -----------------------*/
tstReset: procedure expose m.
parse arg m, nm
call tstIni
m.m.name = nm
m.m.inIx = 0
m.m.out.0 = 0
m.m.err = 0
m.m.errHand = 0
m.tst.act = m
if \ datatype(m.m.trans.0, 'n') then
m.m.trans.0 = 0
m.m.trans.old = m.m.trans.0
return
endProcedure tstReset
tst: procedure expose m.
parse arg m, nm, cmpSt
call tstReset m, nm
m.tst.tests = m.tst.tests+1
if cmpSt == '' then do
cmpSt = mCut(t'.CMP', 0)
call tst4dp cmpSt, mapInline(nm)
end
m.m.cmp = cmpSt
m.m.moreOutOk = 0
call mAdd mCut(m'.IN', 0), 'tst in line 1 eins ,' ,
, 'tst in line 2 zwei ; ' ,
, 'tst in line 3 drei .schluss.'
call tstOut m, left('### start tst' nm '', 67, '#')
call errReset 'h', 'return tstErrHandler(ggTxt)'
m.m.errCleanup = m.err.cleanup
if m.tst.ini.j \== 1 then do
call err implement outDest 'i', 'call tstOut' quote(m)', msg'
end
else do
call oMutate m, 'Tst'
m.m.jReading = 1
m.m.jWriting = 1
if m.tst.ini.e \== 1 then do
m.m.oldJin = m.j.in
m.m.oldOut = m.j.out
m.j.in = m
m.j.out = m
end
else do
if m.pipe.0 <> 1 then
call tstErr m, 'm.pipe.0' m.pipe.0 '<> 1'
call pipeBeLa '<' m, '>' m
end
end
return m
endProcedure tst
tstEnd: procedure expose m.
parse arg m, opt opt2
cmp = m.m.cmp
m.m.jReading = 0
m.m.jWriting = 0
if m.tst.ini.j == 1 then do
m.m.jReading = 0
m.m.jWriting = 0
if m.tst.ini.e \== 1 then do
m.j.in = m.m.oldJin
m.j.out = m.m.oldOut
end
else do
if m.j.in \== m | m.j.out \== m then
call tstErr m, m.j.in '\==' m '|' m.j.out '\==' m
call pipeEnd
if m.pipe.0 <> 1 then
call tstErr m, 'm.pipe.0' m.pipe.0 '<> 1'
end
end
if m.m.err = 0 then
if m.m.errCleanup \= m.err.cleanup then
call tstErr m, 'err.Cleanup' m.err.cleanup '<> old',
m.m.errCleanup
if m.m.out.0 \= m.cmp.0 & \ (m.m.moreOutOk,
& m.m.out.0 > m.cmp.0) then do
call tstErr m, 'old' m.cmp.0 'lines \= new' m.m.out.0
do nx = m.m.out.0 + 1 to min(m.m.out.0+10, m.cmp.0)
say 'old - ' m.cmp.nx
end
end
call errReset 'h'
m.tst.act = ''
soll = 0
if opt = 'err' then do
soll = opt2
if m.m.err \= soll then
call err soll 'errors expected, but got' m.m.err
end
if m.m.err \= soll then do
say 'new lines:' (m.m.out.0 - 1)
call tst2dpSay m.m.name, m'.OUT', 68
end
say left('###' m.m.name 'end with' m.m.err 'errors ', 67, '#')
if 1 & m.m.err \= soll then
call err 'dying because of' m.m.err 'errors'
m.m.trans.0 = m.m.trans.old
return
endProcedure tstEnd
tst2dp: procedure expose m.
parse arg st, dp, ml
dx = m.dp.0
do sx=1 to m.st.0
li = m.st.sx
cx = 1
do until cx > length(li)
c = substr(li, cx, 1)
ou = left('.', strip(c) == '' | pos(c, '.+') > 0)
ex = min(length(li),cx+ml-length(ou)-2)
ou = ou || substr(li, cx, ex+1-cx)
dx = dx + 1
c = right(ou, 1)
if ex < length(li) then
m.dp.dx = ou || '+'
else if strip(c) == '' | pos(c, '.+') > 0 then
m.dp.dx = ou || '.'
else
m.dp.dx = ou
cx = ex +1
end
end
m.dp.0 = dx
return
endProcedure tst2dp
tst2dpSay: procedure expose m.
parse arg name, st, ml
say '/*<<'name
call tst2dp st, mCut('TST.TMP', 0), 68
do nx=1 to m.tst.tmp.0
say ' ' m.tst.tmp.nx
end
say name '*/'
return tst2dpSay
tst4dp: procedure expose m.
parse arg st, dp
sx = m.st.0
inData = 0
data = ''
do dx=1 to m.dp.0
li = strip(m.dp.dx)
if pos(left(li, 1), '.+') > 0 then
li = substr(li, 2)
if right(li, 1) == '+' then do
inData = 1
data = data || left(li, length(li)-1)
iterate
end
if right(li, 1) == '.' then
li = left(li, length(li)-1)
sx = sx + 1
m.st.sx = data || li
inData = 0
data = ''
end
m.st.0 = sx
if inData then
call err 'end inData'
return
endProcedure tst4dp
/*--- write to test: say lines and compare them ----------------------*/
tstWrite: procedure expose m.
parse arg m, arg
call tstOut m, 'out:' arg
return
endProcedure tstWrite
tstOut: procedure expose m.
parse arg m, arg
do tx=m.m.trans.0 by -1 to 1
arg = repAll(arg, word(m.m.trans.tx, 1),
, subword(m.m.trans.tx, 2))
end
call mAdd m'.OUT', arg
nx = m.m.out.0
cmp = m.m.cmp
c = m.cmp.nx
if nx > m.cmp.0 then do
if nx = m.cmp.0+1 & \ m.m.moreOutOK then
call tstErr m, 'more new Lines' nx
end
else if c \== arg then do
do cx=1 to min(length(c), length(arg)) ,
while substr(c, cx, 1) == substr(arg, cx, 1)
end
msg = 'old line' nx '<> new overnext, firstDiff' cx',',
'len old' length(c)', new' length(arg)
if cx > 10 then
msg = overlay('|', msg, cx-10)
call tstErr m, msg
say c
end
say arg
return 0
endProcedure tstOut
tstWriteO: procedure expose m.
parse arg m, var
if abbrev(var, m.class.escW) then do
call tstOut t, o2String(var)
end
else if m.class.o2c.var == m.class.classV then do
call tstOut t, m.var
end
else if oKindOf(var, 'JRW') then do
call tstOut t, 'tstWriteO kindOf JRW jWriteNow begin <<<'
call jWriteNow m, var
call tstOut t, 'tstWriteO kindOf JRW jWriteNow end >>>'
end
else if oKindOf(var, 'ORun') then do
call tstOut t, 'tstWriteO kindOf ORun oRun begin <<<'
call oRun var
call tstOut t, 'tstWriteO kindOf ORun oRun end >>>'
end
else do
call classOut , var, 'tstR: '
end
return
endProcedure tstWriteO
tstReadO: procedure expose m.
parse arg m, arg
ix = m.m.inIx + 1
m.m.inIx = ix
if ix <= m.m.in.0 then do
m.arg = m.m.in.ix
m.class.o2c.arg = m.class.classV
call tstOut m, '#jIn' ix'#' m.arg
return 1
end
call tstOut m, '#jIn eof' ix'#'
return 0
endProcedure tstReadO
tstFilename: procedure
parse arg suf, opt
os = errOS()
if os == 'TSO' then do
dsn = dsn2jcl('~tmp.tst.'suf)
if opt = 'r' then do
if sysDsn("'"dsn"'") \== 'DATASET NOT FOUND' then
call adrTso "delete '"dsn"'"
call csiOpen 'TST.CSI', dsn'.**'
do while csiNext('TST.CSI', 'TST.FINA')
say 'deleting csiNext' m.tst.fina
call adrTso "delete '"m.tst.fina"'"
end
end
return dsn
end
else if os == 'LINUX' then do
if abbrev(suf, '/') then
fn = suf
else
fn = .Stream%%new('~/tmp/tst/'suf)%%qualify /* full path */
cx = lastPos('/', fn)
if cx > 0 then do
dir = left(fn, cx-1)
if \sysIsFileDirectory(dir) then
call adrSh "mkdir -p" dir
if \sysIsFileDirectory(dir) then
call err 'tstFileName could not create dir' dir
end
if opt \= 'r' then
nop
else if sysIsFile(fn) then
call sysFileDelete fn
else if sysIsFileDirectory(fn) then
call adrSh 'rm -r' fn
return fn
end
else
call err 'tstFilename does not implement os' os
endProcedure tstFilename
/*--- say total errors and fail if not zero --------------------------*/
tstTotal: procedure expose m.
say '######'
say '######'
say '######' m.tst.tests 'tests with' ,
m.tst.err 'errors in' m.tst.errNames
say '######'
say '######'
if m.tst.err \== 0 then
call err m.tst.err 'errors total'
return
endProcedure tstTotal
/*--- test err: message, count it and continue -----------------------*/
tstErr: procedure expose m.
parse arg m, msg
say '### error' msg
m.m.err = m.m.err + 1
m.tst.err = m.tst.err + 1
nm = m.m.name
if wordPos(nm, m.tst.errNames) < 1 then
m.tst.errNames = m.tst.errNames nm
return 0
endProcedure tstErr
/*--- tstErrHandler: intercept errors --------------------------------*/
tstErrHandler: procedure expose m.
parse arg ggTxt
m = m.tst.act
if m == '' then
call err ggTxt
m.m.errHand = m.m.errHand + 1
m.tstErrHandler.0 = 0
call outPush tstErrHandler
call errSay ggTxt
call outPop
call tstOut m.tst.act, '*** err:' m.tstErrHandler.1
do x=2 to m.tstErrHandler.0
call tstOut m, ' e' (x-1)':' m.tstErrHandler.x
end
return 0
endSubroutine tstErrHandler
tstTrc: procedure expose m.
parse arg msg
m.tst.trc = m.tst.trc + 1
say 'tstTrc' m.tst.trc msg
return m.tst.trc
endProcedure tstTrc
/*--- tstIni: global initialization ----------------------------------*/
tstIni: procedure expose m.
if m.tst.ini \== 1 then do
m.tst.ini = 1
call mapIni
m.tst.err = 0
m.tst.trc = 0
m.tst.errNames = ''
m.tst.tests = 0
m.tst.act = ''
end
if m.tst.ini.j \== 1 & m.j.ini == 1 then do
m.tst.ini.j = 1
call classNew 'n Tst u JRWO', 'm',
, "jReadO return tstReadO(m, var)",
, "jWrite call tstOut m, line",
, "jWriteO call tstWriteO m, var"
end
if m.tst.ini.e \== 1 & m.pipe.ini == 1 then do
m.tst.ini.e = 1
end
return
endProcedure tstIni
/* copx tst end **************************************************/
/* copx tstData begin *************************************************/
tstData: procedure expose m.
parse arg ty 2 le 'n' nu, l, r, num
abs = abs(num)
if nu \== '' then do
if abs // 5 = 0 then
return 'null' || (abs % 5 // nu + 1)
end
if ty = 'c' then do
if le = '' then
le = 8
le = abs // le + 1
if r = '' then
r = '+'
return left(l || num || r, le, right(r, 1))
end
if pos(ty, 'ief') < 1 then
call err 'bad type' ty
nn = abs
if abbrev(num, '-') | abbrev(num, '+') then
parse var num si 2 nn
else
si = ''
if ty == 'e' then
ex = 'e' || left('-', abs // 2) || (abs // 15)
else
ex = ''
if le \== '' then
nn = right(nn, abs // max(1, le - length(si||ex)) + 1, 1)
if ty \== 'i' & (abs // 4) \= 0 & length(nn) > 1 then
nn = overlay('.', nn, length(nn) - abs // length(nn))
return si || nn || ex
endProcedure tstData
tstDataClassFo: procedure expose m.
parse arg flds
ty = ''
do fx=1 by 2 to words(flds)
if word(flds, fx) = '.' then
ty = ty', v'
else
ty = ty', f' word(flds, fx) 'v,'
end
t = classNew('n tstData* u' substr(ty, 2))
fo = oNew(m.t.name)
fs = oFlds(fo)
do fx=1 to m.fs.0
f = fo || m.fs.fx
m.f = word(flds, 2*fx)
end
return fo
endProcedure tstDataClassFo
tstDataClassOut: procedure expose m.
parse arg flds, f, t
fo = tstDataClassFo(flds)
fs = oFlds(fo)
do x=f to t
o = oCopyNew(fo)
do fx=1 to m.fs.0
na = substr(m.fs.fx, 2)
f = o || m.fs.fx
m.f = tstData(m.f, na, '+'na'+', x)
end
call outO o
end
return
endProcedure tstDataClassOut
/* copx tstData end ***************************************************/
/* copy tstAll end **************************************************/
/* copy fmt begin **************************************************/
/*--- format the first arg by the format in the second ---------------*/
fmt: procedure
parse arg v, f 2 l
/* say 'fmt' v',' f l */
if abbrev('-', f) then
return v
else if f == 'l' then
return left(v, l)
else if f == 'r' then
return right(v, l)
else if f == 'f' then do
parse value l'.0.0.' with b '.' a '.' e '.'
return format(v, b, a, e, 0)
end
else if f == 'e' then do
parse var l b '.' a '.' e '.'
if b == '' then b = 2
if a == '' then a = 2
if e == '' then e = 2
res = format(v, b, a, e, 0)
y = length(res)-e-1
if substr(res, y) = '' then
return left(res, y-1)left('E', e+1, 0)
else if substr(res, y+1, 1) == '+' then
return left(res, y)substr(res, y+2)
else if substr(res, y+2, 1) == '0' then
return left(res, y+1)substr(res, y+3)
else
call err 'formatoverflow' f || l 'for' v '-->' res
end
else if f = 's' then
if l == '' then
return strip(v, 't')
else
return strip(v, l)
else if f == 'w' then do
parse var l st ',' le
return substr(v, st, le)
end
else
call err 'bad format' f l 'for' v
endProcedure fmt
/*--- format special (title, null Value also for numbers) ------------*/
fmtS: procedure expose m.
parse arg v, ty 2 l
if ty == 'f' then do
if \ dataType(v, 'n') then do
parse value l'.0.0.' with b '.' a '.' e '.'
return right(v, b + a + (a \== 0) + e + 2 * (e > 0))
end
end
else if ty == 'e' then do
if \ dataType(v, 'n') then do
parse var l b '.' a '.' e '.'
if b == '' then b = 2
if a == '' then a = 2
if e == '' then e = 2
return right(v, b + a + (a \== 0) + e + (e > 0))
end
end
return fmt(v, ty || l)
endProcedure fmtS
/* copy fmt end **************************************************/
/* copy fmtF begin **************************************************/
fmtFCsvAll: procedure expose m.
parse arg fSep
if fSep = '' then
fSep = ','
if \ inO(i) then
return
f = oFlds(i)
li = ''
do fx=1 to m.f.0
li = li',' substr(m.f.fx, 2)
end
call out substr(li, 3)
do until \ inO(i)
li = ''
do fx=1 to m.f.0
if m.f.fx = '' then do
li = li',' m.i
end
else do
fld = substr(m.f.fx, 2)
li = li',' m.i.fld
end
end
call out substr(li, 3)
end
return
endProcedure fmtFCsvAll
fmtFAdd: procedure expose m.
parse arg m
fx = m.m.0
do ax=2 to arg()
fx = fx + 1
parse value arg(ax) with m.m.fx.fld m.m.fx.fmt m.m.fx.tit
end
m.m.0 = fx
return m
endProcedure fmtFAdd
fmtFAddFlds: procedure expose m.
parse arg m, st
fx = m.m.0
do sx=1 to m.st.0
fx = fx + 1
parse value m.st.sx with m.m.fx.fld m.m.fx.fmt m.m.fx.tit
end
m.m.0 = fx
return m
endProcedure fmtFAddFlds
fmtF: procedure expose m.
parse arg m, st
if arg() >= 3 then
mid = arg(3)
else
mid = ' '
li = ''
do fx=1 to m.m.0
f = st || m.m.fx.fld
li = li || mid || fmtS(m.f, m.m.fx.fmt)
end
return substr(li, 1 + length(mid))
endProcedure fmtF
fmtFReset: procedure expose m.
parse arg m
m.m.0 = 0
return m
endProcedure fmtFReset
fmtFWriteAll: procedure expose m.
parse arg m, rdr, wiTi
b = env2buf(rdr)
st = b'.BUF'
if m.st.0 < 1 then
return
if m.m.0 < 1 then
call fmtFAddFlds m, oFlds(st'.1')
call fmtFDetect m, st
if wiTi \== 0 then
call out fmtFTitle(m)
do sx=1 to m.st.0
call out fmtF(m, st'.'sx)
end
return
fmtFWriteAll
fmtFTitle: procedure expose m.
parse arg m
if arg() >= 2 then
mid = arg(2)
else
mid = ' '
li = ''
do fx=1 to m.m.0
if m.m.fx.tit \= '' then
t = m.m.fx.tit
else if m.m.fx.fld = '' then
t = '='
else
t = substr(m.m.fx.fld, 1+abbrev(m.m.fx.fld, '.'))
li = li || mid || fmtS(t, m.m.fx.fmt)
end
return substr(li, 1 + length(mid))
res = ''
fs = m.form.FLDS
do ix=1 to m.fs.0
res = res fmtS(m.fs.ix, m.form.ix)
end
return substr(res, 2)
endProcedure fmtFldTitle
fmtFldTitle: procedure expose m.
parse arg form
res = ''
fs = m.form.FLDS
do ix=1 to m.fs.0
res = res fmtS(m.fs.ix, m.form.ix)
end
return substr(res, 2)
endProcedure fmtFldTitle
fmtFld: procedure expose m.
parse arg form, st
res = ''
fs = m.form.FLDS
do ix=1 to m.fs.0
f = m.fs.ix
res = res fmt(m.st.f, m.form.ix)
end
return substr(res, 2)
endProcedure fmtData
fmtFldSquash: procedure expose m.
parse arg newFo, class, src
fs = oFlds(class)
do fx = 1 to m.fs.0
fd = m.fs.fx
lMi = 9e9
lMa = 0
rMi = 9e9
rMa = 0
len = 0
do sx = 1 to m.src.0
x = verify(m.src.sx.fd, ' ', 'n')
if x < 1 then
iterate
lMi = min(lMi, x)
lMa = max(lMa, x)
x = length(strip(m.src.sx.fd, 't'))
rMi = min(rMi, x)
rMa = max(rMa, x)
end
if rMa = 0 then
m.newFo.fx = 'w1,1'len
else
m.newFo.fx = 'w'lMi',' || (rMa+1-lMi)
end
m.newFo.0 = m.fs.0
m.newFo.flds = fs
return newFo
endProcedure fmtFldSquash
fmtFDetect: procedure expose m.
parse arg m, st
do fx=1 to m.m.0
if m.m.fx.fmt = '' then
m.m.fx.fmt = fmtFDetect1(st, m.m.fx.fld)
end
return m
endProcedure fmtDetect
fmtFDetect1: procedure expose m.
parse arg st, suf
aMa = -1
aCnt = 0
aDiv = 0
nCnt = 0
nMi = ''
nMa = ''
nDi = -1
nBe = -1
nAf = -1
eMi = ''
eMa = ''
do sx=1 to m.st.0
f = st'.'sx || suf
v = m.f
aMa = max(aMa, length(v))
if \ dataType(v, 'n') then do
aCnt = aCnt + 1
if aDiv <=3 then
if aDiv.v \== 1 then do
aDiv.v = 1
aDiv = aDiv + 1
end
iterate
end
nCnt = nCnt + 1
if nMi == '' then
nMi = v
else
nMi = min(nMi, v)
if nMa == '' then
nMa = v
else
nMa = max(nMa, v)
parse upper var v man 'E' exp
if exp \== '' then do
en = substr(format(v, 2, 2, 9, 0), 7)
if en = '' then
en = exp
if eMi == '' then
eMi = en
else
eMi = min(eMi, en)
if eMa == '' then
eMa = en
else
eMa = max(eMa, en)
end
parse upper var man be '.' af
nBe = max(nBe, length(be))
nAf = max(nAf, length(af))
nDi = max(nDi, length(be || af))
end
say 'suf' suf aCnt 'a len' aMa 'div' aDiv
say ' ' nCnt 'n' nMi'-'nMa 'be' nBe 'af' nAf,
'di' nDi 'ex' eMi'-'eMa
if nCnt = 0 | aDiv > 3 then
newFo = 'l'max(0, aMa)
else if eMi \== '' then do
eMa = max(eMa, substr(format(nMa, 2, 2, 9, 0), 7))
newFo = 'e' || (1+(eMi < 0)) || '.' || (max(0, nDi-1))'.' ,
|| max(length(eMa+0), length(eMi+0))
end
else if nAf > 0 then
newFo ='f'nBe'.'nAf
else
newFo ='f'nBe'.0'
say ' ' newFo
return newFo
endProcedure fmtFDetect1
fmtFldRW: procedure expose m.
parse arg fo
ty = oGetClassPara(m.j.in)
call assert 'oFlds(ty) == m.fo.flds', 'fo different flds than class'
call out fmtFldTitle(fo)
do while in(ii)
call out fmtFld(fo, ii)
end
return
endProcedure fmtClassRW
fmtFldSquashRW: procedure expose m.
parse arg in, opCl
if in = '' then
in = m.j.in
if opCl == 'opCl' then
call jOpen in, 'r'
ty = oGetClassPara(in)
flds = oFlds(ty)
st = 'FMT.CLASSAD'
do ix=1 while jRead(in, st'.'ix)
end
m.st.0 = ix - 1
fo = fmtFldSquash(sqFo, ty, st)
call out fmtFldTitle(fo)
do ix = 1 to m.st.0
call out fmtFld(fo, st'.'ix)
end
if opCl == 'opCl' then
call jClose in
return
endProcedure fmtFldSquashRW
/* copy fmtF end * **************************************************/
/* copy sort begin ****************************************************/
sort: procedure expose m.
parse arg i, o, cmp
if cmp == '' then
m.sort.comparator = "cmp = m.l.l0 <<= m.r.r0"
else if length(cmp) < 6 then
m.sort.comparator = "cmp = m.l.l0" cmp "m.r.r0"
else if pos(';', cmp) < 1 then
m.sort.comparator = "aLe = l'.'l0; aRi = r'.'r0; cmp =" cmp
else
m.sort.comparator = "aLe = l'.'l0; aRi = r'.'r0;" cmp
call sort1 i, 1, m.i.0, o, 1, sort.work, 1
m.o.0 = m.i.0
return
endProcedure sort
sort1: procedure expose m.
parse arg i, i0, le, o, o0, w, w0
if le <= 3 then do
if le = 3 then do
call sortMerge i, i0, i0+1, i, i0+1, i0+2, w, w0
call sortMerge i, i0+2, i0+3, w, w0, w0+2, o, o0
end
else if le = 2 then
call sortMerge i, i0, i0+1, i, i0+1, i0+2, o, o0
else if le = 1 then
m.o.o0 = m.i.i0
return
end
h = (le + 1) % 2
call sort1 i, i0, h, o, o0+le-h, w, w0
call sort1 i, i0+h, le-h, w, w0, o, o0
call sortMerge o, o0+le-h, o0+le, w, w0, w0+le-h, o, o0
return
endProcedure sort1
sortMerge: procedure expose m.
parse arg l, l0, le, r, r0, re, o, o0
do while l0 < le & r0 < re
interpret m.sort.comparator
if cmp then do
m.o.o0 = m.l.l0
l0 = l0 + 1
end
else do
m.o.o0 = m.r.r0
r0 = r0 + 1
end
o0 = o0 + 1
end
do while l0 < le
m.o.o0 = m.l.l0
l0 = l0 + 1
o0 = o0 + 1
end
do while r0 < re
m.o.o0 = m.r.r0
r0 = r0 + 1
o0 = o0 + 1
end
return
endProcedure sortMerge
/* copy sort end ****************************************************/
/* copy match begin ***************************************************/
/************************************* begin copy match ******/
/*--- wildCard matching with the following wildchars:
* 0-n chars
? 1 char
fill matched expressions instem st if st is non empty
return 1 if mask matches wert ----------------------------------*/
match: procedure expose m.
parse arg wert, mask, st
if st == '' then
return matchRO(wert, mask)
m.st.0 = -9
return matchSt(wert, mask, st, 0)
endProcedure match
/*--- return the fixed prefix of maskt -------------------------------*/
matchPref: procedure
arg mask, suff
ix = verify(mask, '*?', 'm')
if ix = 0 then
return mask
else
return left(mask, ix-1)suff
endProcedure matchPref
/*--- return true if mask matches wert -------------------------------*/
matchRO: procedure
arg wert, mask
ix = verify(mask, '*?', 'm')
if ix < 1 then return (mask == wert)
if length(wert) < ix-1 then return 0
if left(mask, ix-1) \== left(wert, ix-1) then return 0
if substr(mask, ix, 1) == '?' then do
if length(wert) < ix then return 0
return matchRO(substr(wert, ix+1), substr(mask, ix+1))
end
mask = substr(mask, ix+1) /* * 0 - n Chars */
do ex = 1+length(wert) to ix by -1
if matchRO(substr(wert, ex), mask) then return 1
end
return 0
endProcedure matchRO
/*--- wildCard matching: fill matched expressions instem st
return 1 if mask matches wert ----------------------------------*/
matchSt: procedure expose m.
parse arg wert, mask, st, sx
ix = verify(mask, '*?', 'm')
if ix < 1 then do
if mask \== wert then
return 0
m.st.0 = sx
return 1
end
if \ abbrev(wert, left(mask, ix-1)) then
return 0
reMa = substr(mask, ix+1)
sx = sx + 1
if substr(mask, ix, 1) == '?' then do /* ? 1 Character */
if length(wert) < ix then
return 0
m.st.sx = substr(wert, ix, 1)
return matchSt(substr(wert, ix+1), reMa, st, sx)
end
do lx = 1+length(wert) to ix by -1 /* greedy: from all to empty */
if matchSt(substr(wert, lx), reMa, st, sx) then do
m.st.sx = substr(wert, ix, lx-ix)
return 1
end
end
return 0
endProcedure matchSt
matchTrans: procedure expose m.
parse arg mask, st
r = ''
ox = 1
sx = 0
ix = verify(mask, '*?', 'm')
do sx=1 to m.st.0 while ix > 0
if sx > m.st.0 then
call err 'matchTrans('mask',' st') has only' ,
m.st.0 'variables'
r = r || substr(mask, ox, ix-ox)m.st.sx
ox = ix+1
ix = verify(mask, '*?', 'm', ox)
end
if ix > 0 then
call err 'matchTrans('mask',' st') has only' ,
m.st.0 'variables'
return r || substr(mask, ox)
endProcedure matchTrans
/* copy match end *****************************************************/
/* copy comp begin *****************************************************
the shell compiler
syntax and semantics of the shell language see javaDoc
***********************************************************************/
/*--- module initialisation ------------------------------------------*/
compIni: procedure expose m.
if m.compIni = 1 then
return
m.compIni = 1
call pipeIni
call scanReadIni
cc = classNew('n Compiler u')
m.comp.stem.0 = 0
m.comp.idChars = m.scan.alfNum'@_'
return
endProcedure compIni
/*--- constructor of Compiler ----------------------------------------*/
comp: procedure expose m.
parse arg src
nn = oNew('Compiler')
m.nn.cmpRdr = src
return nn
endProcedure comp
m.nn.cmpRdr = scanRead(src)
return compReset(nn, src)
compReset: procedure expose m.
parse arg m
m.m.scan = scanRead(,,'|0123456789')
m.m.chDol = '$'
m.m.chSpa = ' ' || x2c('09')
m.m.chNotBlock = '${}='
m.m.chNotWord = m.m.chNotBlock || m.m.chSpa
m.m.chKind = '.-=#@'
m.m.chKinC = '.-=@'
return m
endProcedure compReset
/*--- push an empty stem on the stack --------------------------------*/
compNewStem: procedure expose m.
parse arg m
st = mAdd('COMP.STEM', '')
do ix=1 to arg()-1
m.st.ix = arg(ix+1)
end
m.st.0 = ix-1
return st
endProcedure compNewStem
/*--- compile the source and return an oRunner with the code ---------*/
compile: procedure expose m.
parse arg m, spec
call compReset m
s = m.m.scan
kind = '@'
spec = strip(spec)
do while pos(left(spec, 1), m.m.chKinC) > 0
kind = left(spec, 1)
spec = strip(substr(spec, 2))
end
call scanSrc s, spec
call compSpComment m
m.m.dirKind = kind
m.m.compSpec = 1
res = oRunner()
nxt = res
doClose = 0
do cx=1 to 100
m.m.dir = ''
kind = m.m.dirKind
if kind == '@' then do
what = "shell"
expec = "pipe or $;";
call compSpNlComment m
src = comp2Code(m, ';'compShell(m))
end
else do
what = "data("kind")";
expec = "sExpression or block";
src = comp2Code(m, ';'compData(m, kind))
end
if m.m.dir == '' then
call compDirective m
if m.m.dir == '' then
return scanErr(s, expec "expected: compile" what ,
" stopped before end of input")
if abbrev(m.m.dir, '$#') then
if \ scanLit(s, m.m.dir) then
call scanErr m.m.scan 'directive' m.m.dir 'mismatch'
if src \== '' then do
call oRunnerCode nxt, src
nxt = m.m.dirNext
end
if wordPos(m.m.dir, 'eof next $#end $#out') > 0 then do
if doClose then
call jClose s
if m.m.dir \== 'next' | \ m.m.compSpec then
return res
call scanReadReset s, m.m.cmpRdr
doClose = jOpenIfNotYet(s)
m.m.compSpec = 0
end
end
call scanErr s, 'loop in compile'
endProcedure compile
compDirective: procedure expose m.
parse arg m, ki
if m.m.dir \== '' then
return ''
lk = scanLook(m.m.scan, 9)
if abbrev(lk, '$#') then do
if pos(substr(lk, 3, 1), m.m.chKinC) > 0 then do
m.m.dirKind = substr(lk, 3, 1)
m.m.dir = left(lk, 3)
end
else if abbrev(lk, '$#end') then do
m.m.dir = 'eof'
return ''
end
else
call scanErr m.m.scan, 'bad directive after $#'
end
else if scanAtEnd(m.m.scan) then do
if \ m.m.compSpec | m.m.cmpRdr == '' then do
m.m.dir = 'eof'
return ''
end
m.m.dir = 'next'
end
else do
return ''
end
m.m.dirNext = oRunner()
if ki == '@' then
return "; call oRun '"m.m.dirNext"'"
else
return ". '"m.m.dirNext"'"
endProcedure compDirective
/*--- compile data lines return stmts or expr ------------------------*/
compData: procedure expose m.
parse arg m, ki
s = m.m.scan
lines = compNewStem(m)
do forever
state = 'f'
do forever
l = compExpr(m, 'd', ki)
if \ scanReadNL(s) then
state = 'l'
if \ compIsEmpty(m, l) | (state=='' &\abbrev(l, 'c')) then
call mAdd lines, l
if state == 'l' then
leave
call compComment m
state = ''
end
one = compStmt(m)
if one == '' then
leave
call mAdd lines, one
call compComment m
end
return 'l*' lines
endProcedure compData
/*--- compile shell and return code ----------------------------------*/
compShell: procedure expose m.
parse arg m
res = ''
do forever
one = compPipe(m)
if one \== '' then
res = res || one
if \ scanLit(m.m.scan, '$;') then
return res
call compSpNlComment m
end
endProcedure compShell
/*--- compile an expression, type d=data, w=word, s=strip ------------*/
compExpr: procedure expose m.
parse arg m, type, ki
s = m.m.scan
if length(type) \== 1 | pos(type, 'dsb') < 1 then
call scanErr s, 'bad type' type 'in compExpr(,' type','ki ')'
if length(ki) \== 1 | pos(ki, m.m.chKind';') < 1 then
call scanErr s, 'bad kind' ki 'in compExpr(,' type','ki ')'
charsNot = if(type=='b', m.m.chNotBlock, m.m.chDol)
laTx = 9e9
st = compNewStem(m)
gotCom = 0
if pos(type, 'sb') > 0 then do
call compSpComment m
gotCom = gotCom | m.m.gotComment
end
ki2 = if(ki=='=', '-=', ki)
do forever
if scanVerify(s, charsNot, 'm') then do
call mAdd st, ki2 m.s.tok
laTx = min(laTx, m.st.0)
end
else do
pr = compPrimary(m, ki)
if pr = '' then
leave
call mAdd st, pr
laTx = 9e9
end
gotCom = gotCom | compComment(m)
end
do rx = m.st.0 by -1 to laTx while m.st.rx = ki2
end
if pos(type, 'bs') > 0 then do
if rx >= laTx then
m.st.rx = strip(m.st.rx, 't')
m.st.0 = rx
end
if ki == '=' then
if m.st.0 < 1 then
return 'e='
else
ki = '-'
return substr('ce', 2-gotCom, rx < 1)ki'0*' st
endProcedure compExpr
/*--- transform abstract syntax tree to code ------------------------
wkTst??? codeTree besser dokumentieren
optimizer an/und/abschaltbar machen
(test sollte laufen, allenfalls gehen rexx variabeln
verloren)
syntax tree is simple, only where
* a transformation is needed from several places or
* must be deferred for possible optimizations
sn = ops* syntax node op or syntax function
( '=' constant none
| '-' rexxExpr yielding string cast to string
| '.' rexxExpr yielding object cast to object
| '<' rexxExpr yielding file cast to file
| ';' rexxStmts execute, write obj, Str
| '*' stem yielding multiple sn none
)
ops = '@' cast to ORun
| '|' single
| 'e' empty = space only
| 'c' empty = including a comment
| '0' cat expression parts
| 'l' cat lines
| '(' add ( ... ) or do ... end
---------------------------------------------------------------------*/
comp2Code: procedure expose m.
parse arg m, ki expr
/* wkTst??? optimize: use stem with code and interpret */
if expr = '' & pos(right(ki, 1), '@;=') < 1 then
return scanErr(m.m.scan, 'comp2Code empty expr' ki expr)
do forever
ki = comp2CodeKind(m, ki)
if length(ki) <= 1 then
if pos(ki, m.m.chKind';<') > 0 then
return expr
else
call err 'comp2Code bad return' ki expr
fr = right(ki, 1)
to = substr(ki, length(ki)-1, 1)
opt = ''
if pos(to, 'l0') > 0 then do
opt = to
to = substr(ki, length(ki)-2, 1)
end
nn = '||||'
if fr == '*' then do
if opt == '' then
call scanErr m.m.scan, 'no sOp for * kind' ki expr
cat = comp2CodeCat(m, expr, opt, to)
parse var cat to nn
end
else if to == '-' then do
if fr == '=' then
nn = quote(expr)
else if abbrev(fr expr, '. envGetO(') then
nn = 'envGet(' || substr(expr, 9)
else if fr == ';' then
nn = "o2String('"oRunner(expr)"')"
else if pos(fr, '.<') > 0 then
nn = "o2String("expr")"
end
else if to == '.' then do
if fr == '=' then
nn = quote(s2o(expr))
else if abbrev(fr expr, '- envGet(') then
nn = 'envGetO('substr(expr, 8)
else if fr == '-' then
nn = 's2o('expr')'
else if fr == '<' then
nn = expr
else if fr == ';' then
nn = quote(oRunner(expr))
end
else if to == '@' then do
if fr == '.' then
nn = 'call oRun' expr
else if fr == '<' then
nn = 'call pipeWriteAll' expr
else if fr == ';' then
nn = expr
to = ';'
end
else if to == ';' then do
if fr == '=' then
nn = 'call out' quote(expr)
else if fr == '-' then
nn = 'call out' expr
else if fr == '.' then
nn = 'call outO' expr
else if fr == '<' then
nn = 'call pipeWriteAll ' expr
end
else if to == ':' then do
if fr == '=' then
nn = quote(expr)
else
nn = expr
to = ';'
end
else if to == '<' then do
if fr == '-' then
nn = 'file('expr')'
else if fr == '=' then
nn = "file("quote(expr)")"
else if fr == '.' then
nn = 'o2File('expr')'
else if fr == ';' then
nn = 'o2File('oRunner(expr)')'
end
else if to == '(' then do
nn = compAddBracks(m, fr, expr)
to = fr
end
if nn == '||||' then
return scanErr(m.m.scan,
,'comp2code bad fr' fr 'to' to 'for' ki expr)
ki = left(ki, length(ki)-2-length(opt))to
expr = nn
end
endProcedure comp2Code
/*--- optimize operands: eliminate duplicates and
identity transformations -------------------*/
comp2CodeKind: procedure expose m.
parse arg m, ki
ki = '$'space(translate(ki, ' ', 'ce'), 0)
fr.2 = '== -- .. << ;; (( -( .( ;( (< @; @@ ;@ $l $0'
to.2 = '= - . < ; ( (- (. (; < ; @ @ $ $'
fr.3 = ';0; ;l; -.- -;- .-. .;. ;<; <(; '
to.3 = ' 0; l; - - . . ; <; '
do until ki = oldKi
oldKi = ki
do le=3 by-1 to 2
do cx=1 while cx <= length(ki)+1-le
wx = wordPos(substr(ki, cx, le), fr.le)
if wx > 0 then
ki = left(ki, cx-1) || ,
word(to.le, wx) || substr(ki, cx+le)
end
end
end
return substr(ki, 2)
endProcedure comp2CodeKind
/*--- generate one codeString for one stem -------------------------*/
comp2CodeCat: procedure expose m.
parse arg m, st, sOp, trgt
toCode = trgt == '@' | trgt == ';'
if m.st.0 < 1 & trgt \== '<' then
return trgt
tr1 = trgt
if \ toCode then do
/* check wether we need to evaluate statements
and cast the outptut to an object */
maxTy = 0
do x=1 to m.st.0
maxTy = max(maxTy, pos(left(m.st.x, 1), '=-.<;@'))
end
if trgt \== '<' then do
if maxTy >= 5 then do
tr1 = ';'
toCode = 1
end
end
else do /* handle files */
if maxTy > 1 then do /* not constant */
res = ';'
do sx=1 to m.st.0
res = res';' comp2Code(m, ';'m.st.sx)
end
return '<'res
end
/* constant file write to jBuf */
buf = jOpen(jBuf(), m.j.cWri)
do sx=1 to m.st.0
call jWrite buf, substr(m.st.sx, 3)
end
return '<' quote(jClose(buf))
end
end
if m.st.0 = 1 & trgt \== '<' then
return trgt comp2Code(m, trgt || m.st.1)
tr2 = tr1
if toCode then do
mc = '; '
if sOp == 0 then do
mc = ''
tr2 = ':'
end
end
else if sOp == '0' then
mc = if(tr1 == '.' | tr1 == '-', '', ' || ')
else if sOp == 'l' then
mc = ' '
else
call scanErr m.m.scan, 'bad sOp' sOp ,
'in comp2CodeCat('m',' st',' sOp',' trgt')'
if symbol('m.st.1') \== 'VAR' then
return err("bad m."st'.1')
sep = if(tr1 == '.' | tr1 == '-' | tr1 == '=', ' || ', ' ')
sep = if(sOp = 0, ' || ', ' ')
tr3 = left(tr2, sOp \== 0)
res = comp2Code(m, tr3 || m.st.1)
do sx = 2 to m.st.0
if (tr2 == '.' | tr2 == '-') ,
& (m.st.sx = '-' | m.st.sx = '.') then do
/* empty expr is simply a rexx syntax space */
if right(res, 1) \== ' ' then
res = res' '
end
else do
act = comp2Code(m, tr3 || m.st.sx)
res = compCatRexx(res, act, mc, sep)
end
end
return copies(trgt || sOp, tr1 \== trgt)tr1 res
endProcedure comp2CodeCat
/*--- add expression brackets if necessary --------------------------*/
compAddBracks: procedure expose m.
parse arg m, ki, ex
if ki == ';' then
return 'do;' ex || left(';', ex \= '') 'end'
if \ (ki == '.' | ki == '-') then
return ex
ex = strip(ex)
e1 = left(ex, 1)
if e1 == '(' & pos('(', ex, 2) = 0 & pos(')', ex) = length(ex) then
return ex
if pos(e1, '"''') > 0 & pos(e1, ex, 2) = length(ex) then
return ex
return '('ex')'
endProcedure compAddBracks
/*--- cat two rexx parts, avoid strange effects--------------------*/
compCatRexx: procedure expose m.
parse arg le, ri, mi, sep
if mi \== '' then
return le || mi || ri
lr = right(le, 1)
rl = left(ri, 1)
if (lr == "'" | lr == '"') then do
if rl == lr then /* "a","b" -> "ab" */
return left(le, length(le)-1) || substr(ri, 2)
else if rl == '(' then /* "a",( -> "a" || ( */
return le||sep||ri /* avoid function call */
end
else if pos(lr, m.comp.idChars) > 0 then
if pos(rl, m.comp.idChars'(') > 0 then
return le || sep || ri /* a,b -> a || b */
return le || mi || ri
endProcedure compCatRexx
/*--- compile a primary and return code ------------------------------*/
compPrimary: procedure expose m.
parse arg m, ki
s = m.m.scan
if \ scanLit(s, '$') then
return ''
if scanString(s) then /*wkTst??? brauchts beides? */
return translate(ki, '.--', '@;=')'=' m.s.val
if scanLit(s, '.', '-') then do
op = m.s.tok
return op'('compCheckNN(m, compObj(m, op),
, 'objRef expected after $'op)
end
if pos(ki, '.<') >= 1 then
f = '. envGetO'
else
f = '- envGet'
if scanLit(s, '{') then do
if scanLit(s, '?') then
f = '- envIsDefined'
else if scanLit(s, '>') then
f = '- envReadO'
res = compCheckNE(m, compExpr(m, 'b', '='), 'var name')
if \scanLit(s, '}') then
call scanErr s, 'closing } missing after ${'
return f'(' || comp2Code(m, '-'res)')'
end
if scanName(s) then
return f"('"m.s.tok"')"
call scanBack s, '$'
return ''
endProcedure compPrimary
/*--- compile a pipe and return code ---------------------------------*/
compPipe: procedure expose m.
parse arg m
s = m.m.scan
ios = ''
stmts = ''
stmtLast = ''
do forever
io1 = compRedirIO(m, 1)
if io1 \== '' then do
ios = ios',' io1
call compSpNlComment m
end
else do
if stmtLast \== '' then do
if \ scanLit(s, '$|') then
leave
call compSpNlComment m
end
one = comp2code(m, ';'compStmts(m))
if one == '' then do
if stmtLast \== '' then
call scanErr s, 'stmts expected after $|'
if ios == '' then
return ''
leave
end
if stmtLast \== '' then
stmts = stmts'; call pipe' || stmtLast
stmtLast = ';' one
end
end
if stmts \== '' then
stmtLast = insert('Begin', stmts, pos('pipe;', stmts)+3) ,
|| '; call pipeLast' stmtLast'; call pipeEnd'
if ios \== '' then do
if stmtLast == '' then
stmtLast = '; call pipeWriteAll'
stmtLast = '; call pipeBeLa 'substr(ios, 3) || stmtLast';' ,
'call pipeEnd'
end
return stmtLast
endProcedure compPipe
/*--- compile an io redirection, return
if makeExpr then "option", expr
else code write inut to standard out -------------*/
compRedirIO: procedure expose m.
parse arg m
s = m.m.scan
if \ scanLit(s, '$<', '$>>', '$>') then
return ''
opt = substr(m.s.tok, 2)
return "'"opt"'" comp2Code(m, compFile(m))
endProcedure compRedirIO
/*--- compile stmts (stmt or java) -----------------------------------*/
compStmts: procedure expose m.
parse arg m
lst = compNewStem(m)
do forever
one = compStmt(m)
if one == '' then do
do forever
la = compExpr(m, 's', ';')
if compIsEmpty(m, la) then
leave
la = strip(comp2code(m, ';'la))
if right(la, 1) \== ',' then do
one = one la
leave
end
one = one strip(left(la, length(la)-1))
call compSpNlComment m
end
if one = '' then
return 'l*' lst
one = ';' one
end
call mAdd lst, one
call compSpNlComment m
end
endProcedure compStmts
/* wkTst???syntax start */
/*--- compile a single statement -------------------------------------*/
compStmt: procedure expose m.
parse arg m
s = m.m.scan
if scanLit(s, "$=") then do
nm = comp2Code(m, '-'compCheckNE(m,
, compExpr(m, 'b', '='), "variable name after $="))
if \ scanLit(s, "=") then
call scanErr s, '= expected after $=' nm
vl = compCheckNE(m, compBlockExpr(m, '='),
, 'block or expression after $=' nm '=')
if abbrev(vl, '-') then
return '; call envPut' nm',' comp2Code(m, vl)
else
return '; call envPutO' nm',' comp2Code(m, '.'vl)
end
if scanLit(s, '$@') then do
if \ scanName(s) then
return 'l;' comp2Code(m,
, '@'compCheckNN(m, compObj(m, '@'),
, "objRef expected after $@"))
fu = m.s.tok
if fu == 'for' then do
v = comp2Code(m, '-'compCheckNE(m, compExpr(m, 'b', '='),
, "variable name after $@for"))
call compSpComment m
st = comp2Code(m, ';'compCheckNN(m, compStmt(m),
, "statement after $@for" v))
return '; do while envReadO('v');' st'; end'
end
if fu == 'do' then do
call compSpComment m
var = if(scanName(s), m.s.tok, '')
pre = var
call compSpComment m
if scanLook(s, 1) \== '=' then
var = ''
suf = comp2Code(m, ':'compCheckNE(m, compExpr(m, 's', ';'),
, "$@do control construct"))
call compSpComment m
st = comp2Code(m, ";"compCheckNN(m, compStmt(m),
, "$@do statement"))
return "; do" pre suf";",
if(var \== "", "call envPut '"var"'," var";") st"; end"
end
if fu == 'ct' then do
call compSpComment m
call compInter(comp2Code(m, ';'compCheckNN(m, compStmt(m),
, 'ct statement')));
return '; '
end
if fu == 'proc' then do
nm = compCheckNE(m, compExpr(m, 'b', '='), "proc name")
call compSpComment m
st = oRunner(comp2Code(m, ';'compCheckNN(m, compStmt(m),
, 'proc statement')));
call envPutO compInterEx(comp2Code(m, '-'nm)), st
return '; '
end
if \ scanLit(s, '(') then
call scanErr s, 'procCall, for, do, ct, proc' ,
'or objRef expected after $@'
call compSpComment m
if \ scanLit(s, ')') then
call scanErr s, 'closing ) expected after $@'fu'('
return '; call oRun envGetO("'fu'")'
end
if scanLit(s, '$$') then
return compCheckNN(m, compBlockExpr(m, '='),
, 'block or expression expected after $$')
return compDirective(m, '@')
endProcedure compStmt
/* wkTst???syntax end */
compInter: procedure expose m.
interpret arg(1)
return
endProcedure compInter
compInterEx: procedure expose m.
interpret 'return' arg(1)
endProcedure compInterEx
compBlockExpr: procedure expose m.
parse arg m, ki
s = m.m.scan
res = compBlock(m, ki)
if res \== '' then
return res
lk = scanLook(s, 1)
if pos(lk, m.m.chKind) > 0 then
call scanChar s, 1
else
lk = ki
return compExpr(m, 's', lk)
endProcedure compBlockExpr
compObj: procedure expose m.
parse arg m, ki
one = compPrimary(m, translate(ki, '.', '@'))
if one \== '' then
return one
ki = translate(ki, ';', '@')
one = compBlock(m, ki)
if one \== '' then
return ki || one
s = m.m.scan
if scanLit(s, '<') then
return compFile(m)
if scanLit(s, 'compile') then do
if pos(scanLook(s, 1), m.m.chKind) < 1 then
call scanErr s, 'compile kind expected'
call scanChar s, 1
return ki'. compile(comp(env2Buf()), "'m.s.tok'")'
end
return compDirective(m, ki)
endProcedure compObj
compFile: procedure expose m.
parse arg m
res = compBlock(m, '=')
if res \== '' then
return '<;'res
s = m.m.scan
ki = scanLook(s, 1)
if pos(ki, m.m.chKind) > 0 then do
call scanLit s, ki
end
else do
ki = '='
res = compDirective(m, '.')
if res \== '' then
return '<'res
end
res = compCheckNE(m, compExpr(m, 's', ki),
, 'block or expr expected for file')
return '<'res
endProcedure compFile
compBlock: procedure expose m.
parse arg m, ki
s = m.m.scan
t2 = scanLook(s, 2)
hasType = pos(left(t2, 1) , m.m.chKind) > 0
start = substr(t2, hasType+1, 1)
if pos(start, '{¢/') < 1 then
return ''
if hasType then
ki = translate(left(t2, 1), ';', '@')
if \ scanLit(s, left(t2, hasType+1)) then
call scanErr s, 'compBlock internal 1'
starter = start
if start == '{' then
stopper = '}'
else if start == '¢' then
stopper = '$!'
else do
call scanVerify s, '/', 'm'
starter = '/'m.s.tok'/'
stopper = '$'starter
if \scanLit(s, '/') then
call scanErr s, 'ending / after stopper' stopper 'expected'
end
if start == '{' then do
res = compNewStem(m)
if ki == '#' then do
tx = '= '
cb = 1
do forever
call scanVerify s, '{}', 'm'
tx = tx || m.s.tok
if scanLit(s, '{') then
cb = cb + 1
else if scanLook(s, 1) \== '}' then
call scanErr s, 'closing } expected'
else if cb <= 1 then
leave
else if scanLit(s, '}') then
cb = cb - 1
else
call scanErr s, 'closing } programming error'
tx = tx || m.s.tok
end
call mAdd res, tx
end
else do
one = compExpr(m, 'b', ki)
if one \== '' & \ abbrev(one, 'e') then
call mAdd res, one
end
res = 'l*' res
end
else if ki == '#' then do
res = compNewStem(m)
call compSpComment m
if \ scanReadNl(s) then
call scanErr s,
, 'space nl expected in heredata after' starter
do while \ abbrev(m.s.src, stopper)
call mAdd res, '=' strip(m.s.src, 't')
if \ scanReadNl(s, 1) then
call scanErr s, 'eof in heredata after' starter
end
res = 'l*' res
end
else if ki == ';' then do
call compSpNlComment m
res = compShell(m)
end
else if ki == '@' then do
call err 'compBlock bad ki' ki
end
else do
res = compData(m, ki)
if res == '' then
res = 'l*' compNewStem(m)
end
if \ scanLit(s, stopper) then
call scanErr s, 'ending' stopper 'expected after' starter
if res = '' then
return '('ki
else
return '('res
endProcedure compBlock
/*--- if va == null then issue an error with msg --------------------*/
compCheckNN: procedure expose m.
parse arg m, va, msg
if va == '' then
call scanErr m.m.scan, msg 'expected'
return va
endProcedure compCheckNN
/*--- return true iff expression is empty ---------------------------*/
compIsEmpty: procedure expose m.
parse arg m, ex
e1 = left(ex, 1)
return ex = '' | pos(e1, 'ce') > 0 | e1 = ex
endProcedure compIsEmpty
/*--- if va == null or empty then issue an error with msg -----------*/
compCheckNE: procedure expose m.
parse arg m, ex, msg
e1 = left(ex, 1)
if compIsEmpty(m, ex) then
call scanErr m.m.scan, msg 'expected'
return ex
endProcedure compCheckNE
/*--- skip a comment. return 0 if there is none ----------------------*/
compComment: procedure expose m.
parse arg m
s = m.m.scan
res = 0
do forever
if scanLit(s, '$**') then
m.s.pos = 1 + length(m.s.src) /* before next nl */
else if scanLit(s, '$*+') then
call scanReadNl s, 1
else if scanLit(s, '$*(') then do
do forever
if scanVerify(s, m.m.chDol, 'm') then iterate
if scanReadNl(s) then iterate
if compComment(m) then iterate
if \ scanLit(s, '$') then
call scanErr s, 'source end in comment'
if scanLit(s, '*)') then
return 1
if scanLit(s, '$') then iterate
if scanString(s) then iterate
end
end
else
return res
res = 1
end
endProcedure compComment
/*--- skip spaces and comments ---------------------------------------*/
compSpComment: procedure expose m.
parse arg m
sp = 0
co = 0
do forever
if scanVerify(m.m.scan, m.m.chSpa) then
sp = 1
else if compComment(m) then
co = 1
else
leave
end
m.m.gotComment = co
return co | sp
endProcedure compSpComment
/*--- skip spaces, NLs and comments ----------------------------------*/
compSpNlComment: procedure expose m.
parse arg m
found = 0
do forever
if compSpComment(m) then
found = 1
else if scanReadNl(m.m.scan) then
found = 1
else
return found
end
endProcedure compSpComment
/* copy comp end ******************************************************/
/* copy scan begin ****************************************************
Scan: scan an input:
scanLine(m,ln) : begin scanning a single line (string)
scanRead??(m,ln): begin scanning all lines of an opened reader
scanAtEnd(m) : returns whether we reached end of input
scanLit(m,lit) : scan Literal lit if present or return 0
scanChar(m,n) : scan next n characters
scanName(m) : scan a name
ScanNat(m) : scan a natural number (without sign)
scanString(m,q): scan a String with quote q. (with doubble = 1)
scanVerify(m,c,o): verify(...,c,o,...)
scanKeyValue(m): scan a key = value clause (with spaces)
scanWord(m,u) : scan a space delimited word or a string,
if u=1 then uppercase non-strings
scanErr(m, txt): error with current scan location
m is an adress, to store our state
if a scan function succeeds, the scan posititon is moved
returns: true if scanned, false otherwise
m.m.tok ==> last token
m.m.val ==> last value for scanString/Word/KeyValue
m.key ==> key for scanKeyValue
m.m.pos ==> scan position
m.m.src ==> scan source
***********************************************************************/
scanIni: procedure expose m.
if m.scan.ini == 1 then
return
m.scan.ini = 1
m.scan.alfLC = 'abcdefghijklmnopqrstuvwxyz'
m.scan.alfUC = translate(m.scan.alfLC)
m.scan.alfa = m.scan.alfLC || m.scan.alfUC
m.scan.alfNum = m.scan.alfa || '0123456789'
return
endProcedure scanIni
scanReset: procedure expose m.
parse arg m, n1, np, co
m.m.rdr = ''
m.m.jReading = 0 /* if called without jReset */
m.m.jWriting = 0
return scanOpts(m, n1, np, co)
endProcedure scanReset
scanOpts: procedure expose m.
parse arg m, m.m.scanName1, namePlus, m.m.scanComment
if m.m.scanName1 == '' then
m.m.scanName1 = m.scan.alfa
if namePlus == '' then
m.m.scanNameR = m.m.scanName1 || '0123456789'
else
m.m.scanNameR = m.m.scanName1 || namePlus
return m
endProcedure scanOpts
/*--- begin scanning a single line -----------------------------------*/
scanSrc: procedure expose m.
parse arg m, m.m.src
return scanOpen(m)
endProcedure scanSrc
scanOpen: procedure expose m.
parse arg m
m.m.tok = ''
m.m.val = ''
m.m.key = ''
m.m.pos = 1
m.m.atEnd = m.m.rdr == ''
m.m.jReading = 1
return m
endProcedure scanOpen
/*--- return the next len characters ---------------------------------*/
scanLook: procedure expose m.
parse arg m, len
if len == '' then
return substr(m.m.src, m.m.pos)
else
return substr(m.m.src, m.m.pos,
, min(len, 1 + length(m.m.src) - m.m.pos))
endProcedure scanLook
/*--- scan the literal lit ------------------------------------------*/
scanLit: procedure expose m.
parse arg m
do ax=2 to arg()
if abbrev(substr(m.m.src, m.m.pos), arg(ax)) then do
m.m.tok = arg(ax)
m.m.pos = m.m.pos + length(arg(ax))
return 1
end
end
m.m.tok = ''
return 0
endProcedure scanLit
/*--- scan the next len characters -----------------------------------*/
scanChar: procedure expose m.
parse arg m, len
nx = 1 + length(m.m.src)
if len \= '' then
nx = min(m.m.pos + len, nx)
m.m.tok = substr(m.m.src, m.m.pos, nx - m.m.pos)
m.m.pos = nx
return m.m.tok \== ''
endProcedure scanChar
/*--- scan a string with quote char qu -------------------------------*/
scanString: procedure expose m.
parse arg m, prefs
m.m.tok = ''
bx = m.m.pos
if prefs = '' then do
qu = substr(m.m.src, bx, 1)
if pos(qu, "'""") < 1 then
return 0
ax = bx + 1
end
else do
do px=1 until abbrev(substr(m.m.src, bx), p1)
p1 = word(prefs, px)
if p1 = '' then
return 0
end
qu = right(p1, 1)
ax = bx + length(p1)
end
m.m.val = ''
do forever
qx = pos(qu, m.m.src, ax)
if qx < 1 then
return scanErr(m, 'ending Apostroph('qu') missing')
m.m.val = m.m.val || substr(m.m.src, ax, qx-ax)
if qx >= length(m.m.src) then
leave
else if substr(m.m.src, qx+1, 1) <> qu then
leave
ax = qx+2
m.m.val = m.m.val || qu
end
m.m.tok = substr(m.m.src, bx, qx+1-bx)
m.m.pos = qx+1
return 1
endProcedure scanString
/*--- scan a Name, first char in *.scanName1, rest in *.scanNameR ----*/
scanName: procedure expose m.
parse arg m
if pos(substr(m.m.src, m.m.pos, 1),
, m.m.scanName1) <= 0 then do
m.m.tok = ''
return 0
end
return scanVerify(m, m.m.scanNameR)
endProcedure scanName
/*--- scan with verify, vOpt is passed to verify ---------------------*/
scanVerify: procedure expose m.
parse arg m, alpha, vOpt, onlyIfMatch
if vOpt == '' then /* empty string does not take default */
nx = verify(m.m.src, alpha, , m.m.pos)
else
nx = verify(m.m.src, alpha, vOpt, m.m.pos)
if nx = 0 then
if onlyIfMatch == 1 then
nx = m.m.pos
else
nx = length(m.m.src) + 1
m.m.tok = substr(m.m.src, m.m.pos, nx - m.m.pos)
m.m.pos = nx
return m.m.tok \== ''
endProcedure scanVerify
/*--- scan a natural number (no sign, decpoint ...) ------------------*/
scanNat: procedure expose m.
parse arg m, chEn
if \ scanVerify(m, '0123456789') then
return 0
if chEn \== 0 then
if pos(scanLook(m , 1), m.m.scanNameR) > 0 then
call scanErr m, 'illegal number end after' m.m.tok
return 1
endProcedure ScanNat
/*--- scan an integer (optional sign, no decpoint ...) ---------------*/
scanInt: procedure expose m.
parse arg m, chEn
call scanLit m, '+', '-'
si = m.m.tok
if \ scanNat(m, chEn) then do
m.m.pos = m.m.pos - si
return 0
end
m.m.tok = si || m.m.tok
return 1
endProcedure scanInt
/*--- scan a number (optional sign, decpoint, exponent) ------------*/
scanNum: procedure expose m.
parse arg m, chEn
sx = m.m.pos
call scanLit m, '+', '-'
po = scanLit(m, '.')
if \ scanNat(m, 0) then do
m.m.pos = sx
return 0
end
if \ po then
if scanLit(m, '.') then
call scanNat m, 0
if scanLit(m, 'e', 'E') then
if \ scanInt(m, 0) then
call scanErr 'exponent expected after' ,
substr(m.m.src, sx, m.m.pos-sx)
m.m.tok = substr(m.m.src, sx, m.m.pos-sx)
m.m.val = translate(m.m.tok)
if chEn \== 0 then
if pos(scanLook(m , 1), m.m.scanNameR) > 0 then
call scanErr m, 'illegal number end after' m.m.tok
return 1
endProcedure scanNum
/*--- scan a word and put value into *.val
a word is either delimited by space or stopper
or a string (with single or double quotes -------*/
scanWord: procedure expose m.
parse arg m, stopper
if scanString(m) then return 1
if \scanVerify(m, ' 'stopper, 'm') then return 0
m.m.val = m.m.tok
return 1
endProcedure scanWord
scanType: procedure expose m.
parse arg m, opt
m.m.tok = ''
if scanName(m) then
m.m.type = 'n'
else if scanNum(m) then
m.m.type = 0
else if scanString(m) then
m.m.type = left(m.m.tok, 1)
else if scanSpaceNl(m) then
m.m.type = 's'
else do
call scanChar m, 1
m.m.type = m.m.tok
end
return m.m.type
endProcedure scanType
scanBack: procedure expose m.
parse arg m, tok
if m.m.pos <= length(tok) then
call scanErr sc, 'cannot back "'tok'" length'
cx = m.m.pos - length(tok)
if substr(m.m.src, cx, length(tok)) \== tok then
call scanErr sc, 'cannot back "'tok'" value'
m.m.pos = cx
return
endProcedure scanBack
/*--- scan a key = word phrase
put key into m.key and word into m.m.val -------*/
scanKeyValue: procedure expose m.
parse arg m, def
if \ scanName(m) then
return 0
m.m.key = m.m.tok
if \ scanLit(scanSkip(m), '=') then do
m.m.val = def
m.m.tok = ' no='
end
else if \scanWord(scanSkip(m)) then
return scanErr(m, 'word expected after' m.m.key '=')
return 1
endProcedure scanKeyValue
/*--- return true/false whether we are at the end of input ----------*/
scanAtEnd: procedure expose m.
parse arg m
return m.m.atEnd & m.m.pos > length(m.m.src)
endProcedure scanAtEnd
/*--- skip over spaces, nl and comments (if option set) --------------*/
scanSpaceNL: procedure expose m.
parse arg m
lastTok = m.m.tok
if m.m.rdr \== '' then
interpret 'res = ' objMet(m, 'scanSpaceNl')
else
res = scanSpaceCom(m)
m.m.tok = lastTok
return res
endProcedure scanSpaceNL
scanSpaceCom: procedure expose m.
parse arg m
res = scanVerify(m, ' ')
if m.m.scanComment \== '' then
if abbrev(substr(m.m.src, m.m.pos), m.m.scanComment) then do
m.m.pos = 1 + length(m.m.src)
return 1
end
return res
endProcedure scanSpaceCom
/*--- skip over space, nl and comments and return m -----------------*/
scanSkip: procedure expose m.
parse arg m
call scanSpaceNl m
return m
endProcedure scanSkip
/*--- emit an error with current scan pos ----------------------------*/
scanErr: procedure expose m.
parse arg m, txt
m.m.err.0 = 0
call err 'scanErr' txt'\n'scanInfo(m, m'.ERR')
return 0
endProcedure scanErr
scanPos: procedure expose m.
parse arg m
if m.m.rdr \== '' then
interpret 'return' objMet(m, 'scanPos')
else if scanAtEnd(m) then
return E
else
return 1 m.m.pos
endProcedure scanPos
scanInfo: procedure expose m.
parse arg m
msg = 'last token' m.m.tok 'scanPosition' ,
strip(left(substr(m.m.src, m.m.pos), 40), 't')
if m.m.rdr == '' then
return msg'\npos' m.m.Pos 'in string' strip(m.m.src, 't')
else
interpret 'return msg ||' objMet(m, 'scanInfo')
endProcedure scanInfo
/* copy scan end ****************************************************/
/* copy scanRead begin ************************************************/
scanReadIni: procedure expose m.
if m.scanRead.ini = 1 then
return
m.scanRead.ini = 1
call scanIni
call jIni
ts = classNew('n Scan u f TOK v, f VAL v, f KEY v, f TYPE v')
call classNew 'n ScanRead u JRW', 'm',
, 'jReset call scanReadReset m, arg, arg2, arg3',
, 'jOpen call scanReadOpen m',
, 'jClose if m.m.closeRdr then call jClose m.m.rdr',
, 'jRead call scanType m; call oClaCopy "'ts'", m, var;' ,
'return m.m.type \== ""',
, 'scanReadNl return scanReadNlImpl(m, unCond)',
, 'scanSpaceNl scanReadSpaceNl(m)',
, 'scanInfo scanReadInfo(m)',
, 'scanPos scanReadPos(m)'
return
endProcedure scanReadIni
/*--- begin scanning the lines of a reader ---------------------------*/
scanRead: procedure expose m.
parse arg rdr, n1, np, co
return scanOpts(oNew('ScanRead', rdr), n1, np, co)
scanReadReset: procedure expose m.
parse arg m, r, n1, np, co
call scanReset m, n1, np, co
m.m.rdr = r
return m
endProcedure scanReadReset
scanReadOpen: procedure expose m.
parse arg m, r, n1, np, co
call scanOpen m
m.m.atEnd = 0
m.m.lineX = 0
m.m.closeRdr = jOpenIfNotYet(m.m.rdr, m.j.cRead)
call scanReadNl m, 1
return m
endProcedure scanReadOpen
/*--- scan over next newLine
if unCond \== 1 only if we are already at endOfLine
return true if we scanned a NL ------------------------------*/
scanReadNl: procedure expose m.
parse arg m, unCond
interpret objMet(m, 'scanReadNl')
endProcedure scanReadNl
/*--- implementation of scanReadNl ----------------------------------*/
scanReadNLimpl: procedure expose m.
parse arg m, unCond
if unCond \== 1 then
if m.m.pos <= length(m.m.src) then
return 0
if m.m.atEnd then
return 0
m.m.atEnd = \ jRead(m.m.rdr, m'.SRC')
if m.m.atEnd then do
m.m.pos = 1 + length(m.m.src)
end
else do
m.m.pos = 1
m.m.lineX = m.m.lineX + 1
end
return \ m.m.atEnd
endProcedure scanReadNLimpl
scanReadSpaceNl: procedure expose m.
parse arg m
fnd = 0
do forever
if scanSpaceCom(m) then
fnd = 1
if \ scanReadNl(m) then
return fnd
fnd = 1
end
endProcedure scanReadSpaceNl
scanReadPos: procedure expose m.
parse arg m, msg
if scanAtEnd(m) then
return E
else
return m.m.lineX m.m.pos
endProcedure scanReadPos
scanReadInfo: procedure expose m.
parse arg m, msg
if scanAtEnd(m) then
msg = msg'\natEnd after'
else
msg = msg'\npos' m.m.pos 'in'
return msg 'line' m.m.lineX':' strip(m.m.src, 't')
endProcedure scanReadInfo
/* copy scanRead end **************************************************/
/* copy scanWin begin *************************************************
scan the the concatenation of the lines of a reader
any token my be split over several line
except the end-of-line-comment-token
***********************************************************************/
scanWinIni: procedure expose m.
if m.scanWin.ini = 1 then
return
m.scanWin.ini = 1
call scanIni
call jIni
call classNew 'n ScanWin u JRW', 'm',
, 'jReset call scanWinReset m, arg, arg2, arg3',
, 'jOpen call scanWinOpen m ',
, 'jClose call scanWinClose m ',
, 'scanReadNl return scanWinNl(m, unCond)',
, 'scanSpaceNl scanWinSpaceNl(m)',
, 'scanInfo scanWinInfo(m)',
, 'scanPos scanWinPos(m)'
return
endProcedure scanReadIni
/*--- instanciate a new window scanner, open rdr ---------------------*/
scanWin: procedure expose m.
parse arg rdr, wiSz, wiBa, cuPo, cuLe
return scanWinOpts(oNew('ScanWin', rdr), wiSz, wiBa, cuPo, cuLe)
/*--- set the reader and attributes of window scanner m -------------*/
scanWinReset: procedure expose m.
parse arg m, r, wiSz, wiGa, cuPo, cuLe
call scanReset m
m.m.rdr = r
m.m.atEnd = 'still closed'
return scanWinOpts(m, wiSz, wiGa, cuPo, cuLe)
endProcedure scanWinReset
/*--- set the attributes of window scanner m ------------------------*/
scanWinOpts: procedure expose m.
parse arg m, wiSz, wiGa, cuPo, cuLe
wiSz = word(wiSz 5, 1)
wiGa = word(wiGa 1, 1)
m.m.cutPos = word(cuPo 1, 1)
m.m.cutLen = word(cuLe 72, 1)
m.m.winTot = (wiSz * 2 + wiGa) * m.m.cutLen
m.m.posLim = (wiSz + wiGa) * m.m.cutLen
m.m.posOff = wiGa * m.m.cutLen
return m
endProcedure scanWinReset
/*--- open reader and start scanning --------------------------------*/
scanWinOpen: procedure expose m.
parse arg m, lx
call scanOpen m
m.m.atEnd = 0
if lx = '' then
m.m.lineX = 1
else
m.m.lineX = lx
m.m.pos = 1
m.m.src = ''
call jOpen m.m.rdr, m.j.cRead
call scanWinRead m
return m
endProcedure scanWinOpen
scanWinClose: procedure expose m.
m.m.atEnd = 'still closed'
call jClose m.m.rdr
return
endProcedure scanWinClose
/*--- move the source window: cut left side and append at right side
return number of characters cut at left ------------------------*/
scanWinRead: procedure expose m.
parse arg m
dlt = 0
if m.m.atEnd then
return 0
if m.m.pos >= m.m.posLim then do /* cut left side */
dlt = m.m.pos - (m.m.pos // m.m.cutLen + m.m.posOff)
m.m.src = substr(m.m.src, dlt+1)
m.m.pos = m.m.pos - dlt
m.m.lineX = m.m.lineX + dlt % m.m.cutLen
end
do while length(m.m.src) < m.m.winTot /* read and fill to len */
if \ jRead(m.m.rdr, m'.'one) then do
m.m.atEnd = 1
return dlt
end
m.m.src = m.m.src || substr(m.m.one, m.m.cutPos, m.m.cutLen)
end
call assert 'length(m.m.src) = m.m.winTot'
return dlt
endProcedure scanWinRead
/*--- return position of next line start -----------------------------*/
scanWinNLPos: procedure expose m.
parse arg m
return m.m.pos + m.m.cutLen - ((m.m.pos - 1) // m.m.cutLen)
/*--- scan over spaces and comments ----------------------------------*/
scanWinSpaceNL: procedure expose m.
parse arg m
res = 0
do forever
r1 = 0
if scanVerify(m, ' ') then do
r1 = 1
end
else if m.m.scanComment \== '' ,
& abbrev(substr(m.m.src, m.m.pos), m.m.scanComment) then do
np = scanWinNlPos(m)
r1 = length(m.m.scanComment) <= np - m.m.pos
if r1 then
m.m.pos = np
end
if r1 then
res = 1
else if scanWinRead(m) = 0 then
return res
end
endProcedure scanWinSpaceNl
/*--- return current position in input ------------------------------*/
scanWinPos: procedure expose m.
parse arg m
if scanAtEnd(m) then
return 'E'
else
ps = m.m.pos - 1
return (m.m.lineX + (ps % m.m.cutLen)) (ps // m.m.cutLen + 1)
endProcedure scanWinPos
/*--- return a description of the current scan position --------------*/
scanWinInfo: procedure expose m.
parse arg m
p = scanWinPos(m)
if p == 'E' then do
res = 'atEnd after'
p = m.m.lineX - 1 + length(m.m.src) % m.m.cutLen
end
else do
res = 'pos' word(p, 2) 'in'
p = word(p, 1)
end
return '\n'res 'line' p':' strip(substr(m.m.src,
, 1 + (p - m.m.lineX) * m.m.cutLen, m.m.cutLen), 't')
endProcedure scanWinInfo
/* copy scanWin end *************************************************/
/* copy scanSql begin *************************************************/
/*--- initialize with reader inRdr ----------------------------------*/
scanSql: procedure expose m.
parse arg inRdr
return scanSqlReset(scanWin(inRdr), inRdr)
scanSqlReset: procedure expose m.
parse arg m, r, scanWin
if scanWin \== 0 then
call scanWinOpts m, 5, 2, 1, 72
else
m.m.rdr = r
return scanOpts(m, , '0123456789_' , '--')
scanSqlSeekId: procedure expose m.
parse arg m, lx, cmd, opts
if opts = '' then
opts = word
if adrEdit("cursor =" max(trunc(lx), 1), 12) = 12 then
return -1
do while adrEdit("seek" cmd opts, 4) = 0 /* find each command*/
call adrEdit "(fx) = cursor"
if m.debug then do
call adrEdit "(LI) = LINE" fx
call debug 'scanSqlSeekId after' lx 'found' cmd 'at' fx li
end
call editReadReset m.m.rdr, fx
call scanWinOpen es, fx
do while word(scanPos(m), 1) <= fx & scanSqlClass(m)
if m.m.sqlClass = 'i' & m.m.val == cmd then
return fx
end
end
return -1
endProcedure scanSqlSeekId
/*--- scan a sql token put class in m.sqlclass:
'i': ordinary identifier e.g. Name
'd': delimited identifier e.g. "Delimited"
'q': qualified identifier e.g. abc."efg"
'u': integer units e.g. 8G
'n': number e.g. -234 or .2e3
's': string e.g. 'abc''ef'
'' : at end
: any other character e.g. ;
----------------------------------------------------------------*/
scanSqlClass: procedure expose m.
parse arg m, retSpace
m.m.val = ''
if scanSpaceNl(m) & retSpace = 1 then do
m.m.sqlClass = 'b'
return 1
end
c2 = scanLook(m ,2)
if scanString(m, "' x' X'") then do
m.m.sqlClass = 's'
if \abbrev(m.m.tok, "'") then
m.m.val = x2c(m.m.val)
end
else if scanSqlQuId(m) then do
if m.m.val.0 > 1 then
m.m.sqlClass = 'q'
else if abbrev(m.m.tok, '"') then
m.m.sqlClass = 'd'
else
m.m.sqlClass = 'i'
end
else if scanSqlNum(m, 0, 1) then
m.m.sqlClass = 'n'
else if scanChar(m, 1) then
m.m.sqlClass = m.m.tok
else if scanAtEnd(m) then do
m.m.sqlClass = ''
return 0
end
else
call scanErr m, 'cannot scan sql'
return 1
endProcedure scanSqlClass
scanSqlSkipBrackets: procedure expose m.
parse arg m, br
if br \== '' then
nop
else if scanLit(m, '(') then
br = 1
else
return 0
do while scanSqlClass(m) & m.m.sqlClass \== ';'
if m.m.sqlClass = '(' then br = br + 1
else if m.m.sqlClass \== ')' then iterate
else if br > 1 then br = br - 1
else return 1
end
call scanErr m, '; or eof, but' br 'closing ) expected'
endProcedure skipBrackets
/*--- scan an ordinary sql identifier e.g. abc, ef_12 ----------------*/
scanSqlId: procedure expose m.
parse arg m
if \ scanName(m) then
return 0
m.m.val = translate(m.m.tok)
return 1
endProcedure scanSqlId
/*--- scan a delimited or ordinay sql identifier ---------------------*/
scanSqlDeId: procedure expose m.
parse arg m
if scanSqlId(m) then
return 1
if \ scanString(m, '"') then
return 0
m.m.val = strip(m.m.val, 't')
return 1
endProcedure scanSqlDeId
/*--- scan a qualified sql identifier --------------------------------*/
scanSqlQuId: procedure expose m.
parse arg m
res = ''
rto = ''
do qx=1
if \ scanSqlDeId(m) then do
if qx <> 1 then
call scanErr m, 'id expected after .'
return 0
end
m.m.val.qx = m.m.val
res = res'.'m.m.val
rto = rto'.'m.m.tok
if \ scanLit(scanSkip(m), '.') then
leave
call scanSpaceNl m
end
m.m.val.0 = qx
m.m.val = substr(res, 2)
m.m.tok = substr(rto, 2)
return 1
endProcedure scanSqlQuId
/*--- scan a sql number ----------------------------------------------*/
scanSqlNum: procedure expose m.
parse arg m, checkEnd, noSp
si = ''
if noSp == 1 then
call err 'deimplement ???? wk'
if noSp \== 1 then do
if scanLit(m, '+', '-') then do
si = m.m.tok
call scanSpaceNl m
ch = scanLook(m, 2)
if left(ch, 1) == '.' then
ch = substr(ch, 2)
if pos(left(ch, 1), '0123456789') < 1 then do
call scanBack m, si
m.m.val = ''
return 0
end
end
end
res = scanNum(m, checkEnd)
m.m.val = si || m.m.val
return res
endProcedure scanSqlNum
/*--- scan a sql number with a unit which may follow without space ---*/
scanSqlNumUnit: procedure expose m.
parse arg m, both, units
if \ scanSqlNum(m, 0) then
return 0
nu = m.m.val
sp = scanSpaceNl(m)
if scanSqlId(m) then do
if units == '' | wordpos(m.m.val, units) > 0 then
nu = nu m.m.val
else if both | \ sp then
call scanErr m, 'scanSqlNumUnit after' nu 'bad unit' m.m.val
else
call scanBack m, m.m.tok
end
else if both then
call scanErr m, 'scanSqlNumUnit no unit after' nu
else if \sp & pos(scanLook(m, 1), m.m.scanNameR) > 0 then
call scanErr m, 'scanSqlNumUnit bad number end after' nu
m.m.val = nu
return 1
endProcedure scanSqlNumUnit
/* copy scanSql end *************************************************/
/* copy scanUtil begin *************************************************
scan db2 utility input statements using scan and a reader
**********************************************************************/
/*--- initialize with reader inRdr ----------------------------------*/
scanUtilReader: procedure expose m.
parse arg m, inRdr
call scanReader m, inRdr
call scanOptions sc, , , '--'
call scanUtilReset m
return m
endProcedure scanUtilReader
scanUtilSql: procedure expose m.
parse arg inRdr
m = scanSql(inRdr)
call scanUtilReset m
return m
endProcedure scanUtilReader
scanUtilReset: procedure expose m.
parse arg m
m.m.utilBrackets = 0
m.scanUtil = 'BACKUP CATENFM CATMAINT CHECK' ,
'COPY COPYTOCOPY DIAGNOSE EXEC LISTDEF LOAD' ,
'MERGECOPY MODIFY OPTIONS QUIESCE REBUILD' ,
'RECOVER REORG REPAIR REPORT RESTORE' ,
'RUNSTATS STOSPACE TEMPLATE UNLOAD'
return
endProcedure scanUtilReset
/*--- scan next token and put its class in m.sc.utilClass:
'u' a utility name
'n' a name
'"' a quoted name
"'" an apostroph'd string
'.' a .
',' a ,
'v' a value
'' at end
---------------------------------------------------------------*/
scanUtil: procedure expose m.
parse arg sc
m.sc.utilSpace = scanSpaceNl(sc)
ty = '?'
if scanLit(sc, '(') then do
m.sc.utilBrackets = m.sc.utilBrackets + 1
end
else if scanLIT(sc, ')') then do
m.sc.utilBrackets = m.sc.utilBrackets - 1
if m.sc.utilBrackets < 0 then
call scanErr sc, 'unmatched closing bracket )'
end
else if scanLit(sc, ',') then do
end
else if scanLit(sc, '.') then do
end
else if scanString(sc, "'") then do
end
else if scanString(sc, '"') then do
end
else if scanName(sc) then do
m.sc.val = translate(m.sc.tok)
if m.sc.utilBrackets > 0 then
ty = 'n'
else if 0 < wordPos(m.sc.val, m.scanUtil) then
ty = 'u'
else
ty = 'n'
end
else if scanVerify(sc, ' (),''"', 'm') then do
ty = 'v'
m.sc.val = translate(m.sc.tok)
end
else if \scanAtEnd(sc) then do
call scanErr sc, 'scanUtil stopped before end'
end
else do
ty = ''
m.sc.val = ''
end
if ty == '?' then
m.sc.utilClass = left(m.sc.tok, 1)
else
m.sc.utilClass = ty
return m.sc.utilClass
endProcedure scanUtil
/*--- scan a value or a bracketed list of values ---------------------*/
scanUtilValue: procedure expose m.
parse arg sc, remApo, nl
if remApo = '' | rempApo = 0 then
remApo = "nv"
else if rempApo = 1 then
remApo = "nv'"
if '(' \== scanUtil(sc) then
return scanUtilValueOne(sc, remApo)
v = ''
brx = m.sc.utilBrackets
oLine = word(scanPos(sc), 1)
do forever
call scanUtil sc
one = scanUtilValueOne(sc, remApo)
if one == '' then
call scanErr sc, 'eof in brackets'
else if brx > m.sc.utilBrackets then
return v
nLine = word(scanPos(sc), 1)
if \ m.sc.utilSpace then
v = v || one
else if nl \== '' & oLine <> nLine then
v = v || nl || one
else
v = v' 'one
oLine = nLine
end
endProcedure scanUtilValue
scanUtilValueOne: procedure expose m.
parse arg sc, valTy
if m.sc.utilClass == '' then
return ''
else if m.sc.utilClass == 'u' then
call scanErr sc, 'util in scanUtilValueOne'
if pos(m.sc.utilClass, valTy) > 0 then
return m.sc.val
else
return m.sc.tok
endProcedure scanUtilValueOne
/* copy scanUtil end **************************************************/
/* copy pipe begin *****************************************************
***********************************************************************/
pipeIni: procedure expose m.
if m.pipe.ini == 1 then
return
m.pipe.ini = 1
call catIni
call classNew "n PipeFrame u"
call classNew "n PipeFramedRdr u JRWO", "m",
, "jOpen call jOpen never-call-PipeFramedRdr-Open",
, "jReadO call pipePushFrame m;" ,
"res = jReadO(m.m.framedRdr, var);",
"call pipeEnd; return res",
, "jReset never-call-PipeFramedRdr-jReset",
, "jClose call pipeFramedClose m"
call mapReset env.vars
call jReset oMutate("PIPE.framedNoOut", "JRWErr")
m.pipe.0 = 0
call pipeBeLa /* by default pushes in and out */
return
endProcedure pipeIni
pipeOpen: procedure expose m.
parse arg e
if m.e.inCat then
call jClose m.e.in
m.e.inCat = 0
if m.e.in == '' then
m.e.in = m.j.in
else if jOpenIfNotYet(m.e.in, m.j.cRead) then
m.e.toClose = m.e.toClose m.e.in
if m.e.out == '' then
m.e.out = m.j.out
else if jOpenIfNotYet(m.e.out, m.e.outOp) then
m.e.toClose = m.e.toClose m.e.out
return e
endProcedure pipeOpen
pipePushFrame: procedure expose m.
parse arg e
call mAdd pipe, e
m.j.in = m.e.in
m.j.out = m.e.out
return e
endProcedure pipePushFrame
pipeBegin: procedure expose m.
e = pipeFrame()
do ax=1 to arg()
call pipeAddIO e, arg(ax)
end
if m.e.out \== '' then
call err 'pipeBegin output redirection' m.e.in
call pipeAddIO e, '>' Cat()
m.e.allInFrame = 1
return pipePushFrame(pipeOpen(e))
endProcedure pipeBegin
pipe: procedure expose m.
px = m.pipe.0
f = m.pipe.px
call pipeClose f
m.f.in = jOpen(m.f.out, '<')
m.f.out = jOpen(Cat(), '>')
m.f.toClose = m.f.in m.f.out
m.j.in = m.f.in
m.j.out = m.f.out
m.e.allInFrame = 1
return
endProcedure pipe
pipeLast: procedure expose m.
px = m.pipe.0
f = m.pipe.px
m.f.in = pipeClose(f)
m.f.out = ''
do ax=1 to arg()
if word(arg(ax), 1) = m.j.cRead then
call err 'pipeLast input redirection' arg(ax)
else
call pipeAddIO f, arg(ax)
end
m.f.allInFrame = 1
if m.f.out == '' then do
preX = px-1
preF = m.pipe.preX
m.f.out = m.preF.out
m.f.allInFrame = m.preF.allInFrame
end
call pipeOpen f
m.j.in = m.f.in
m.j.out = m.f.out
return
endProcedure pipeLast
pipeBeLa: procedure expose m.
e = pipeFrame()
do ax=1 to arg()
call pipeAddIO e, arg(ax)
end
return pipePushFrame(pipeOpen(e))
endProcedure pipeBeLa
/*--- activate the last pipeFrame from stack
and return outputbuffer from current pipeFrame --------------*/
pipeEnd: procedure expose m.
ox = m.pipe.0 /* wkTst??? streamLine|| */
if ox <= 1 then
call err 'pipeEnd on empty stack' ex
ex = ox - 1
m.pipe.0 = ex
e = m.pipe.ex
m.j.in = m.e.in
m.j.out = m.e.out
return pipeClose(m.pipe.ox)
endProcedure pipeEnd
pipeFramedRdr: procedure expose m.
parse arg e
m = pipeFrame()
m.m.jReading = 1
m.m.jWriting = 0
m.m.framedRdr = jOpen(jClose(m.e.out), m.j.cRead)
say 'framedRdr <' m.m.framedRdr
m.m.in = m.e.in
m.m.framedToClose = m.e.toClose
m.e.toClose = ''
m.m.out = "PIPE.framedNoOut"
call oMutate m, 'PipeFramedRdr'
return m
endProcedure pipeFramedRdr
pipeFramedClose: procedure expose m.
parse arg m
m.m.allInFrame = 0
call pipeClose m
call oMutate m, 'PipeFrame'
return
endProcedure pipeFramedClose
pipeFrame: procedure expose m.
m = oBasicNew("PipeFrame")
m.m.toClose = ''
m.m.in = ''
m.m.inCat = 0
m.m.out = ''
m.m.outOp = ''
m.m.allInFrame = 0
return m
endProcedure pipeFrame
pipeClose: procedure expose m.
parse arg m, finishLazy
if m.m.allInFrame == 2 then
return pipeFramedRdr(m)
do wx=1 to words(m.m.toClose)
call jClose word(m.m.toClose, wx)
end
m.m.toClose = ''
return m.m.out
endProcedure pipeClose
pipeAddIO: procedure expose m.
parse arg m, opt file
if opt == m.j.cRead then do
if m.m.in == '' then
m.m.in = o2file(file)
else if m.m.inCat then
call catWriteAll m.m.in, o2file(file)
else do
m.m.in = jOpen(cat(m.m.in, o2file(file)), m.j.cApp)
m.m.inCat = 1
end
return m
end
if \ (opt = m.j.cWri | opt == m.j.cApp) then
call err 'pipeAddIO('opt',' file') bad opt'
else if m.m.out \== '' then
call err 'pipeAddIO('opt',' file') duplicate output'
m.m.out = o2file(file)
m.m.outOp = opt
return m
endProcedure pipeAddIO
/*--- write all from rdr (rsp in) to out, not lazy ----------------*/
pipeWriteNow: procedure expose m.
parse arg rdr
call jWriteNow m.j.out, if(rdr == '', m.j.in, rdr)
return
endProcedure pipeWriteNow
/*--- write all from rdr (rsp in) to out, possibly lazy -----------*/
pipeWriteAll: procedure expose m.
parse arg rdr
call jWriteAll m.j.out, if(rdr == '', m.j.in, rdr)
return
endProcedure pipeWriteAll
/*--- write all from rdr (rsp in) to out, possibly lazy
do lazy reads within current frame -----------*/
pipeWriteAllFramed: procedure expose m.
parse arg rdr
if rdr == '' then
rdr = m.j.in
px = m.pipe.0
f = m.pipe.px
if m.f.allInFrame = 0 then do
call jWriteNow m.j.out, rdr
return
end
m.f.allInFrame = 2
call jWriteall m.j.out, rdr
return
endProcedure pipeWriteFramed
pipePreSuf: procedure expose m.
parse arg le, ri
do while in(v)
call out le || m.v || ri
end
return
endProcedure pipePreSuf
/*--- out interface of pipe -----------------------------------------*/
outIni: procedure expose m.
call pipeIni
return
endProcedure outIni
outPush: procedure expose m.
parse arg st
call pipeBeLa '>' oNew('JRWOut', st)
return
endProcedure outPush
outPop: procedure expose m.
call pipeEnd
return
endProcedure outPop
/*--- write all from rdr (rsp in) to a new jBuf --------------------*/
env2Buf: procedure expose m. /*wkTst remove |||| */
parse arg rdr
b = jOpen(jBuf(), m.j.cWri)
call jWriteNow b, if(rdr=='', m.j.in, rdr)
return jClose(b)
endProcedure env2Buf
envIsDefined: procedure expose m.
parse arg na
return symbol('m.env.vars.na') == 'VAR'
endProcedure envIsDefined
envGetO: procedure expose m.
parse arg na
return mapGet(env.vars, na)
envGet: procedure expose m.
parse arg na
return o2String(mapGet(env.vars, na))
endProcedure envGet
envRead: procedure expose m.
parse arg na
return in("ENV.VARS."na)
envReadO: procedure expose m.
parse arg na
if \ inO("ENV.VARS.OBJ."na) then
return 0
call envPutO na, "ENV.VARS.OBJ."na
return 1
if \ inO('ENV.XX') then
return 0
call envPut na, m.env.xx
return 1
envHasKey: procedure expose m.
parse arg na
return mapHasKey(env.vars, na)
envVia: procedure expose m.
parse arg na
return mapVia(env.vars, na) /*wkTst??? remove?*/
envPutO: procedure expose m.
parse arg na, ref
return mapPut(env.vars, na, ref)
envPut: procedure expose m.
parse arg na, va
call mapPut env.vars, na, s2o(va)
return va
envRemove: procedure expose m.
parse arg na
return mapRemove(env.vars, na)
/* copy pipe end ******************************************************/
/* copy cat begin ****************************************************
***********************************************************************/
/*--- create a new cat -----------------------------------------------*/
cat: procedure expose m.
m = oNew('Cat') /* calls catReset */
do ax=1 to arg()
call catWriteAll m, arg(ax)
end
return m
endProcedure cat
catReset: procedure expose m.
parse arg m
m.m.RWs.0 = 0
m.m.catWr = ''
m.m.catRd = ''
m.m.catRdClose = 0
m.m.catIx = -9e9
return m
endProcedure catReset
catClose: procedure expose m.
parse arg m
if m.m.catWr \== '' then do
call jClose m.m.catWr
call mAdd m'.RWS', m.m.catWr
m.m.catWr = ''
end
if m.m.catRd \== '' then do
if m.m.catRdClose then
call jClose m.m.catRd
m.m.catRd = ''
end
m.m.catIx = -9e9
return m
endProcedure catClose
catOpen: procedure expose m.
parse arg m, oo
if oo == m.j.cRead then do
m.m.catIx = 0
call catNextRdr m
m.m.jReading = 1
end
else if oo == m.j.cWri | oo == m.j.cApp then do
if oo == m.j.cWri then
m.m.RWs.0 = 0
m.m.catIx = -9e9
m.m.jWriting = 1
end
else do
call err 'catOpen('m',' oo') bad opt'
end
return m
endProcedure catOpen
/*--- return and open next reader ------------------------------------*/
catNextRdr: procedure expose m.
parse arg m
if m.m.catRd \== '' & m.m.catRdClose then
call jClose m.m.catRd
cx = m.m.catIx + 1
m.m.catIx = cx
if cx > m.m.RWs.0 then do
m.m.catRd = ''
return 0
end
m.m.catRd = m.m.RWs.cx
m.m.catRdClose = jOpenIfNotYet(m.m.catRd , m.j.cRead)
return 1
endProcedure catNextRdr
catReadO: procedure expose m.
parse arg m, var
do while m.m.catRd \== ''
if jReadO(m.m.catRd, var) then
return 1
call catNextRdr m
end
return 0
endProcedure catReadO
catWrite: procedure expose m.
parse arg m, line
if m.m.catWr == '' then
m.m.catWr = jOpen(jBuf(), m.j.cWri)
call jWrite m.m.catWr, line
return
endProcedure catWrite
catWriteO: procedure expose m.
parse arg m, var
if m.m.catWr == '' then
m.m.catWr = jOpen(jBuf(), m.j.cWri)
call jWriteO m.m.catWr, var
return
endProcedure catWriteO
/*--- write contents of a reader to cat
or keep it for later reading -------------------------------*/
catWriteAll: procedure expose m.
parse arg m
if m.m.catWr \== '' then do
call mAdd m'.RWS', jClose(m.m.catWr)
m.m.catWr = ''
end
do ax=2 by 1 to arg()
call mAdd m'.RWS', o2File(arg(ax))
end
return
endProcedure catWriteAll
/*--- create a reader/WriteO for an external file --------------------*/
file: procedure expose m.
parse arg str
if abbrev(str, m.j.cVar) then do
var = substr(str, 2)
if envHasKey(var) then
return envGetO(var)
else
return envPutO(var, jBuf())
end
return oNew('File', str)
endProcedure file
fileChild: procedure expose m.
parse arg m, name, opt
interpret objMet(m, 'fileChild')
endProcedure fileChild
fileRm: procedure expose m.
parse arg m
interpret objMet(m, 'fileRm')
return
endProcedure fileRm
filePath: procedure expose m.
parse arg m
interpret objMet(m, 'filePath')
endProcedure filePath
fileIsFile: procedure expose m.
parse arg m
interpret objMet(m, 'fileIsFile')
endProcedure fileIsFile
fileIsDir: procedure expose m.
parse arg m
interpret objMet(m, 'fileIsDir')
endProcedure fileIsDir
fileMkDir: procedure expose m.
parse arg m, opt
interpret objMet(m, 'fileMkDir')
return
endProcedure fileRm
fileRmDir: procedure expose m.
parse arg m, opt
interpret objMet(m, 'fileRmDir')
return
endProcedure fileRm
/*--- create a reader/WriteO for the filelist of a directory----------*/
fileList: procedure expose m.
parse arg m, opt
return oNew('FileList', filePath(m), opt)
endProcedure fileList
catIni: procedure expose m.
if m.cat.ini == 1 then
return
m.cat.ini = 1
call jIni
call classNew "n Cat u JRWO", "m",
, "jOpen return catOpen(m, opt)",
, "jReset return catReset(m, arg)",
, "jClose call catClose m",
, "jReadO return catReadO(m, var)",
, "jWrite call catWrite m, line; return",
, "jWriteO call catWriteO m, var; return",
, "jWriteAll call catWriteAll m, rdr; return"
os = errOS()
if os == 'TSO' then
call fileTsoIni
else if os == 'LINUX' then
call fileLinuxIni
else
call err 'file not implemented for os' os
return
endProcedure catIni
/* copy cat end ****************************************************/
/* copy fiLinux begin *************************************************/
/*--- send ggShCmd to shell bash,
fail if rc <> 0 or not listed in ggRet -----------------------*/
adrSh: procedure expose m. /* really no need for variables???? */
parse arg ggShCmd, ggRet
address 'bash' ggShCmd
if rc == 0 then return 0
else if ggRet == '*' then return rc
else if wordPos(rc, ggRet) > 0 then return rc
else
call err 'adrSh rc' rc 'for' ggShCmd
endProcedure adrSh
fileLinuxReset: procedure expose m.
parse arg m, nm
m.m.spec = nm
if abbrev(nm, '&') then do
if nm == '&in' then do
m.m.stream = .input
m.m.jReading = 1
end
else if nm == '&out' then do
m.m.stream = .output
m.m.jWriting = 1
end
else do
call err 'bad spec' nm
end
end
else do
m.m.stream = .Stream%%new(nm)
m.m.stream%%init(m.m.stream%%qualify)
end
return m
endProcedure fileLinuxReset
fileLinuxOpen: procedure expose m.
parse arg m, opt
if opt == m.j.cRead then do
res = m.m.stream%%open(read shareread)
m.m.jReading = 1
end
else do
if opt == m.j.cApp then
res = m.m.stream%%open(write append)
else if opt == m.j.cWri then
res = m.m.stream%%open(write replace)
else
call err 'fileLinuxOpen('m',' opt') with bad opt'
m.m.jWriting = 1
end
if res \== 'READY:' then
call err 'fileLinuxOpen fails' res':' opt m.m.stream%%qualify
return m
endProcedure fileLinuxOpen
fileLinuxClose:
parse arg m
res = m.m.stream%%close
if res \== 'READY:' then
call err 'fileLinuxClose' res':' m.m.stream%%qualify
return m
endProcedure fileLinuxClose
fileLinuxRead: procedure expose m.
parse arg m, var
res = m.m.stream%%lineIn
if res == '' then
if m.m.stream%%state \== 'READY' then
return 0
m.var = res
m.class.o2c.var = m.class.classV
return 1
endProcedure fileLinuxRead
fileLinuxWrite: procedure expose m.
parse arg m, line
if m.m.stream%%lineOut(line) then
call err 'fileLinuxWrite'
return
endProcedure fileLinuxWrite
fileLinuxRmDir: procedure expose m.
parse arg m, opt
if opt == '' then
return adrSh('rmdir' m.m.spec)
else if opt == '-r' then
return adrSh('rm -r' m.m.spec)
else
call err 'bad opt' opt 'in fileLinuxRmDir'
endProcedure fileLInuxRmDir
fileLinuxListReset: procedure expose m.
parse arg m, m.m.spec, o
if o == 'r' then
m.m.opt = 'S'
else if o == '' then
m.m.opt = ''
else
call err 'bad opt' o 'in fileLinuxListReset'
m.m.rx = 'closed'
return m
endProcedure fileLinuxListReset
fileLinuxListOpen: procedure expose m.
parse arg m
if m.m \== value('m.'m) then
call err 'bad m for fileLinuxList:' m
if m.m.opt == '' then
rc = sysFileTree(m.m.spec'/*', 'm.'m'.LIST')
else
rc = sysFileTree(m.m.spec'/*', 'm.'m'.LIST', m.m.opt)
if rc \== 0 then
call err 'rc' rc 'in sysFileTree('m.m.spec', m.'m'.LIST)'
m.m.rx = 0
m.m.jReading = 1
return m
endProcedure fileLinuxListOpen
fileLinuxListRead: procedure expose m.
parse arg m, var
x = m.m.rx + 1
if x > m.m.list.0 then
return 0
m.var = substr(m.m.list.x, 43)
m.m.rx = x
return 1
endProcedure fileLinuxListRead
fileLinuxIni: procedure expose m.
if m.fileLinux.ini == 1 then
return
m.fileLinux.ini = 1
m.file.sep = '/'
call jIni
call classNew "n File u JRW", "m",
, "jReset return fileLinuxReset(m, arg)",
, "jOpen return fileLinuxOpen(m, opt)",
, "jClose call fileLinuxClose m",
, "jRead return fileLinuxRead(m, var)",
, "jWrite call fileLinuxWrite m, line",
, "jWriteO call jWrite m, o2String(var)",
, "filePath return m.m.stream%%qualify",
, "fileIsFile return sysIsFile(m.m.stream%%qualify)" ,
, "fileIsDir return sysIsFileDirectory(m.m.stream%%qualify)" ,
, "fileChild return file(m.m.stream%%qualify'/'name)",
, "fileRm return adrSh(m.m.spec)",
, "fileMkDir return adrSh('mkdir' m.m.stream%%qualify)" ,
, "fileRmDir return fileLinuxRmDir(m, opt)"
call classNew "n FileList u JRW", "m",
, "jReset return fileLinuxListReset(m, arg, arg2)",
, "jOpen return fileLinuxListOpen(m, opt)",
, "jClose m.m.rx = 'closed'",
, "jRead return fileLinuxListRead(m, var)"
return
endProcedure fileLinuxIni
/* copy fiLinux end *************************************************/
/* copy fileTso begin *************************************************/
fileTsoReset: procedure expose m.
parse arg m, sp
m.m.readIx = 'c'
if symbol('m.m.defDD') \== 'VAR' then do
ix = mInc('FILETSO.BUF')
m.m.defDD = 'CAT'ix
m.m.buf = 'FILETSO.BUF'ix
m.m.spec = sp
end
if sp \== '' then do
m.m.spec = dsnSpec(sp)
rr = translate(subword(m.m.spec, 4))
m.m.stripT = \ (pos(':V', rr) > 0 | pos('RECFM(V', rr) > 0)
end
return m
endProcedure fileTsoReset
fileTsoOpen: procedure expose m.
parse arg m, opt
buf = m.m.buf
if opt == m.j.cRead then do
aa = dsnAlloc(m.m.spec, 'SHR', m.m.defDD)
if m.dsnAlloc.dsn <> '' then
if sysDsn("'"m.dsnAlloc.dsn"'") <> 'OK' then
call err 'cannot read' m.dsnAlloc.dsn':',
sysDsn("'"m.dsnAlloc.dsn"'")
call readDDBegin word(aa, 1)
m.m.jReading = 1
m.buf.0 = -1
m.m.readIx = 0
end
else do
if opt == m.j.cApp then
aa = dsnAlloc(m.m.spec, 'MOD', m.m.defDD)
else if opt == m.j.cWri then
aa = dsnAlloc(m.m.spec, 'OLD', m.m.defDD)
else
call err 'fileTsoOpen('m',' opt') with bad opt'
call writeDDbegin word(aa, 1)
m.m.jWriting = 1
m.buf.0 = 0
m.m.readIx = 'w'
end
m.m.dd = word(aa, 1)
m.m.free = subword(aa, 2)
return m
endProcedure fileTsoOpen
fileTsoClose:
parse arg m
buf = m.m.buf
if m.m.readIx \== 'c' then do
if m.m.readIx == 'w' then do
if m.buf.0 > 0 then
call writeDD m.m.dd, 'M.'BUF'.'
call writeDDend m.m.dd
end
else do
call readDDend m.m.dd
end
interpret m.m.free
end
m.buf.0 = 'closed'
m.m.readIx = 'c'
m.m.free = ''
m.m.dd = ''
return m
endProcedure fileTsoClose
fileTsoRead: procedure expose m.
parse arg m, var
ix = m.m.readIx + 1
buf = m.m.buf
if ix > m.buf.0 then do
res = readDD(m.m.dd, 'M.'buf'.')
if \ res then
return 0
ix = 1
end
m.m.readIx = ix
m.var = m.buf.ix
call oMutate var, m.class.classV
return 1
endProcedure fileTsoRead
fileTsoWrite: procedure expose m.
parse arg m, var
buf = m.m.buf
ix = m.buf.0 + 1
m.buf.0 = ix
if m.m.stripT then
m.buf.ix = strip(var, 't')
else
m.buf.ix = var
if ix > 99 then do
call writeDD m.m.dd, 'M.'buf'.'
m.buf.0 = 0
end
return
endProcedure fileTsoWrite
fileTsoWriteO: procedure expose m.
parse arg m, var
if objClass(var, m.class.classV) == m.class.classV then do
call fileTsoWrite m, m.var
return
end
call err 'fileTsoWriteO('m',' var') cannot write objects of class',
objClass(var)
endProcedure fileTsoWriteO
jclSub: procedure expose m.
return file('.sysout(T) writer(intRdr)')
endProcedure jclSub
fileTsoIni: procedure expose m.
if m.fileTso.ini == 1 then
return
m.fileTso.ini = 1
m.file.sep = '.'
m.fileTso.buf = 0
call jIni
um = "call err 'for tso undefined method'"
call classNew "n File u JRW", "m",
, "jOpen return fileTsoOpen(m, opt)",
, "jReset return fileTsoReset(m, arg)",
, "jClose call fileTsoClose m",
, "jRead return fileTsoRead(m, var)",
, "jWrite call fileTsoWrite m, line",
, "jWriteO call fileTsoWriteO m, var",
, "filePath return word(m.m.spec, 1)" ,
, "fileIsFile" um "'fileIsFile'" ,
, "fileIsDir return 1" ,
, "fileChild return file(word(m.m.spec, 1)'.'name opt)",
, "fileRm" um "'fileRm'" ,
, "fileMkDir" ,
, "fileRmDir" um "'fileRmDir'"
/* , "filePath return m.m.stream%%qualify",
, "fileIsFile return sysIsFile(m.m.stream%%qualify)" ,
, "fileIsDir return sysIsFileDirectory(m.m.stream%%qualify)" ,
, "fileChild return file(m.m.stream%%qualify'/'name)",
, "fileRm return adrSh(m.m.spec)",
, "fileMkDir return adrSh('mkdir' m.m.stream%%qualify)" ,
, "fileRmDir return fileLinuxRmDir(m, opt)" */
call classNew "n FileList u JRW", "m",
, "jReset if arg2 == 'r' then m.m.dsnMask=arg'.**';",
"else m.m.dsnMask=arg'.*';",
, "jOpen call csiOpen m, m.m.dsnMask; m.m.jReading=1; return",
, "jClose" ,
, "jRead return csiNext(m, var)"
return
endProcedure fileTsoIni
/* copy fileTso end *************************************************/
/* copy sqlO begin ***************************************************
sql interface mit o und j Anbindung
***********************************************************************/
sqlOini: procedure expose m.
if m.sqlO.ini == 1 then
return
m.sqlO.ini = 1
m.sqlO.cursors = left('', 10, 'r')left('', 30, ' ')
call sqlIni
call pipeIni
call classNew 'n SqlSel u JRWO', 'm',
, "jReset m.m.src = arg; m.m.type = arg2;",
"m.m.fetch = ''; m.m.type=''; m.m.cursor=''",
, "jOpen call sqlSelOpen m, opt",
, "jClose call sqlSelClose m",
, "jReadO return sqlSelRead(m, var)"
/* call oDecMethods oNewClass("SqlLn", "SqlType"),
, "jRead return sqlFetchLn(substr(m, 8), var)"
*/ return
endProcedure sqlOini
sqlSel: procedure expose m.
parse arg src, type
return oNew('SqlSel', src, type)
endProcedure sqlSel
sqlSel1: procedure expose m.
parse arg src, type, var
r = jOpen(oNew('SqlSel', src, type), '<')
if \ jReadO(r, var) then
call err 'eof on 1. Read in sqlSel1'
if jReadO(r, sqlSql.ver) then
call err 'not eof on 2. Read in sqlSel1'
call jClose r
return
endProcedure sqlSel1
/*--- prepare and open cursor
generate type and fetchList ------------------------------------*/
sqlSelOpen: procedure expose m.
parse arg m, opt
if opt\== m.j.cRead then
call err 'opt not' m.j.cRead 'sqlSelOpen('m',' opt')'
m.m.cursor = sqlGetCursor(m.m.cursor)
call sqlPreOpen m.m.cursor, m.m.src, m.m.type == ''
if m.m.type == '' then do
m.m.type = sqlDA2type('SQL.'m.m.cursor'.D')
m.m.fetch = ''
end
if m.m.fetch == '' then
m.m.fetch = sqlFetchVars(m.m.type, 'M.V')
m.m.jReading = 1
return m
endProcedure sqlOpen
/*--- return a free cursor -------------------------------------------*/
sqlGetCursor: procedure expose m.
parse arg last
cx = 0
if datatype(last, 'n') & last>0 & last<=length(m.sqlO.cursors) then
if pos(substr(m.sqlo.cursors, last, 1), 'c ') > 0 then
cx = last
if cx == 0 then
cx = pos(' ', m.sqlo.cursors)
if cx == 0 then
cx = pos('c', m.sqlo.cursors)
if cx = 0 then
call err 'no more cursors' m.sqlo.cursors
m.sqlo.cursors = overlay('o', m.sqlo.cursors, cx)
return cx
endProcedure sqlGetCursor
/*--- mark a cursor as closed ----------------------------------------*/
sqlFreeCursor: procedure expose m.
parse arg cx
if cx < 1 | cx > length(m.sqlo.cursors) then
call err 'bad cursor sqlFreeCursor('cx')'
m.sqlo.cursors = overlay('c', m.sqlo.cursors, cx)
return cx
endProcedure sqlFreeCursor
/*--- create a type for a sqlDA --------------------------------------*/
sqlDA2type: procedure expose m.
parse arg da , ind
ff = ''
do ix=1 to m.da.sqlD
f1 = word(m.da.ix.sqlName, 1)
if f1 == '' then
f1 = 'COL'ix
if (ind == 1 & m.da.ix.sqlType // 2 = 1) | ind == 2 then
ff = ff', f' f1' v, f' f1'.IND v'
else
ff = ff', f' f1 'v'
end
return classNew('n SQL* u' substr(ff, 3))
endProcedure sqlGenType
/*--- create the fetch vars sql syntx -------------------------------*/
sqlFetchVars: procedure expose m.
parse arg cla, pre
vv = ''
f = class4name(cla)'.FLDS'
la = '?'
do fx=1 to m.f.0
if la'.IND' \== m.f.fx then
vv = vv','
vv = vv ':'pre || m.f.fx
end
return substr(vv, 3)
endProcedure sqlFetchVars
/*--- fetch cursor for this sqlSel -----------------------------------*/
sqlSelRead: procedure expose m.
parse arg m, v
call oMutate v, m.m.type
return sqlFetchInto(m.m.cursor, m.m.fetch)
endProcedure sqlSelRead
/*--- close sql Cursor -----------------------------------------------*/
sqlSelClose: procedure expose m.
parse arg m, v
call sqlClose m.m.cursor
call sqlFreeCursor m.m.cursor
return m
endProcedure sqlSelClose
/*--- fetch cursor 'c'cx into destination dst
each column is formatted and assigned to m.dst.<colName> ---*/
sqlFetch: procedure expose m.
parse arg cx, dst
if ^ sqlFetchInto(cx, 'descriptor :M.SQL.'cx'.D') then
return 0
if dst == '' then
return 1
fi = oFlds(sqlType(cx))
fo = m.sql.cx.fmt
do ix=1 to m.sql.cx.d.SQLD
f = m.fi.ix
if m.sql.cx.d.ix.sqlInd = 0 then
m.dst.f = fmt(m.sql.cx.d.ix.sqlData, m.fo.ix)
else
m.dst.f = fmtS(m.sqlNull, m.fo.ix)
end
return 1
endProcedure sqlFetch
/*--- fetch all rows into stem st
from sql src using type ty and format fmt -----------------*/
sql2St: procedure expose m.
parse arg st, src, ty, fmt
cx = 49
call sql2Cursor cx, src, ty, fmt
call sqlOpen cx
do ix=1 by 1 while sqlFetch(cx, st'.'ix)
end
m.st.0 = ix-1
call sqlClose cx
return ix-1
endProcedure sql2St
/*--- prepare statement 's'cx and declare cursor 'c'cx from sql src
use or generate type ty and format fo ---------------------*/
sql2Cursor: procedure expose m.
parse arg cx, src, ty, fo
call sqlPreDeclare cx, src, 1 /* with describe output */
call sqlGenType cx, ty
m.Sql.cx.FMT.0 = 0
m.Sql.cx.FMT = sqlGenFmt('SQL.'cx'.FMT', cx, fo)
call assert 'm.'m.sql.cx.fmt'.0 >= m.sql.cx.d.sqlD', 'too few fmt'
return
endProcedure sql2Cursor
/*--- return the type for sql cx -------------------------------------*/
sqlType: procedure expose m.
parse arg cx
return oGetTypePara('SQL.TY.'cx)
/*--- fetch cursor 'c'cx
put the formatted and concatenated columns into m.var
return 1 if a row fetched, 0 if not ------------------------*/
sqlFetchLn: procedure expose m.
parse arg cx, var
st = 'SQL.'cx'.FET'
if ^ sqlFetch(cx, st) then
return 0
m.var = oFldCat(sqlType(cx), st, m.sql.cx.fmt)
return 1
endProcedure sqlFetchLn
/*--- generate the type sql cx as specified in ty
use the information from the sqlDa -------------------------*/
sqlGenType: procedure expose m.
parse arg cx, ty
if ty == '*' | ty = '' then do
ff = ''
do ix=1 to m.sql.cx.d.sqlD
f1 = word(m.sql.cx.d.ix.sqlName, 1)
if f1 == '' then
f1 = 'COL'ix
ff = ff f1
end
ty = oFldOnly(ff, 'e')
end
call oSetTypePara 'SQL.TY.'cx, ty, 'noCall'
return ty
endProcedure sqlGenType
/*--- generate the format ff for a sql cx as specified in sp
use the information from the sqlDa -------------------------*/
sqlGenFmt: procedure expose m.
parse arg ff, cx, sp
if abbrev(sp, '=') then
return substr(sp, 2)
if sp = '' then
sp = '*st'
m.ff.0 = m.sql.cx.d.sqlD
m.ff.flds = oFlds(sqlType(cx))
if abbrev(sp, '*') then do
do ix=1 to m.ff.0
m.ff.ix = substr(sp, 2)
end
return ff
end
if abbrev(fmts, '=') then
m.Sql.cx.FMT = substr(fmts, 2)
defs = 'ir7 fr9 sl12 Tl26' sp
do wx = 1 to words(defs)
parse value word(defs, wx) with ty 2 fo
select
when ty = 'd' then t.384 = fo
when ty = 'f' then t.480 = fo'/f'
when ty = 'i' then t.496 = fo'/i'
when ty = 'n' then t.484 = fo'/n'
when ty = 's' then t.448 = fo
when ty = 't' then t.388 = fo
when ty = 'T' then t.392 = fo
otherwise call err 'bad type' ty 'for format' fo
end
end
if symbol('t.496') == 'VAR' then
t.500 = t.496
if symbol('t.448') == 'VAR' then do
t.452 = t.448
t.456 = t.448
t.464 = t.448
end
do wx = 1 to m.ff.0
ty = m.sql.cx.d.wx.sqlType
le = m.sql.cx.d.wx.sqlLen
withNulls = ty // 2
ty = ty - withNulls
if symbol('t.ty') <> 'VAR' then
call err 'sqlType' ty 'not supported'
parse var t.ty fo 2 fl '/' op
if op = 'i' then
if le = 2 then le = 6
else le = 12
else if op <> '' then
call err 'length for sqlType' ty 'op' op 'not implemented'
if fl = '=' then
fl = le
else if abbrev(fl, '<') then
fl = min(le, substr(fl, 2))
m.ff.wx = fo || fl
end
return ff
endProcedure sqlGenFmt
/*--- sql o interface ------------------------------------------------*/
/*--- return a reader for the givenn sql or std input ----------------*/
sql2Obj: procedure expose m.
parse arg cx, src, ty, fo
if ty = '' then
ty = '*'
if src == '' then
src = envCatStr(' ', 'sb')
call sql2Cursor cx, src, ty, substr(fo, 1+abbrev(fo, '~'))
call oMutate 'SQL.TY.'cx, 'SqlType'
return 'SQL.TY.'cx
endProcedure sql2obj
/*--- write to std output the result columns of
the sql given in src or std input --------------------------*/
sql: procedure expose m.
parse arg cx, src, ty, fo
call jWriteAll m.j.out, "r£", sql2Obj(cx, src, ty, fo)
return
endProcedure sql
/*--- write to std output the result lines of
the sql given in src or std input --------------------------*/
sqlLn: procedure expose m.
parse arg cx, src, ty, fo
if fo = '' then
fo = '~'
squash = abbrev(fo, '~')
if ^ abbrev(fo, '=') then
fo = left(fo, squash) 'sl=' substr(fo, squash+1)
t = sql2Obj(cx, src, ty, fo)
if squash then do
call fmtFldSquashRw t, 'opCl'
return
end
m = 'SQL.LN.'cx
call oMutate m, 'SqlLn'
call jWrite m.j.out, fmtFldTitle(m.sql.cx.fmt)
call jWriteAll m.j.out, "r£", m
return
endProcedure sqlLn
/* copy sqlO end **************************************************/
/* copy sql begin ***************************************************
sql interface
***********************************************************************/
sqlIni: procedure expose m.
m.sqlNull = '---'
return
endProcedure sqlIni
/*--- prepare statement 's'cx from sql src into descriptor desc ------*/
sqlPrepare: procedure expose m.
parse arg cx, src, descOut, descInp
s = ''
if descOut == 1 then
s = 'into :M.SQL.'cx'.D'
call sqlExec 'prepare s'cx s 'from :src'
if descInp == 1 | (descInp == '' & pos('?', src) > 0) then
call sqlExec 'describe input s'cx 'into :M.SQL.'cx'.I'
else
m.sql.cx.i.sqlD = 0
return
endProcedure
/*--- prepare and declare 'c'cx from sql src -------------------------*/
sqlPreDeclare: procedure expose m.
parse arg cx, src, descOut, descInp
call sqlPrepare cx, src, descOut, descInp
call sqlExec 'declare c'cx 'cursor for s'cx
return
endProcedure sqlPreDeclare
/*--- prepare, declare and open 'c'cx from sql src -------------------*/
sqlPreOpen: procedure expose m.
parse arg cx, src, descOut, descInp
call sqlPreDeclare cx, src, descOut, descInp
call sqlOpen cx
return
endProcedure sqlPreOpen
/*--- open cursor 'c'cx using arguments arg(2), arg(3)... ------------*/
sqlOpen: procedure expose m.
parse arg cx
do ix=1 to arg()-1
call sqlDataSet 'SQL.'cx'.I', ix, arg(ix+1)
end
call sqlExec 'open c'cx 'using descriptor :M.SQL.'cx'.I'
return
endProcedure sqlOpen
/*--- close cursor 'c'cx ---------------------------------------------*/
sqlClose: procedure expose m.
parse arg cx, src
return sqlExec('close c'cx)
endProcedure sqlClose
/*--- fetch cursor 'c'cx into variables ggVars -----------------------*/
sqlFetchInto:
parse arg ggCx, ggVars
if ggVars == '' then
ggVars = 'descriptor :M.SQL.'ggCX'.D'
/* accept sqlCodes > 0 except 100 */
return sqlExec('fetch c'ggCx 'into' ggVars, 0 100) <> 100
endProcedure sqlFetchInto
/*--- return sql variable list for stem st and fields the word in vars
if withInd == 1 then with sqlIndicator variables
sqlVars('S', 'A B') --> ':S.A, :S.B'
sqlVars('S', 'A B', 1) --> ':S.A :S.A.SQLIND, :S.B :S.B.SQLIND'
----------------------------------------------------------------------*/
sqlVars: procedure expose m.
parse arg st, vars, withInd
res = ''
if st ^== '' then
st = st'.'
do ix=1 to words(vars)
res = res', :'st || word(vars, ix)
if withInd == 1 then
res = res ':'st || word(vars, ix)'.SQLIND'
end
return substr(res, 3)
endProcedure sqlVars
sqlVarsNull: procedure expose m.
parse arg st, vars
hasNulls = 0
do ix = 1 to words(vars)
fld = word(vars, ix)
if m.st.fld.sqlInd < 0 then do
m.st.fld = m.sqlNull
hasNulls = 1
end
end
return hasNulls
endProcedure sqlVarsNull
sqlDescNull: procedure expose m.
parse arg cx
desc = 'SQL.'ggCX'.D',
hasNulls = 0
do ix=1 to m.desc.SQLD
if m.desc.ix.sqlInd < 0 then do
m.desc.ix.sqlData = m.sqlNull
hasNulls = 1
end
end
return hasNulls
endProcedure sqlDescNull
/*--- open cursor 'c'cx fetch all into variables vars and close
st = passed stem, sx = row number
return number of rows fetched ----------------------------------*/
sqlOpAllCl:
parse arg ggCx, st, ggVars
do ggAx=4 to arg()
call sqlDataSet 'SQL.'ggCx'.I', ggAx-3, arg(ggAx)
end
call sqlOpen ggCx
do sx = 1 while sqlFetchInto(ggCx, ggVars)
end
m.st.0 = sx - 1
call sqlClose ggCx
return m.st.0
endProcedure sqlOpAllCl
sqlDataSet: procedure expose m.
parse arg da, ix, val
m.da.ix.sqlData = val
m.da.ix.sqlInd = - (arg(ix+2) == m.sqlNull)
return
endProcedure sqlDataSet
/*--- prepare, declare open cursor 'c'cx, fetch all and close
return number of rows fetched ----------------------------------*/
sqlPreAllCl:
parse arg ggCx, ggSrc, st, ggVars
call sqlPreDeclare ggCx, ggSrc
return sqlOpAllCl(ggCx, st, ggVars)
endProcedure sqlPreAllCl
/*--- execute statement 's'cx using arguments arg(2), arg(3)... ------*/
sqlExecute:
parse arg ggCx retOk
do ggAx=2 to arg()
call sqlDataSet 'SQL.'ggCx'.I', ggAx-1, arg(ggAx)
end
return sqlExec('execute s'ggCx 'using descriptor :M.SQL.'ggCx'.I',
, retOk)
endProcedure
/*--- execute immediate the sql src ----------------------------------*/
sqlExImm:
parse arg ggSrc, ggRet
return sqlExec('execute immediate :ggSrc', ggRet)
endProcedure sqlExImm
sqlCommit: procedure expose m.
parse arg src
return sqlExec('commit')
endProcedure sqlCommit
/*--- execute sql thru the dsnRexx interface -------------------------*/
sqlExec: /* no procedure, to keep variables sql... */
parse arg ggSqlStmt, ggRet, ggNo
if ggNo <> '1' then
ggSqlStmt = 'execSql' ggSqlStmt
address dsnRexx ggSqlStmt
/* say 'sqlCode' sqlCode 'rc' rc 'for' ggSqlStmt ggNo */
if rc = 0 then
return 0
else if ggRet = '*' | wordPos(sqlCode, ggRet) > 0 then
return sqlCode
else if rc < 0 then
call err sqlmsg()
else if sqlWarn.0 ^== ' ' | sqlCode <> 0 then
call errSay sqlMsg(), ,'w'
return sqlCode
endSubroutine sqlExec
/*--- connect to the db2 subsystem ggSys -----------------------------*/
sqlConnect: procedure expose m.
parse arg ggSys, ggRetCon
call sqlIni
address tso "SUBCOM DSNREXX"
if rc <> 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
if ggSys = '-' then
return 0
return sqlExec("connect" ggSys, ggRetCon ,1)
endProcedure sqlConnect
/*--- diconnect from db2 ---------------------------------------------*/
sqlDisconnect: procedure expose m.
parse arg ggRet
return sqlExec("disconnect ", ggRet, 1)
endProcedure sqlDisconnect
/*--- issue an sql error message -------------------------------------*/
sqlMsg: /* no procedure, to keep variables sql... */
signal on syntax name sqlMsgOnSyntax
ggRes = 'sqlCode' sqlCodeT(sqlCode, sqlErrMc, sqlwarn.0':' ,
|| sqlwarn.1||sqlwarn.2||sqlwarn.3||sqlwarn.4||sqlwarn.5',',
|| sqlwarn.6||sqlwarn.7||sqlwarn.8||sqlwarn.9||sqlwarn.10)
if 0 then
sqlMsgOnSyntax: do
ggRes = 'sqlCode' sqlCode translate(sqlErrMc, ',', 'ff'x),
'<<rexx sqlCodeT not found or syntax>>\nwarnings'
do ggX=0 to 10
if sqlWarn.ggx <> '' then
ggRes = ggRes ggx'='sqlWarn.ggx
end
end
signal off syntax
ggRes = ggRes'\nstate' sqlState'\nstmt = ' ggSqlStmt
ggPref = '\nwith'
ggXX = pos(':', ggSqlStmt)+1
do 12 while ggXX > 1
ggYY = verify(ggSqlStmt, ' ,:+-*/&%?|()¢!', 'm', ggXX)
if ggYY < 1 then
ggYY = length(ggSqlStmt) + 1
ggVar = substr(ggSqlStmt, ggXX, ggYY - ggXX)
if ggVar <> '' then do
ggRes = ggRes || ggPref ggVar '=' value(ggVar)
ggPref = '\n '
end
ggXX = pos(':', ggSqlStmt, ggYY+1) + 1
end
return ggRes
endSubroutine sqlMsg
/*--- send a command to db2 through the TSO dsn processor ------------*/
sqlDsn: procedure expose m.
parse arg st, sys, cmd, rcOk
x = outtrap('M.'st'.')
push 'END'
push cmd
address tso 'DSN SYSTEM('sys')'
rr = rc
x = outtrap(off)
if rr = 0 | rcOk = '*' | wordPos(rr, rcOk) > 0 then
return rr
fl = max(1, m.st.0 - 10)
em = 'rc' rr 'for DSN SYSTEM('sys') cmd' cmd,
'\nOuputlines' fl '-' m.st.0':'
do lx=fl to m.st.0
em = em '\n' strip(m.st.lx, 't')
end
call err em
endProcedure sqlDsn
/* copy sql end **************************************************/
/* copy csi begin ***************************************************
csi interface: see dfs managing catalogs appendix c
returncode/reason see message IDC3009I
**********************************************************************/
/*--- specify dsn mask and fields to start a csi catalog search --------
arguments:
m objectPointer
dsnMask specifies the dsns with wildcards:
% 1 character
* 0 - n character in one level
** 0 - n levels
fields a (space separated) list of field names -------------*/
csiOpen: procedure expose m.
parse arg m, dsnMask, fields
m.m.fld.0 = words(fields)
ffix = d2c(m.m.fld.0, 2)
do x=1 to m.m.fld.0
m.m.fld.x = translate(word(fields, x))
ffix = ffix || left(m.m.fld.x, 8)
end
if dsnMask \== '' & pos('*', dsnMask) < 1 then
dsnMask = dsnMask'.**'
m.m.filt = left(dsnMask, 149) ,
|| left('Y', 3) , /* resume offset 149 */
|| ffix /* csiNumEn offset 152 */
WORKLEN = 1024 * 64
m.m.work = D2C(WORKLEN,4) || COPIES('00'X,WORKLEN-4)
m.m.pos = workLen + 1
return
endProcedure csiOpen
/*--- put the next dsn into m.o and m.o.* (for other fields)
return 1 if next dsn exists 0 otherwise ------------------------*/
csiNext: procedure expose m.
parse arg m, o
usedL = C2D(SUBSTR(m.m.work,9,4)) /* GET AMOUNT OF WORK AREA USED */
px = m.m.pos
do forever
if px > usedL then do
if substr(m.m.filt, 150, 1) \== 'Y' then do
m.m.pos = px
m.o = ''
return 0
end
reason = left('', 4)
ADDRESS LINKPGM 'IGGCSI00 reason m.'m'.filt m.'m'.work'
if rc == 0 & substr(reason, 3, 2) == '0000'x then
nop
else if rc == 4 & substr(reason, 3, 2) == '0464'x then
say 'data set entry with error'
else
call err 'call csi returns' rc,
'rc' c2d(substr(reason, 4,1)),
'reason' c2d(substr(reason, 3,1)),
'module' substr(reason, 1,2)
usedL = C2D(SUBSTR(m.m.work,9,4)) /* GET WORK AREA USED */
numFD = C2D(SUBSTR(m.m.work,13,2)) /* no flds + 1 */
if numFd <> m.m.fld.0 + 1 then
call err 'csiNumFd' numFd 'not' m.m.fld.0 '+' 1
px = 15
iterate
end
eType = substr(m.m.work, px+1, 1)
m.o = strip(substr(m.m.work, px+2, 44), 't')
flag = substr(m.m.work, px, 1)
/* say 'eType' eType m.o 'flag' c2x(flag) */
if eType == '0' then do
if flag \== '00'x & flag \== '40'x then
call err 'flag' c2x(flag) 'for catalog' m.o
px = px + 50 /* length of catalog entry */
iterate
end
else do
if \ abbrev(x2b(c2x(flag)), '101') then
call err 'call csi entry flag' x2b(c2x(flag)),
'rc' c2d(substr(m.m.work, px+49,1)),
'reason' c2d(substr(m.m.work, px+48,1)),
'module' substr(m.m.work, px+46, 2),
'for entry' m.o,
'see qw IDC3009I'
py = px + 46
tl = c2d(substr(m.m.work, py, 2))
pl = py + 4
pf = py + m.m.fld.0 * 2 + 4
do fx = 1 to m.m.fld.0
fi = m.m.fld.fx
fl = c2d(substr(m.m.work, pl, 2))
m.o.fi = substr(m.m.work, pf, fl)
if fi = 'MGMTCLAS' then
m.o.fi = substr(m.o.fi, 3, c2d(left(m.o.fi ,2)))
else if wordPos(fi, 'COMUDSIZ NOBYTTRK') > 0 then
m.o.fi = c2d(m.o.fi)
pf = pf + fl
pl = pl + 2
end
if py + tl <> pf then
call err 'length mismatch for entry' m.o
m.m.pos = pf
return 1
end
end
endProcedure csiNext
/*--- if dsn is arcived return 'arcive'
if dsn is tape return 'tape'
otherwise return managment class ------------------------------*/
csiArcTape: procedure expose m.
parse arg vo, cl, dt, dsn
if vo = '' then
say err '||| no volume for dsn' dsn
else if vo = 'ARCIVE' then
res = 'arcive'
else if cl <> '' then
res = cl
else if abbrev(vo, 'SHR') then
res = 'SHR'
else
res = 'tape'
if res = 'arcive' then
return res
/*if abbrev(res, 'ar') \= abbrev(dt, '00'x) , */
if abbrev(res, 'ta') \= abbrev(c2x(left(dt, 1)), '7') ,
| (left(res, 1) >= 'A') \= abbrev(dt, '30'x) then
say '||| mismatch cl' cl 'vo' vo 'dt' c2x(dt) 'dsn' dsn
return res
endProcedure csiArcTape
/* copy csi end ******************************************************/
/* copy csm begin ******************************************************
interface to csm,
it is integrate with adrTso, eg. dsnAlloc , 'RZ3/..' uses csm
***********************************************************************/
adrCsm:
return adrTso('csmExec' arg(1), arg(2))
endProcedure adrCsm
csmCopy: procedure expose m.
parse arg csnFr, csnTo, ggRet
if dsnGetMbr(csnTo) ^= '' ,
& dsnGetMbr(csnFr) <> dsnGetMbr(csnTo) then
call err 'member rename' csnFr 'to' csnTo
parse value csmSysDsn(csnFr) with sysFr '/' dsnFr
parse value csmSysDsn(csnTo) with sysTo '/' dsnTo
if sysFr = '*' & sysTo <> '*' then do
pdsTo = dsnSetMbr(dsnTo)
al = "SYSTEM("sysTo") DDNAME(COPYTo)",
"DATASET('"pdsTo"') DISP(SHR)"
alRes = dsnAlloc(systo'/'pdsTo, ,'COPYTO', '*')
if datatype(alRes, 'n') then do
/* wir müssen es selbst allozieren csmxUtil
vergisst management class ||||| */
say 'could not allocate' al
say 'trying to create'
rc = listDsi("'"dsnSetMbr(dsnFr)"' SMSINFO")
if rc = 0 then
mv = ''
else if rc = 4 & sysReason = 19 then do
mv = 'UNITCNT(30)'
say 'multi volume' mv
end
else if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
al = left(al, length(al)-4)'CAT)'
if right(sysDsSms, 7) == 'LIBRARY' ,
| abbrev(sysDsSms, 'PDS') then
al = al 'DSNTYPE(LIBRARY)'
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
al = al "DSORG("sysDSorg") MGMTCLAS("sysMgmtClass")",
"RECFM("sysREcFM") LRECL("SYSLRECL")",
"blksize("sysBLkSIZE")",
"SPACE("sysPrimary"," sysSeconds")" sysUnits mv
call adrCsm "allocate" al
end
call adrTso 'free dd(copyTo)'
end
c = "'COPY" sysFr"/''"dsnFr"'' TO" ,
sysTo"/''"dsnSetMbr(dsnTo)"'' REPLACE'"
return adrTso("exec 'CSM.RZ1.P0.EXEC(CSRXUTIL)'" c , ggRet)
return
endProcedure csmCopy
csmAlloc: procedure expose m.
parse arg dsn dd disp rest ':' nn, retRc
sys = ''
a2 = ''
parse value csmSysDsn(dsn) with sys '/' dsn
if disp = '' then
disp = 'shr'
al = "SYSTEM("sys") DDNAME("dd")"
if dsn <> '' then do
a2 = "DATASET('"dsnSetMbr(dsn)"')"
mbr = dsnGetMbr(dsn)
if mbr <> '' then
a2 = a2 'MEMBER('mbr')'
end
if abbrev(disp, 'SYSOUT(') then
a2 = a2 disp
else
a2 = a2 "DISP("disp")"
if retRc <> '' | nn = '' then do
alRc = adrCsm('allocate' al a2 rest, retRc)
if alRc <> 0 then
return alRc
return dd 'call adrTso "free dd('dd')";'
end
do retry=0 by 1
alRc = adrCsm('allocate' al a2 rest, '*')
if alRc = 0 then
return dd 'call adrTso "free dd('dd')";'
if retry > 0 | nn = '' | wordPos(disp, 'OLD SHR') < 1 then
return err('cmsAlloc rc' alRc 'for' al rest)
say 'csmAlloc rc' alRc 'for' al a2 rest '...trying to create'
nn = al 'disp(cat)' dsnCreateAtts(dsn, nn, 1)
call adrCsm 'allocate' nn
call adrTso 'free dd('dd')'
end
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
/* copy csm end********************************************************/
/* copy adrIsp begin *************************************************/
/**********************************************************************
lmd: catalog read
call sequence: lmdBegin, lmdNext*, lmdEnd
mit lmd service (mit save in file und read,
weil list zu langsam und listcat abstürzt)
1. arg (grp) als group dataset für lmd save
und dd name für file read
***********************************************************************/
lmdBegin: procedure expose m.
parse arg grp, lev
call adrIsp 'lmdinit listid(lmdId) level('lev')'
res = adrIsp('lmdlist listid(&lmdId) option(save) group('grp')', 4)
call adrIsp 'lmdfree listid(&lmdId)'
if res = 0 then do
call trc timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') shr dsn('grp'.datasets)'
end
else do
call trc 'no datasets found' timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') dummy'
end
call readDDBegin grp
return /* end lmdBegin */
lmdNext:
parse arg ggGrp, ggSt, withVolume
if \ readDD(ggGrp, ggSt) then
return 0
if withVolume \== 1 then
do ggIx=1 to value(ggSt'0')
x = value(ggSt || ggIx, word(value(ggSt || ggIx), 1))
end
return 1
endSubroutin lmdNext
lmdEnd: procedure expose m.
parse arg grp
call readDDEnd grp
call adrTso 'free dd('grp')'
return /* end lmdEnd */
lmd: procedure expose m.
parse arg lev, withVol
call lmdBegin gg1, lev
do while lmdNext(gg1, q., withVol)
do x=1 to q.0
call out q.x
end
end
call lmdEnd gg1
return
endProcedure lmd
/**********************************************************************
member list of a pds:
call sequence x=lmmBegin(dsn) lmmNext(x) * lmmEnd(x)
***********************************************************************/
lmm: procedure expose m.
parse arg dsn
id = lmmBegin(dsn)
do ix=1 by 1
m = lmmNext(id)
if m = '' then
leave
call out m
end
call lmmEnd id
return
endProcedure lmm
lmmBegin: procedure expose m.
parse arg dsn
mbr = dsnGetMbr(dsn)
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET('"pds"') ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(INPUT) "
res = lmmId
if mbr <> '' then
res = res 'pattern('mbr')'
return res
endProcedure lmmBegin
lmmEnd: procedure expose m.
parse arg lmmId opt
call adrIsp "LMMLIST DATAID("lmmId") option(free)", 8
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
return
endProcedure lmmEnd
lmmNext: procedure expose m.
parse arg lmmId opt
if adrIsp("LMMLIST DATAID("lmmid")" ,
"OPTION(LIST) MEMBER(Mbr)" opt, 4 8) = 0 then
return strip(mbr)
else
return ''
endProcedure lmmNext
lmmRm: procedure expose m.
parse arg dsn, mbrs
mbrs = dsnGetMbr(dsn) mbrs
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET("pds") ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(OUTPUT) "
err = ''
do wx=1 to words(mbrs)
m1 = word(mbrs, wx)
rr = adrIsp("lmmDel dataid("lmmId") member("m1")", 0 8 12)
if rc = 0 then
say 'removed' m1 'from' pds
else if rc = 8 then
say 'not found' m1 'in' pds
else do
err = 'error deleting' m1 'in' pds 'rc' rr strip(zerrlm)
say err
leave
end
end
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
if err <> '' then
call err err
return
endProcedure lmmRm
/*--- address ispf with error checking -------------------------------*/
adrIsp:
parse arg ggIspCmd, ggRet
address ispexec ggIspCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr ispExec rc' rc 'in' ggIspCmd':' strip(zerrlm)
endSubroutine adrIsp
/*--- address editor with error checking -----------------------------*/
adrEdit:
parse arg ggEditCmd, ggRet
address isrEdit ggEditCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr isrEdit rc' rc 'for' ggEditCmd
endSubroutine adrEdit
/* copy adrIsp end *************************************************/
/* copy adrTso begin *************************************************/
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet ---*/
adrTso:
parse arg ggTsoCmd, ggRet
address tso ggTsoCmd
if rc == 0 then return 0
else if ggRet == '*' then return rc
else if wordPos(rc, ggRet) > 0 then return rc
else
call err 'adrTso rc' rc 'for' ggTsoCmd
return /* end adrTso */
/*--- format dsn from tso format to jcl format -----------------------*/
dsn2jcl: procedure expose m.
parse upper arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
cx = pos('~', dsn)
if cx < 1 & addPrefix == 1 then
return sp'.'dsn
do while cx \== 0
le = left(dsn, cx-1)
ri = substr(dsn, cx+1)
if right(le, 1) == '.' | left(ri, 1) == '.' then
dsn = le || sp || ri
else
dsn = le || left('.', le \== '') || sp ,
|| left('.', ri \== '') || ri
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
parse arg dsn, mbr
bx = pos('(', dsn)
if bx > 0 then
dsn = strip(left(dsn, bx-1))
if mbr <> '' then
dsn = dsn'('strip(mbr)')'
return dsn
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn
lx = pos('(', dsn)
rx = pos(')', dsn, lx+1)
if lx < 1 then
return ''
else if lx < rx then
return substr(dsn, lx+1, rx-lx-1)
else
return strip(substr(dsn,lx+1))
endProcedure dsnGetMbr
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: readDDBegin, readDD*, readDDEnd
write: writeBegin, writeDD*, writeEnd
readDD returns true if data read, false at eof
***********************************************************************/
/*--- prepare reading from a DD --------------------------------------*/
readDDBegin: procedure expose m.
parse upper arg ggDD
call errAddCleanup 'call readDDEnd' ggDD', "*"'
return /* end readDDBegin */
/*--- read from DD ggDD into ggSt, return false at eof ---------------*/
readDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskr' ggDD '(stem' ggSt')', 2
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- finish reading DD ggDD ----------------------------------------*/
readDDEnd: procedure expose m.
parse upper arg ggDD, ggRet
call errRmCleanup 'call readDDEnd' ggDD', "*"'
return adrTso('execio 0 diskr' ggDD '(finis)', ggRet)
endProcedure readDDEnd
/*--- prepare writing to DD ggDD -------------------------------------*/
writeDDBegin: procedure expose m.
parse upper arg ggDD
/* ensure file is erased, if no records are written */
call adrTso 'execio' 0 'diskw' ggDD '(open)'
call errAddCleanup 'call writeDDEnd' ggDD', "*"'
return /* end writeDDBegin */
/*--- write to gg ggDD from stem ggSt, ggCnt records -----------------*/
writeDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt == '' then
ggCnt = value(ggst'0')
call adrTso 'execio' ggCnt 'diskw' ggDD '(stem' ggSt')'
return
endSubroutine writeDD
/*--- end writing to dd ggDD (close) --------------------------------*/
writeDDEnd: procedure expose m.
parse upper arg ggDD, ggRet
call errRmCleanup 'call writeDDEnd' ggDD', "*"'
return adrTso('execio 0 diskw' ggDD '(finis)', ggRet)
endProcedure writeDDEnd
/*--- standardise a dsn spec
word1 dsName or -
word2 dd or -
word3 disp or -
word4 to first : attributes in tso format
after first : attributes for new allocation
----------------------------------------------------------------------*/
dsnSpec: procedure expose m.
parse upper arg spec
rr = '' /* put leading - in separate words */
do sx=1 while words(rr) < 3 & wx \= ''
wx = word(spec, sx)
do while abbrev(wx, '-') & words(rr) < 3
wx = substr(wx, 2)
rr = rr '-'
end
rr = rr wx
end
spec = rr subWord(spec, sx)
na = ''
dd = ''
di = ''
if left(spec, 1) = '&' then /* external spec is handled ok */
spec = strip(substr(spec, 2))
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, '.') | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
di = w
else if w = 'CATALOG' then
di = di w
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
na = strip(substr(w, 5, length(w)-5))
else if na == '' then
na = dsn2jcl(w)
else if dd == '' then
dd = w
else if di == '' then
di = w
else
leave
end
if na == '' then
na = '-'
else if abbrev(na, "'") then
na = substr(na, 2, length(na)-2)
if dd == '' then dd = '-'
if di == '' then di = '-'
re = subword(spec, wx)
if abbrev(re, '.') then
re = substr(re, 2)
return na dd di re
endProcedure dsnSpec
/*--- alloc a dsn with dsnAlloc
if the dsn is inuse wait and retry
until either the allocation is successfull
or the timeout occurs --------------------------------------*/
dsnAllocWait: procedure expose m.
parse upper arg spec, pDi, pDD, timeOut
x = max(1, arg() - 1)
do rt=0
m.adrTsoAl.1 = ''
m.adrTsoAl.2 = ''
m.adrTsoAl.3 = ''
call outtrap m.adrTsoAl.
res = dsnAlloc(spec, pDi, pDD, '*')
call outtrap off
if \ abbrev(res, ' ') then
return res
msg = m.adrTsoAl.1'\n'm.adrTsoAl.2'\n'm.adrTsoAl.3
if rt > timeOut & timeOut \== '' then
return err('timeout allocating' spec time() '\n'msg)
if pos('DATA SET IS ALLOCATED TO ANOTHER', msg) < 1 then
return err('allocating' spec'\n'msg)
say time() 'sleep and retry alloc' spec
call sleep 1, 0
end
endProcedure dsnAllocWait
/*--- alloc a dsn or a dd
spec '-'<ddName>
datasetName? disposition? '.'? attributes? (':' newAtts)?
disp default disposition
dd default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc -----*/
dsnAlloc: procedure expose m.
parse upper arg spec, pDi, pDD, retRc
parse value dsnSpec(spec) with na dd di rest
if na = '-' then
m.dsnAlloc.dsn = ''
else
m.dsnAlloc.dsn = na
if na == '-' & dd \== '-' & di == '-' & rest = '' then
return dd
if dd == '-' & pDD \== '' then
dd = pDD
if dd == '-' then do
if symbol('m.adrTso.ddNum') = 'VAR' then
dd = m.adrTso.ddNum + 1
else
dd = 1
m.adrTso.ddNum = dd
dd = 'DD' || dd
end
if di = '-' & pDi \== '' then
di = pDi
if di = '-' then
di = 'SHR'
else if pos('(', na) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if pos('/', na) > 0 then
return csmAlloc(na dd di rest, retRc)
else
return tsoAlloc(na dd di rest, retRc)
endProcedure dsnAlloc
tsoAlloc: procedure expose m.
parse arg na dd disp rest ':' nn, retRc
c = 'alloc dd('dd')' disp
if na \== '-' then
c = c "DSN('"na"')"
call outtrap m.adrTsoAl.
alRc = adrTso(c rest, '*')
call outtrap off
if alRc = 0 then do
call errAddCleanup 'call tsoFree' dd', "*"'
return dd 'call tsoFree' dd';'
end
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& sysDsn("'"m.dsnAlloc.dsn"'") == 'DATASET NOT FOUND' then do
say 'tsoAlloc creating' c rest ':'nn
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na dd disp rest, retRc)
end
do ax=1 to m.adrTsoAl.0
say m.adrTsoal.ax
end
if retRc = '*' | wordPos(alRc, retRc) > 0 then
return ' ' alRc
call err 'tsoAlloc rc' alRc 'for' c rest
endProcedure tsoAlloc
tsoFree: procedure expose m.
parse arg dd, ggRet
call adrTso 'free dd('dd')', ggRet
call errRmCleanup 'call tsoFree' dd', "*"'
return
endProcedure tsoFree
dsnCreateAtts: procedure expose m.
parse arg dsn, atts, forCsm
bl = 32760
if abbrev(atts, ':') then do
rl = substr(atts, 3)
if abbrev(atts, ':F') then do
if rl = '' then
rl = 80
recfm='f b'
bl = bl - (bl // rl)
end
else do
if rl = '' then
rl = bl-4
recfm = substr(atts, 2, 1) 'B'
end
end
if pos('(', dsn) > 0 then
po = 'dsntype(library) dsorg(po)'
else
po = ''
dsn = dsnSetMbr(dsn)
if forCsm == 1 then
return "dataset('"dsn"')" po,
"recfm("space(recfm, 0)") lrecl("rl") blkSize("bl")" ,
"mgmtclas(COM#A091) space(10, 1000) cylinder"
else
return "dsn('"dsn"')" po,
"recfm("recfm") lrecl("rl") block("bl")" ,
"mgmtclas(COM#A091) space(10, 1000) cyl"
endProcedure dsnCreateAtts
/*--- read the dataset specified in ggDsnSpec to stem ggSt -----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
interpret subword(ggAlloc, 2)
return
endSubroutine readDsn
/*--- write the dataset specified in ggDsnSpec from stem ggSt
write ggCnt records if not empty otherwise ggst0
if ggSay 1 then say ... records written to ... -------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'open finis)'
interpret subword(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
copyDSN: procedure expose m.
parse arg frSpec, toSpec, ggSay
frDD = dsnAlloc(frSpec, 'SHR', 'FRDD')
toDD = dsnAlloc(toSpec, 'OLD', 'TODD')
call readDDBegin word(frDD, 1)
call writeDDBegin word(toDD, 1)
cnt = 0
do while readDD(word(frDD, 1), r.)
call writeDD word(toDD, 1), r.
cnt = cnt + r.0
end
call readDDEnd word(frDD, 1)
call writeDDEnd word(toDD, 1)
interpret ';' subword(frDD, 2) '; ; ;' subword(toDD, 2)
if ggSay == 1 | m.debug == 1 then
say cnt 'records copied from' frSpec 'to' to toSpec
return
endSubroutine writeDsn
/* copy adrTso end ****************************************************/
/* copy sleep begin ***************************************************/
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
/* copy sleep end *****************************************************/
/* copy j begin *******************************************************
the j framework
jReset
jOpen
jClose
jRead
jWrite
***********************************************************************/
jRead: procedure expose m.
parse arg m, var
call objMetClaM m, 'jRead'
if m.m.jReading then
interpret ggCode
else
return err('jRead('m',' var') but not opened r')
endProcedure jRead
jReadO: procedure expose m.
parse arg m, var
call objMetClaM m, 'jReadO'
if m.m.jReading then
interpret ggCode
else
return err('jReadO('m',' var') but not opened r')
endProcedure jReadO
jWrite: procedure expose m.
parse arg m, line
call objMetClaM m, 'jWrite'
if \ m.m.jWriting then
return err('jWrite('m',' line') but not opened w')
interpret ggCode
return
endProcedure jWrite
jWriteO: procedure expose m.
parse arg m, var
call objMetClaM m, 'jWriteO'
if \ m.m.jWriting then
return err('jWriteO('m',' var') but not opened w')
interpret ggCode
return
endProcedure jWriteO
jWriteAll: procedure expose m.
parse arg m, rdr
rdr = o2file(rdr)
call objMetClaM m, 'jWriteAll'
if \ m.m.jWriting then
return err('jWriteAll('m',' rdr') but not opened w')
interpret ggCode
return
endProcedure jWriteAll
jWriteNow: procedure expose m.
parse arg m, rdr
rdr = o2file(rdr)
interpret objMet(m, 'jWriteNow')
return
endProcedure jWriteNow
jCat: procedure expose m.
parse arg opt m
if m = '' then do
m = opt
opt = m.j.cWri
end
doClose = jOpenIfNotYet(m, opt)
do ax=2 to arg()
call jWriteAll m, arg(ax)
end
if doClose then
call jClose m
return m
endProcedure jCat
jWriteNowImpl: procedure expose m.
parse arg m, rdr
doClose = jOpenIfNotYet(rdr, m.j.cRead)
do while jRead(rdr, line)
call jWrite m, m.line
end
if doClose then
call jClose rdr
return
endProcedure jWriteNow
jWriteNowImplO: procedure expose m.
parse arg m, rdr
doClose = jOpenIfNotYet(rdr, m.j.cRead)
do while jReadO(rdr, line)
call jWriteO m, line
end
if doClose then
call jClose rdr
return
endProcedure jWriteNow
/*--- reset JRW: fail if open, initialise ---------------------------*/
jReset: procedure expose m.
parse arg m, arg, arg2, arg3
if m.m.jReading == 1 | m.m.jWriting == 1 then
return err('still open jReset('m',' arg2')') / 3
m.m.jReading = 0
m.m.jWriting = 0
interpret objMet(m, 'jReset')
return m
endProcedure jReset
jOpenIfNotYet: procedure expose m.
parse arg m, opt
if opt == m.j.cRead & m.m.jReading then
return 0
if (opt == m.j.cWri | opt == m.j.cApp) & m.m.jWriting then
return 0
call jOpen m, opt
return 1
endProcedure jOpenIfNotYet
jOpen: procedure expose m.
parse arg m, opt
call objMetClaM m, 'jOpen'
if m.m.jReading | m.m.jWriting then
return err('already opened jOpen('m',' opt')')
interpret ggCode
return m
endProcedure jOpen
jClose: procedure expose m.
parse arg m
call objMetClaM m, 'jClose'
if m.m.jReading | m.m.jWriting then
interpret ggCode
else
call err 'jClose' m 'but already closed'
m.m.jReading = 0
m.m.jWriting = 0
return m
endProcedure jClose
/*--- cat the lines of the file together, with mid between lines,
fail if not all lines are strings -------------------*/
jCatLines: procedure expose m.
parse arg m, mid
call jOpen m, '<'
if \ jRead(m, line) then
return ''
res = m.line
do while jRead(m, line)
res = res m.line
end
call jClose m
return res
endProcedure jCatLines
jIni: procedure expose m.
if m.j.ini == 1 then
return
m.j.ini = 1
m.j.cRead = '<'
m.j.cWri = '>'
m.j.cApp = '>>'
m.j.cVar = '}'
call oIni
am = "call err 'call of abstract method"
call classNew 'n JRW u ORun, f JREADING v, f JWRITING v', 'm',
, "new call jReset m, arg, arg2, arg3",
, "jRead" am "jRead('m',' var')'" ,
, "jReadO if \ jRead(m, var) then return 0;" ,
"call oMutate arg, m.class.classV; return 1" ,
, "jWrite" am "jWrite('m',' line')'" ,
, "jWriteO call jWrite(m, o2string(var))" ,
, "jWriteAll call jWriteNowImpl m, rdr",
, "jWriteNow call jWriteNowImpl m, rdr",
, "jReset",
, "jOpen" am" jOpen('m',' opt')'" ,
, "jClose" ,
, "oRun call pipeWriteAll m",
, "o2String return jCatLines(m, ' ')",
, "o2File return m"
call classNew 'n JRWO u JRW', 'm',
, "jRead if \ jReadO(m, 'J.GGVAR.'m) then return 0;" ,
"m.var = o2string('J.GGVAR.'m); return 1" ,
, "jReadO" am "jReadO('m',' var')'" ,
, "jWrite call jWriteO(m, s2o(var))" ,
, "jWriteO" am "jWriteO('m',' line')'",
, "jWriteAll call jWriteNowImplO m, rdr",
, "jWriteNow call jWriteNowImplO m, rdr",
am = "call err 'call errObject"
call classNew 'n JRWErr u JRW', 'm',
, "jWriteAll" er "jWriteAll 'm', rdr'",
, "jWriteNow" er "jWriteNow 'm', 'rdr'",
, "jClose" er "jClose 'm'"
call classNew 'n JRWOut u JRW', 'm',
, "jReset m.m.stem = arg;",
"if arg \== '' & \ dataType(m.arg.0, 'n') then",
"m.arg.0 = 0" ,
, "jWrite if m.m.stem == '' then say line;" ,
"else call mAdd m.m.stem, line" ,
, "jWriteO call classOut , var, 'outO: '",
, "jOpen if \ abbrev(opt, m.j.cWri) then",
"call err 'can only write JRWOut.jOpen('m',' opt')';" ,
"else m.m.jWriting = 1"
call classNew 'n JRWEof u JRW', 'm',
, "jRead drop m.var; return 0",
, "jOpen if pos('>', opt) > 0 then",
"call err 'can only read JRWEof.jOpen('m',' opt')';" ,
"else m.m.jReading = 1"
m.j.in = jOpen(oNew('JRWEof'), '<')
m.j.out = jOpen(oNew('JRWOut'), m.j.cWri)
call classNew "n JBuf u JRWO, f BUF s r", "m",
, "jOpen return jBufOpen(m, opt)",
, "jReset return jBufReset(m, arg)",
, "jRead return jBufRead(m, var)",
, "jReadO return jBufReadO(m, var)",
, "jWrite call jBufWrite m, line",
, "jWriteO call jBufWriteO m, var"
call classNew "n JBufRun u JBuf, f RUNNER r", "m",
, "jOpen return jBufRunOpen(m, opt)",
, "jReset return jBufRunReset(m, arg)"
return
endProcedure jIni
in: procedure expose m.
parse arg arg
return jRead(m.j.in, arg)
endProcedur in
inO: procedure expose m.
parse arg arg
return jReadO(m.j.in, arg)
endProcedur in
out: procedure expose m.
parse arg line
call jWrite m.j.out, line
return 0
endProcedure out
outO: procedure expose m.
parse arg arg
call jWriteO m.j.out, arg
return
endProcedure outO
/*--- jBuf: buffer read or write (supports datataypes) ---------------*/
jBuf: procedure expose m.
m = oNew('JBuf') /* calls jBufReset */
do ax=1 to arg()
m.m.buf.ax = arg(ax)
end
m.m.buf.0 = ax-1
m.m.allV = 1
return m
endProcedure jBuf
jBufReset: procedure expose m.
parse arg m
m.m.stem = m'.BUF'
do ax=1 to arg() - 1
m.m.buf.ax = arg(ax+1)
end
m.m.buf.0 = ax-1
m.m.allV = 1
return m
endProcedure jBufReset
jBufOpen: procedure expose m.
parse arg m, opt
if opt == m.j.cRead then do
m.m.readIx = 0
m.m.jReading = 1
return m
end
if opt == m.j.cWri then do
m.m.buf.0 = 0
m.m.allV = 1
end
else if opt \== m.j.cApp then
call err 'jBufOpen('m',' opt') with bad opt'
m.m.jWriting = 1
return m
endProcedure jBufOpen
jBufWrite: procedure expose m.
parse arg m, line
nx = mAdd(m'.BUF', line)
if \ m.m.allV then
m.class.o2c.nx = m.class.classV
return
endProcedure jBufWrite
jBufWriteStem: procedure expose m.
parse arg m, st
ax = m.m.buf.0
if m.m.allV then do
do sx=1 to m.st.0
ax = ax + 1
m.m.buf.ax = m.st.sx
end
end
else do
do sx=1 to m.st.0
ax = ax + 1
m.m.buf.ax = o2String(m.st.sx)
m.class.o2c.m.buf.ax = m.class.classV
end
end
m.m.buf.0 = ax
return m
endProcedure jBufWrite
jBufWriteO: procedure expose m.
parse arg m, ref
if m.m.allV then do
cl = objClass(ref)
if cl = m.class.classV then do
call mAdd m'.BUF', m.ref
return
end
if cl = m.class.classW then do
call mAdd m'.BUF', substr(ref, 2)
return
end
m.m.allV = 0
do ax=1 to m.m.buf.0
adr = m'.BUF.'ax
m.class.o2c.adr = m.class.classV
end
end
call oCopy ref, m'.BUF.'mInc(m'.BUF.0')
return
endProcedure jBufWriteO
jBufReadO: procedure expose m.
parse arg m, var
nx = m.m.readIx + 1
if nx > m.m.buf.0 then
return 0
m.m.readIx = nx
if m.m.allV then do
m.var = m.m.buf.nx
m.class.o2c.var = m.class.classV
end
else
call oCopy m'.BUF.'nx, var
return 1
endProcedure jBufReadO
jBufRead: procedure expose m.
parse arg m, var
nx = m.m.readIx + 1
if nx > m.m.buf.0 then
return 0
m.m.readIx = nx
if m.m.allV then do
m.var = m.m.buf.nx
end
else
m.var = o2String(m'.BUF.'nx)
return 1
endProcedure jBufRead
jBufRun: procedure expose m.
parse arg oRun
return oNew('JBufRun', oRun) /* calls jBufRunReset */
endProcedure jBufRun
jBufRunReset: procedure expose m.
parse arg m, m.m.runner
return m
endProcedure jBufRunReset
jBufRunOpen: procedure expose m.
parse arg m, opt
call jBufOpen m, m.j.cWri /* to avoid recursive loop in push| */
call pipeBeLa m.j.cWri m
call oRun m.m.runner
li = m.m.buf.0
call pipeEnd
call jBufOpen jClose(m), opt
m.m.buf.0 = li
return m
endProcedure jBufRunOpen
/* copy j end *********************************************************/
/* copy o begin ******************************************************
an object has a class which describes fields and methods
an object has fields (e.g. m.o.fld1)
an object may call it's methods (dynamic binding)
***********************************************************************/
oIni: procedure expose m.
if m.o.ini = 1 then
return
m.o.ini = 1
call classIni
call oClassAdded m.class.classV
call mRegister 'Class', 'call oClassAdded arg'
call classNew 'n ORun u',
, 'm oRun call err "call of abstract method oRun"',
, 'm o2File return JBufRun(m)',
, 'm o2String return jCatLines(JBufRun(m), " ")'
return
endProcedure oIni
/*--- when notified about a new class cl, build the redundancies ----*/
oClassAdded: procedure expose m.
parse arg cl
m.class.o2c.cl = m.class.class
m.cl.oAdr = 'O.'substr(cl, 7) /* object adresses */
m.cl.oCnt = 0
new = 'new'
m.cl.oMet.new = ''
call oAddMethod cl'.OMET', cl
call oAddFields mCut(cl'.FLDS', 0), cl
co = '' /* build code for copy */
do fx=1 to m.cl.flds.0
nm = m.cl.flds.fx
if translate(nm) == nm & \ abbrev(nm, 'GG') ,
& pos('.M.', nm'.') < 1 & pos('.T.', nm'.') < 1 then
co = co'm.t'nm '= m.m'nm';'
else
co = co 'f='quote(substr(nm, 2))';m.t.f = m.m.f;'
end
p = cl'.OMET.oCopy'
if symbol('m.p') \== VAR then
m.p = co
return
endProcedure oClassAdded
/*--- add the methods of class cl to the methodtable mt -------------*/
oAddMethod: procedure expose m.
parse arg mt, cl
if pos(m.cl, 'frsv') > 0 then
return
if m.cl = 'm' then do
nm = m.cl.name
m.mt.nm = m.cl.met
return
end
if m.cl.class \== '' then
call oAddMethod mt, m.cl.class
if m.cl.0 \== '' then
do x=1 to m.cl.0
call oAddMethod mt, m.cl.x
end
return
endProcedure oAddMethod
/*--- add the the fields of class cl to stem f ----------------------*/
oAddFields: procedure expose m.
parse arg f, cl, nm
if pos(m.cl, 'rv') > 0 then do
do fx=1 to m.f.0
if m.f.fx == nm then
return 0
end
if nm == '' then do
call mMove f, 1, 2
m.f.1 = ''
end
else do
call mAdd f, nm
end
return 0
end
if m.cl = 'f' then
return oAddFields(f, m.cl.class, nm'.'m.cl.name)
if m.cl.class \== '' then
return oAddFields(f, m.cl.class, nm)
if m.cl.0 = '' then
return 0
do tx=1 to m.cl.0
call oAddFields f, m.cl.tx, nm
end
return 0
endProcedure oAddFields
/*--- create an an object of the class className --------------------*/
oBasicNew: procedure expose m.
parse arg className
cl = class4Name(className)
m.cl.oCnt = m.cl.oCnt + 1
m = m.cl.oAdr'.'m.cl.oCnt
m.class.o2c.m = cl
return m
endProcedure oBasicNew
/*--- create an an object of the class className
and call it's new method ------------------------------------*/
oNew: procedure expose m.
parse arg className, arg, arg2, arg3
m = oBasicNew(className)
interpret classMet(className, 'new')
return m
endProcedure oNew
/*--- return the class of object obj --------------------------------*/
objClass: procedure expose m.
parse arg obj
if symbol('m.class.o2c.obj') == 'VAR' then
return m.class.o2c.obj
if abbrev(obj, m.class.escW) then
return m.class.classW
if abbrev(obj, 'CLASS.CAST.') then
return substr(obj, 12, pos(':', obj, 12)-12)
if arg() >= 2 then
return arg(2)
return err('objClass no class found for object' obj)
endProcedure objClass
oKindOf: procedure expose m.
parse arg obj, sup
cl = objClass(obj, '')
if cl == '' then
return 0
return classInheritsOf(cl, class4name(sup))
endProcedure oKindOf
classInheritsOf: procedure expose m.
parse arg cl, sup /* wkTst optimierung in classAdded */
if cl == sup then
return 1
do until m.cl = 'u'
if m.cl.class == '' then
return 0
cl = m.cl.class
end
do cx=1 to m.cl.0
d = m.cl.cx
if m.d == 'n' then
if classInheritsOf(d, sup) then
return 1
end
return 0
endProcedure classInheritsOf
classSetMet: procedure expose m.
parse arg na, me, code
if symbol('m.class.n2c.na') \== 'VAR' then
call err 'no class' na 'in classMet('na',' me')'
cl = m.class.n2c.na
if symbol('m.cl.oMet.me') \== 'VAR' then
call err 'no method in classMet('na',' me')'
m.cl.oMet.me = code
return cl
endProcedure classSetMet
/*--- return the code of method me of the class with name na --------*/
classMet: procedure expose m.
parse arg na, me
if symbol('m.class.n2c.na') \== 'VAR' then
call err 'no class' na 'in classMet('na',' me')'
cl = m.class.n2c.na
if symbol('m.cl.oMet.me') \== 'VAR' then
call err 'no method in classMet('na',' me')'
return m.cl.oMet.me
endProcedure classMethod
/*--- set m, ggClass, ggCode to the address, class and code
of method me of object m ------------------------------------*/
objMetClaM: procedure expose m. m ggClass ggCode
parse arg m, me
if symbol('m.class.o2c.m') == 'VAR' then
ggClass = m.class.o2c.m
else if abbrev(m, 'CLASS.CAST.') then
parse var m 'CLASS.CAST.' ggClass ':' m
else
return err('no class found for object' m)
if symbol('m.ggClass.oMet.me') == 'VAR' then
ggCode = m.ggClass.oMet.me
else
call err 'no method' me 'in class' className(ggClass),
'of object' m
return
endProcedure objMetClaM
/*--- return the code of method me of object obj --------------------*/
objMet: procedure expose m.
parse arg obj, me
/* handle the easy and frequent case directly */
if symbol('m.class.o2c.obj') == 'VAR' then
c = m.class.o2c.obj
else if abbrev(obj, m.class.escW) then
c = m.class.classW
else do
call objMetClaM obj, me
return 'M="'m'";'ggCode
end
if symbol('m.c.oMet.me') == 'VAR' then
return m.c.oMet.me
return err('no method' me 'in class' className(c) 'of object' obj)
endProcedure objMet
/*--- return the stem of fieldnames of object m ---------------------*/
oFlds: procedure expose m.
parse arg m
return objClass(m)'.FLDS'
endProcedure oFlds
/*--- mutate object m to the class named name -----------------------*/
oMutate: procedure expose m.
parse arg m, name
m.class.o2c.m = class4Name(name)
return m
endProcedure oMutate
/*--- return object obj cast'd to class named cl --------------------*/
oCast: procedure expose m.
parse arg obj, cl
if abbrev(obj, 'CLASS.CAST.') then
obj = substr(obj, 1 + pos(':', obj, 12))
return 'CLASS.CAST.'class4Name(cl)':'obj
endProcedure oCast
/*--- copy object m of class c to t ---------------------------------*/
oClaCopy: procedure expose m.
parse arg ggCla, m, t
if ggCla == m.class.classW then do
m.t = o2String(m)
m.class.o2c.t = m.class.classV
return t
end
ggCode = ggCla'.OMET.oCopy'
interpret m.ggCode
m.class.o2c.t = ggCla
return t
endProcedure oClaCopy
/*--- copy object m to t --------------------------------------------*/
oCopy: procedure expose m.
parse arg m, t
return oClaCopy(objClass(m), m, t)
endProcedure oCopy
/*--- copy object to a newly created object -------------------------*/
oCopyNew: procedure expose m.
parse arg m
if symbol('m.o.o2c.m') == 'VAR' then
return oCopy(m, oBasicNew(m.o.o2c.m))
return oCopy(m, oBasicNew(m.class.classV))
endProcedure oCopyNew
/*--- return a new instance of a subclass of Run
with code code in method oRun -------------------------------*/
oRunner: procedure expose m.
parse arg code
r = oNew(classNew('n ORun* u', '\', 'ORun' ,
, 'm oRun call err "undefined method oRun in oRun"'))
if arg() > 0 then
call oRunnerCode r, arg(1)
return r
endProcedure oRunner
/*--- set code for runner -------------------------------------------*/
oRunnerCode: procedure expose m.
parse arg r, code
call classSetMet objClass(r), 'oRun', code
return r
endProcedure oRunnerCode
/*--- run method oRun of object m -----------------------------------*/
oRun: procedure expose m.
parse arg m, arg, arg2, arg3
interpret objMet(m, 'oRun')
return
endProcedure oRun
/*--- cast the object to a file -------------------------------------*/
o2File: procedure expose m.
parse arg m
interpret objMet(m, 'o2File')
call err 'o2file did not return'
endProcedure o2File
/*--- cast the object to a String -----------------------------------*/
o2String: procedure expose m.
parse arg m, arg, arg2, arg3
interpret objMet(m, 'o2String')
call err 'o2String did not return'
endProcedure o2String
/*--- cast a String to an object -----------------------------------*/
s2o: procedure expose m.
parse arg str
return m.class.escW || str
return r
endProcedure s2o
/*--- cast a String to an object or Null ---------------------------*/
s2oNull: procedure expose m.
parse arg str
if str == '' then
return ''
return m.class.escW || str
endProcedure s2oNull
/* copy o end *******************************************************/
/* copy class begin **************************************************
a class has fields and methods,
the class module handles only the metadata,
object handling (instanciation, methodcalls etc.)
is done in O, which, hower, extends the class definitions
meta
c choice name class
f field name class
m method name met
n name name class
r reference class
s stem class
u union stem
v string (value)
class expression (ce) allow the following syntax
ce = name | 'v' # value contains a string
| 'w' # string reference =m.class.escW||string
| 'o' # object: dynamic class lookup
| 'r' ce? # reference instance of ce default 'o'
| ('n' # names ce
| 'f' # field
| 'c') name ce # choice if value=name
| 's' ce # stem
| 'm' name code # method
| 'u' (ce (',' ce)*)? # union
# 'm' and 'u' extend to the end of whole ce
***********************************************************************/
classIni: procedure expose m.
if m.class.ini == 1 then
return
m.class.ini = 1
call mapIni
/* to notify other modules (e.g. O) on every new named class */
call mRegisterSubject 'Class',
, 'call classAddedListener subject, listener'
m.class.0 = 0
m.class.tmp.0 = 0
call mapReset 'CLASS.N2C' /* name to class */
/* meta meta data: description of the class datatypes */
m.class.classV = classNew('n v u v', 'm o2String return m.m',
, 'm o2File return file(m.m)')
m.class.escW = '!'
m.class.classW = classNew('n w u v',
, 'm o2String return substr(m, 2)',
, 'm o2File return file(substr(m, 2))')
m.class.classO = classNew('o')
m.class.classR = classNew('r')
m.class.class = classNew('n class u', '\')
call classNew 'class',
, 'c v v' ,
, 'c w w' ,
, 'c o o' ,
, 'c r f CLASS r class' ,
, 'c s f CLASS r class' ,
, 'c u s r class',
, 'c f' classNew('u f NAME v, f CLASS r class'),
, 'c n' classNew('u f NAME v, f CLASS r class'),
, 'c c' classNew('u f NAME v, f CLASS r class'),
, 'c m' classNew('u f NAME v, f MET v')
return
endProcedure classIni
/*--- to notify a new listener about already defined classes --------*/
classAddedListener: procedure expose m.
parse arg subject, listener
do y = 1 to m.class.0
if m.class.y == 'n' then
call mNotify1 'Class', listener, 'CLASS.'y
end
return
endProcedure classAddedListener
/*--- return the name of a class if it exists otherwise the class ---*/
className: procedure expose m.
parse arg cl
if m.cl = 'n' then
return m.cl.name
else
return cl
endProcedure class4Name
/*--- return class of given name or class ---------------------------*/
class4Name: procedure expose m.
parse arg nm
if symbol('m.class.n2c.nm') == 'VAR' then
return m.class.n2c.nm
if arg() > 1 then
return arg(2)
call err 'no class' nm
endProcedure class4Name
/*--- get or create a class from the given class expression
arg(2) may contain options
'\' do not search for existing class
'+' do not finish class
type (1 char) type of following args
the remaining args are type expressions and will
be added to the first union -----------------------------*/
classNew: procedure expose m.
parse arg clEx
if arg() <= 1 then
if mapHasKey(class.n2c, clEx) then
return mapGet(class.n2c, clEx)
oldTmp = m.class.tmp.0
ox = verify(arg(2), '\+')
if ox < 1 then
ox = length(arg(2)) + 1
opts = left(arg(2), ox-1)
pr = substr(arg(2), ox, (length(arg(2)) = ox) * 2)
t = classNewTmp(clEx)
if arg() > 1 then do
u = t
do while m.u \== 'u'
if m.u.class == '' then
call err 'no union found' clEx
u = m.u.class
end
do ax = 2 + (opts \== '' | pr \== '') to arg()
call mAdd u, classNew(pr || arg(ax))
end
end
srch = pos('\', opts) < 1
p = classPermanent(t, srch)
if arg() <= 1 then
call mapAdd class.n2c, clEx, p
if \srch & p \== t & pos('+', opts) < 1 then
call mNotify 'Class', p
m.class.tmp.0 = oldTmp
return p
endProcedure classNew
/*--- create a temporary class
with type ty, name nm and class expression ce ---------------*/
classNewTmp: procedure expose m.
parse arg ty nm ce
if length(ty) > 1 then do
if nm \== '' then
call err 'class' ty 'should stand alone:' ty nm ce
return class4Name(ty)
end
t = mAdd(class.tmp, ty)
m.t.name = ''
m.t.class = ''
m.t.met = ''
m.t.0 = ''
if pos(ty, 'vwo') > 0 then do
if nm \== '' then
call err 'basicClass' ty 'end of Exp expected:' ty nm ce
end
else if ty = 'u' then do
fx = 0
m.t.0 = 0
ce = nm ce
ux = 0
do until fx = 0
tx = pos(',', ce, fx+1)
if tx > fx then
sub = strip(substr(ce, fx+1, tx-fx-1))
else
sub = strip(substr(ce, fx+1))
if sub \== '' then do
ux = ux + 1
m.t.ux = classNewTmp(sub)
end
fx = tx
end
m.t.0 = ux
end
else if nm == '' & ty \== 'r' then do
call err 'basicClass' ty 'name or class Exp expected:' ty nm ce
end
else do
if pos(ty, 'sr') > 0 then do
if nm == '' then
nm = 'o'
m.t.class = classNewTmp(nm ce)
end
else do
if pos(ty, 'cfmn') < 1 then
call err 'unsupported basicClass' ty 'in' ty nm ce
m.t.name = nm
if ty = 'm' then
m.t.met = ce
else if ce = '' then
call err 'basicClass' ty 'class Exp expected:' ty nm ce
else
m.t.class = classNewTmp(ce)
end
end
return t
endProcedure classNewTmp
/*--- return the permanent class for the given temporary class
an existing one if possible otherwise a newly created -------*/
classPermanent: procedure expose m.
parse arg t, srch
if \ abbrev(t, 'CLASS.TMP.') then
return t
if m.t.class \== '' then
m.t.class = classPermanent(m.t.class, srch)
if m.t.0 \== '' then do
do tx=1 to m.t.0
m.t.tx = classPermanent(m.t.tx, srch)
end
end
/* search equal permanent class */
do vx=1 to m.class.0 * srch
p = class'.'vx
if m.p.search then
if classEqual(t, p, 1) then
return p
end
p = mAdd(class, m.t)
m.p.name = m.t.name
m.p.class = m.t.class
m.p.met = m.t.met
m.p.search = srch
if m.t.0 > 0 then
call mAddSt mCut(p, 0), t
else
m.p.0 = m.t.0
if mapHasKey(class.n2c, p) then
call err 'class' p 'already defined as className'
else
call mapAdd class.n2c, p, p
if m.p = 'n' then do
if right(m.p.name, 1) == '*' then
m.p.name = left(m.p.name, length(m.p.name)-1) ,
|| substr(p, length('class.x'))
if mapHasKey(class.n2c, m.p.name) then
call err 'class' m.p.name 'already defined'
else
call mapAdd class.n2c, m.p.name, p
if srch then
call mNotify 'Class', p
end
return p
endProcedure classPermanent
/*--- return true iff the two classes are equal
(up to the name pattern if lPat == 1) -----------------------*/
classEqual: procedure expose m.
parse arg l, r, lPat
if m.l \== m.r | m.l.class \== m.r.class | m.l.0 \= m.r.0,
| m.l.met \== m.r.met then
return 0
if m.l.name \== m.r.name then
if lPat \== 1 | right(m.l.name, 1) \== '*' ,
| \ abbrev(m.r.name,
, left(m.l.name, length(m.l.name)-1)) then
return 0
if m.l.0 == '' then
return 1
do sx=1 to m.l.0
if m.l.sx \== m.r.sx then
return 0
end
return 1
endProcedure classEqual
/*--- print object ---------------------------------------------------*/
objOut: procedure expose m.
parse arg m, pr, p1
c = objClass(m, '')
if c == '' then
call out p1 'no class for' m
else if c == m.class.classV then
call out p1 || m.m
else if c == m.class.classW then
call out p1 || o2String(m)
else
call classOutDone c, m, pr, p1
return
endProcedure objOut
/*--- recursively ouput (with out:) the object a with class t -------*/
classOut: procedure expose m.
parse arg t, a, pr, p1
return classOutDone(if(t=='',m.class.classO, t), a, pr, p1)
endProcedure classOut
/*--- ouput object a with class t and stopper done ------------------*/
classOutDone: procedure expose m. done.
parse arg t, a, pr, p1
if p1 == '' then
p1 = pr
if right(p1, 1) \== ' ' then
p1 = p1' '
if done.ini \== 1 then do
done.ini = 1
t = class4Name(t, t)
p1 = p1'@'a' '
end
if done.t.a == 1 then
return out(p1'done :'className(t) '@'a)
done.t.a = 1
if m.t = 'o' then do
t = objClass(a, '')
if t = '' then
return out(p1'obj has no class @'m.a)
else
return classOutDone(t, a, pr, p1'isA')
end
if m.t == 'v' then
return out(p1'=' m.a)
if m.t == 'w' then
return out(p1'}' substr(a, 2))
if m.t == 'n' then
return classOutDone(m.t.class, a, pr, p1':'m.t.name)
if m.t == 'f' then
return classOutDone(m.t.class, a'.'m.t.name, pr, p1'.'m.t.name)
if m.t == 'r' then do
if m.a == '' then
call out p1'refTo :'className(m.t.class) '@null@'
else
return classOutDone(m.t.class, m.a, pr,
, p1'refTo @'m.a)
end
if m.t = 'u' then do
t1 = m.t.1
vv = m.t.0 > 0 & m.t1 == 'v'
call out p1'union' || copies(' =' m.a, vv)
do ux=1+vv to m.t.0
call classOutDone m.t.ux, a, pr' '
end
return 0
end
if m.t = 's' then do
call out p1'stem' m.a.0
do ux=1 to m.a.0
call classOutDone m.t.class, a'.'ux, pr' ', pr' .'ux
end
return 0
end
if m.t = 'c' then do
if m.t.name = m.a then
call classOutDone m.t.class, a, pr, p1'choice' m.a
return 0
end
if m.t = 'm' then
return 0
return err('bad class type' m.t)
endProcedure classOutDone
/* copy class end ***************************************************/
/* copy mapExp begin **************************************************/
mapVia: procedure expose m.
parse arg a, ky
sx = pos('|', ky)
if sx < 1 then
return mapGet(a, ky)
via = mapGet(a, left(ky, sx-1))
do while sx <= length(ky)
fx = sx+1
sx = pos('|', ky, fx)
if sx < 1 then
sx = length(ky) + 1
if sx = fx then do
if symbol('m.via') \== 'VAR' then
call err 'missing m.'via 'at' sx 'in mapVia('a',' ky')'
via = m.via
end
else do
f = substr(ky, fx, sx - fx)
if symbol('m.via.f') \== 'VAR' then
call err 'missing m.'via'.'f ,
'at' sx 'in mapVia('a',' ky')'
via = m.via.f
end
end
return via
endProcedure mapVia
mapExpAt: procedure expose m.
parse arg a, src, sx
m.map.ExpAt = 0
cx = pos('$', src, sx)
if cx < 1 then
return substr(src, sx)
res = substr(src, sx, cx-sx)
do forever
if substr(src, cx+1, 1) = '{' then do
ex = pos('}', src, cx+2)
if ex < 1 then
call err 'missing } after' substr(src, cx) 'in' src
res = res || mapVia(a, strip(substr(src, cx+2, ex-cx-2)))
ex = ex + 1
end
else do
ex = verify(src, m.mAlfDot, 'n', cx+1)
if ex < 1 then
return res || mapVia(a, substr(src, cx+1))
if ex = cx+1 then do
m.map.ExpAt = cx
return res
end
res = res || mapVia(a, substr(src, cx+1, ex-cx-1))
end
cx = pos('$', src, ex)
if cx < 1 then
return res || substr(src, ex)
res = res || substr(src, ex, cx-ex)
end
endProcedure mapExpAt
mapExp: procedure expose m.
parse arg a, src
res = mapExpAt(a, src, 1)
if m.map.ExpAt \== 0 then
call err 'mapExp stopped at' substr(src, map.ExpAt) 'in' src
return res
endProcedure mapExp
mapExpAllAt: procedure expose m.
parse arg a, dst, src, sx, cx
do while sx <= m.src.0
li = mapExpAt(a, m.src.sx, cx)
dx = m.map.ExpAt
if (cx=1 & dx = 0) | li \= '' then
call mAdd dst, li
if dx = 0 then do
cx = 1
sx = sx+1
end
else do
return sx dx
end
end
return ''
endProcedure mapExpAllAt
mapExpAll: procedure expose m.
parse arg a, dst, src
sto = mapExpAllAt(a, dst, src, 1, 1)
if sto == '' then
return
lx = word(sto, 1)
call err 'mapExpAll stopped at' sto':' m.src.lx
endProcedure mapExpAll
/* copy mapExp end ****************************************************/
/* copy map begin ******************************************************
a map stores values at keys
it may also maintain a list of keys
the basic ideas are similar to the java Interface java.util.Map
contrary to stems we also handle keys longer then 250 bytes
***********************************************************************/
/*--- initialize the module ------------------------------------------*/
mapIni: procedure expose m.
if m.map.ini = 1 then
return
m.map.ini = 1
call mIni
m.map.0 = 0
m.map.inlineSearch = 1
return
endProcedure mapIni
mapInline: procedure expose m.
parse arg pName
if mapHasKey(map.inlineName, pName) then
return mapGet(map.inlineName, pName)
if m.map.inlineSearch == 1 then
call mapReset map.inlineName, map.inline
inData = 0
name = ''
do lx=m.map.inlineSearch to sourceline()
if inData then do
if abbrev(sourceline(lx), stop) then do
inData = 0
if pName = name then
leave
end
else do
call mAdd act, strip(sourceline(lx), 't')
end
end
else if abbrev(sourceline(lx), '/*<<') then do
parse value sourceline(lx) with '/*<<' name '<<' stop
name = strip(name)
stop = strip(stop)
if stop == '' then
stop = name
if words(stop) <> 1 | words(name) <> 1 then
call err 'bad inline data' strip(sourceline(lx))
if mapHasKey(map.inline, name) then
call err 'duplicate inline data name' name ,
'line' lx strip(sourceline(lx), 't')
act = mapAdd(map.inlineName, name,
, mCut('MAP.INLINE.' || (m.map.inline.0 + 1), 0))
inData = 1
end
end
if inData then
call err 'inline Data' name 'at' m.map.inlineSearch,
'has no end before eof'
m.map.inlineSearch = lx + 1
if name = pName then
return act
if arg() > 1 then
return arg(2)
call err 'no inline data named' pName
endProcedure mapInline
/*--- create a new map ----------------------------------------------*/
mapNew: procedure expose m.
parse arg opt
return mapReset('MAP.'mInc('MAP.0') , opt)
endProcedure mapNew
/*--- make an empty map, if opt <> '' maintain stem of keys
('K' in map.keys, '=' in a else in opt) --------------*/
mapReset: procedure expose m.
parse arg a, opt
if symbol('m.map.keys.a') == 'VAR' then
call mapClear a
if opt = '=' then
st = a
else if translate(opt) = 'K' then
st = 'MAP.KEYS.'a
else
st = opt
m.map.keys.a = st
if st \== '' then
m.st.0 = 0
return a
endProcedure
/*--- add a new key value pair to the map ----------------------------*/
mapAdd: procedure expose m.
parse arg a, ky, val
vv = mapValAdr(a, ky, 'a')
m.vv = val
return val
endProcedure mapAdd
/*--- change the value at a key or add key value ---------------------*/
mapPut: procedure expose m.
parse arg a, ky, val
vv = mapValAdr(a, ky, 'p')
m.vv = val
return val
endProcedure mapPut
/*--- return 1 if key ky exists in map a, 0 otherwise ----------------*/
mapHasKey: procedure expose m.
parse arg a, ky
return mapValAdr(a, ky) \== ''
endProcedure mapHasKey
/*--- return the value of key ky in map a if it exists,
else if called with a third argument return third argument
else issue an error ----------------------------------------*/
mapGet: procedure expose m.
parse arg a, ky
vv = mapValAdr(a, ky)
if vv \== '' then
return m.vv
else if arg() > 2 then
return arg(3)
else
call err 'missing key in mapGet('a',' ky')'
endProcedure mapGet
/*--- return a stem of all keys --------------------------------------*/
mapKeys: procedure expose m.
parse arg a
if m.map.keys.a == '' then
call err 'mapKeys('a') with no keys'
return m.map.keys.a
endProcedure mapKeys
/*--- remove a key from the map, do nothing if it is missing ---------*/
mapRemove: procedure expose m.
parse arg a, ky
vv = mapValAdr(a, ky)
if vv == '' then
return ''
if m.map.keys.a \== '' then do
trace ?R /* not tested yet ???wkTest */
k = m.map.keys.a
mx = m.k.0
do i=1 to mx
if m.k.i == ky then do
m.k.i = m.k.mx
m.k.0 = mx - 1
return
end
end
end
val = m.vv
drop m.a.ky
return val
endProcedure mapRemove
/*--- remove all entries ---------------------------------------------*/
mapClear: procedure expose m.
parse arg a
st = mapKeys(a)
liLe = 243 - length(a)
do kx=1 to m.st.0
ky = m.st.kx
drop m.st.kx
if length(ky) <= liLe then do
drop m.a.ky
end
else do
adr = mapValAdr(a, ky)
if adr \== '' then do
ha = left(adr, lastPos('.', adr) - 3)
do i = 1 to m.ha.k.0
drop m.ha.k.i m.ha.v.i
end
drop m.ha.k.0
end
end
end
m.st.0 = 0
return a
endProcedure mapClear
/*--- return the value pointer for a key, '' if non existing
with fun = 'a' add a key, with 'p' put a key ------------*/
mapValAdr: procedure expose m.
parse arg a, ky, fun
if length(ky) + length(a) <= 243 then do
res = a'.'ky
if symbol('m.res') == 'VAR' then do
if fun == 'a' then
call err 'duplicate key' ky 'in map' a
return res
end
else if fun == '' then
return ''
end
else do
len = 243 - length(a)
q = len % 4
ha = a'.'left(ky, len - 2 * q) || substr(ky,
, (length(ky)-len) % 2 + 2 * q, q) || right(ky, q)
if symbol('M.ha.k.0') == 'VAR' then do
do i=1 to m.ha.k.0
if m.ha.k.i == ky then do
if fun == 'a' then
call err 'duplicate key' ky ,
'map' a 'hash' ha'.K.'i
return ha'.V.'i
end
end
end
else do
i = 1
end
if fun == '' then
return ''
if i > 9 then
call err 'overflow long key' y 'in map' a 'hash' ha'.K.'i
m.ha.k.0 = i
m.ha.k.i = ky
res = ha'.V.'i
end
opt = left('K', m.map.keys.a \== '')
if opt == 'K' then
call mAdd m.map.Keys.a, ky
return res
endProcedure mapValAdr
/* copy map end *******************************************************/
/* copy m begin ********************************************************
we use variables as follows
m. stem m: all global data and object data that must survive
a procedure call (m for memory in Memoria of B5000)
m.<mbr>.** to avoid conflicts: every rexx Module (copy) should
only allocate addresses m.<mbr>.** with <mbr> the name of
the rexx module
we pass parameters around (e.g. a=address, m=memory, st=stem)
and the called function may use m.a or m.a.subField etc.
gg*: local variable in subroutines without procedure
everything else: temporary data within procedure
every subroutine is declared as procedure expose m.
(also if no m. variable is used, because e.g. of error handling)
the few subroutines that cannot use procedure, should use only
variables starting with gg
***********************************************************************/
/*--- increase m.a and return it (fail if undefined) -----------------*/
mInc: procedure expose m.
parse arg a
m.a = m.a + 1
return m.a
endProcedure mInc
/*--- cut stem a to length len ---------------------------------------*/
mCut: procedure expose m.
parse arg a, len
m.a.0 = len
return a
endProcedure mCut
/*--- add one or several arguments to stem m.a -----------------------*/
mAdd: procedure expose m.
parse arg a
ix = m.a.0
do ax = 2 to arg()
ix = ix + 1
m.a.ix = arg(ax)
end
m.a.0 = ix
return a'.'ix
endProcedure mAdd
/*--- pop last element from stem m.a ---------------------------------*/
mPop: procedure expose m.
parse arg a
ix = m.a.0
if ix < 1 then
call err 'pop from empty stem' a
m.a.0 = ix-1
return m.a.ix
endProcedure mPop
/*--- add to m.dst.* a (sub)sequence of m.src.* ----------------------*/
mAddSt: procedure expose m.
parse arg dst, src
dx = m.dst.0
do sx = 1 to m.src.0
dx = dx + 1
m.dst.dx = m.src.sx
end
m.dst.0 = dx
return
endProcedure mAddSt
/*--- move a part of a stem ------------------------------------------*/
mMove: procedure expose m.
parse arg m, sx, dx
if dx < sx then do
y = dx
do x=sx to m.m.0
m.m.y = m.m.x
y = y + 1
end
end
else if dx > sx then do
y = m.m.0 + dx - sx
do x=m.m.0 by -1 to sx
m.m.y = m.m.x
y = y - 1
end
end
m.m.0 = m.m.0 + dx - sx
return
endProcedure mMove
/*--- strip all elements of a stem -----------------------------------*/
mStrip: procedure expose m.
parse arg st, opt
if opt == '' then
opt = 'b'
do x=1 to m.st.0
m.st.x = strip(m.st.x, opt)
end
return st
endProcedure mStrip
/*--- cat all elements of a stem together ----------------------------*/
mCat: procedure expose m.
parse arg st, mid
if m.st.0 < 1 then
return ''
res = m.st.1
do x=2 to m.st.0
res = res || mid || m.st.x
end
return res
endProcedure mCat
/*--- notify all listeners of subject subj with argument arg --------*/
mNotify: procedure expose m.
parse arg subj, arg
if symbol('m.m.subLis.subj') \== 'VAR' then
call err 'subject' subj 'not registered'
do lx=1 to m.m.subLis.subj.0
call mNotify1 subj, lx, arg
end
return
endProcedure mNotify
/*--- notify the listener listener of subject subj with arg ---------*/
mNotify1: procedure expose m.
parse arg subject, listener, arg
interpret m.m.subLis.subject.listener
return
endProcedure mNotify1
/*--- notify subject subject about a newly registered listener
or a new subject about previously registered listener -------*/
mNotifySubject: procedure expose m.
parse arg subject, listener
interpret m.m.subLis.subject
return
endProcedure mNotifySubject
/*--- register a new subject with the code for mNotifySubject -------*/
mRegisterSubject: procedure expose m.
parse arg subj, addListener
if symbol('m.m.subLis.subj') == 'VAR' then
call err 'subject' subj 'already registered'
m.m.subLis.subj = addListener
if symbol('m.m.subLis.subj.0') \== 'VAR' then do
m.m.subLis.subj.0 = 0
end
else do lx=1 to m.m.subLis.subj.0
call mNotifySubject subj, lx
end
return
endProcedure registerSubject
/*--- register a listener to subject subj with the code for mNotify -*/
mRegister: procedure expose m.
parse arg subj, notify
if symbol('m.m.subLis.subj.0') \== 'VAR' then
m.m.subLis.subj.0 = 0
call mAdd 'M.SUBLIS.'subj, notify
if symbol('m.m.subLis.subj') == 'VAR' then
call mNotifySubject subj, m.m.subLis.subj.0
return
endProcedure mRegister
mIni: procedure expose m.
if m.m.ini = 1 then
return
m.m.ini = 1
m.mAlfLC = 'abcdefghijklmnopqrstuvwxyz'
m.mAlfUC = translate(m.mAlfLC)
m.mAlfa = m.mAlfLC || m.mAlfUC
m.mAlfNum = m.mAlfa || '0123456789'
m.mAlfDot = m.mAlfNum || '.'
return
endProcedure mIni
/* copy m end *********************************************************/
/* copy stringUt begin ***********************************************/
/*--- return the count of occurrences of needle in heyStack ----------*/
posCount: procedure
parse arg needle, hayStack, start, fin
if start = '' then
start = 1
if fin = '' then
fin = length(hayStack) + 1 - length(needle)
do cnt = 0 by 1
start = pos(needle, haystack, start)
if start < 1 | start > fin then
return cnt
start = start + length(needle)
end
endProcedure posCount
repAll: procedure expose m.
parse arg src, w, new
res = ''
cx = 1
do forever
nx = pos(w, src, cx)
if nx < 1 then
return res || substr(src, cx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAll
repAllWords: procedure expose m.
parse arg src, w, new
res = ''
wx = 0
cx = 1
do forever
wx = wordPos(w, src, wx+1)
if wx < 1 then
return res || substr(src, cx)
nx = wordindex(src, wx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAllWords
/* copy stringUt end ***********************************************/
/* copy err begin ******************************************************
messages, errorhandling,help
***********************************************************************/
errIni: procedure expose m.
if m.err.ini == 1 then
return
call outIni
m.err.ini = 1
m.err.handler = ''
m.err.cleanup = ';'
m.err.opt = ''
return
endProcedure errIni
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err.opt, m.err.handler
if pos('I', translate(m.err.opt)) > 0 then
if sysVar('sysISPF') = 'ACTIVE' then
call adrIsp 'control errors return'
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
call errIni
drop err handler cleanup opt call return
if ggOpt == '' & m.err.handler \== '' then do
if 1 then do /* no detection of recursive err call loop
--> will anyway fail by stack overflow */
interpret m.err.handler
end
else do
/* avoid recursive err call loop */
drop call return
if symbol('m.err.call') \== 'VAR' then
m.err.call = 1
else
m.err.call = m.err.call + 1
if m.err.call > 10 then do
say 'errHandler loop:' m.err.handler
end
else do
m.err.return = 1
call errInterpret m.err.handler
m.err.call = m.err.call - 1
if m.err.return then
return result
end
end
end
call outPush
call errSay ggTxt, 'e'
call errCleanup
if ggOpt == '' then
ggOpt = m.err.opt
ggOpt = translate(ggOpt)
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 then do
call errSay 'divide by zero to show stackHistory', 'e'
x = 1 / 0
end
call errSay 'exit(12)', 'e'
exit errSetRc(12)
endSubroutine err
errAddCleanup: procedure expose m.
parse arg code
if m.err.ini \== 1 then
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
if m.err.ini \== 1 then
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
cl = m.err.cleanup
if cl = ';' then
return
m.err.cleanup = ';'
call out 'err cleanup begin' cl
call errInterpret cl
call out 'err cleanup end' cl
return
endProcedure errCleanup
errInterpret: procedure expose m.
parse arg code
interpret code
m.err.return = 0
return
endProcedure errInterpret
/*--- assert that the passed rexx expression evaluates to true -------*/
assert:
interpret 'assertRes =' arg(1)
if \ assertRes then
call err 'assert failed' arg(1)':' arg(2)
return
endProcedure assert
/*--- output an errorMessage msg with pref pref
split message in lines at '/n' ---------------------------*/
errSay: procedure expose m.
parse arg msg, pref
parse source . . ggS3 . /* current rexx */
if pref == 'e' then
msg = 'fatal error in' ggS3':' msg
else if pref == 'w' then
msg = 'warning in' ggS3':' msg
else if pref \== '' then
msg = pref':' msg
return outNl(msg)
endProcedure errSay
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg, op
call errSay msg, 'e'
call help
call err msg, op
endProcedure errHelp
/*--- return the Operating System we are running on: TSO or LINUX ---*/
errOS: procedure expose m.
parse source os .
return os
endProcedure errOS
/*--- set rc for ispf: -------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared varible 3IspfRc
back as return code
----------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- output a trace message if m.tr is set -----------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
call out 'debug' msg
return
endProcedure debug
/*--- return current time and cpu usage ------------------------------*/
timing: procedure expose m.
return return time() 'ela='time('E') 'cpu='sysvar('syscpu'),
'su='sysvar('syssrv')
timingTest: procedure expose m.
say 'begin' timing() sysvar('sysnode')
do 30000000
end
say 'end ' timing()
return
/*--- display the first comment block of the source as help ----------*/
help: procedure expose m.
parse source . . s3 .
call out right(' help for rexx' s3, 79, '*')
do lx=1 by 1
if pos('/*', sourceLine(lx)) > 0 then
leave
else if lx > 10 then do
call out '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
call out li
end
call out right(' end help for rexx' s3, 79, '*')
return 4
endProcedure help
/*--- output all lines (separated by '\n') of all args --------------*/
outNl: procedure expose m.
do ax=1 to max(1, arg())
msg = arg(ax)
sx = 0
bx = -1
do lx=1 until bx >= length(msg)
ex = pos('\n', msg, bx+2)
if ex < 1 then
ex = length(msg)+1
call out substr(msg, bx+2, ex-bx-2)
bx = ex
end
end
return 0
endProcedure outNl
/*--- 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
/*--- if function ----------------------------------------------------*/
if: procedure expose m.
parse arg co, ifTrue, ifFalse
if co then
return ifTrue
else
return ifFalse
endProcedure if
/* copy err end *****************************************************/
}¢--- A540769.WK.REXX(QZT071) cre=2016-01-07 mod=2016-01-07-17.29.50 A540769 ---
$#=
$*( --- for test with wsh -------------
$>. fEdit()
$=rz=RR2
$=dbSys=DBOF
$=nowM=- f('%t S')
$=now =- f('%tSs', $nowM)
$=ab=gbGr
$=ablfP=DSN.ABLF.GBGR.$dbSys
$=ablfRz=DSN.ABLF.GBGR.$dbSys.$rz
--- for test with wsh end ------------- $*)
//QZT0710P JOB (CP00,KE50),'DB2 GBGRENZE',
// REGION=0M,TIME=1440,CLASS=M1,SCHENV=DB2ALL,
// MSGCLASS=E
$@¢
if $rz = sysvar(sysnode) then $@¢
$= csm = $''
$= rzAblf = $ablfP
$! else $@¢
$= csm = SUBSYS=(CSM,'SYSTEM=$rz'),
$= rzAblf = $rz/$ablfP
$!
$=tb=OA1P.TQZ006GBGRTSSTATS
$!
//*
//* db2 gbGrenze ablauf $ab from $rz/$dbSys
//* load into $tb
//* generated by abub skels(QZT071) at $now
//*
//* 7. 1.16 validBegin validEnd ZuerichTime), kein state mehr|
//* updateStatsTime bleibt original
$*( history
5. 1.16 nur noch eine Utility fuer TS bzw. IX
updateStatsTime wird auf ZürichTime übersetzt
origStatsTime enthält originalZeit
19.11.15 rename qzt31L --> qzt071
19. 2.15 load Columns aus Punchfile holen, v11 Kolonnen
12.12.14 elar xb: nur partition die seit 1.12.14 noch wachsen
25. 9.14 rz2/dvbp XB% bis ZS nov14 excluded
$*)
//*********************************************************************
//* --- load table data for $rz/$dbSys
//* --- load raw data into $tb part 1 mit ?/? (default)
//* --- insert active and drops'd rows if changed with $rz/$dbSys
//LOADTS EXEC PGM=DSNUTILB,
// PARM=(DP4G,'QZT0710P.LOAD')
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SQL DD DSN=$ablfRz.SQL,
// DISP=(MOD,DELETE)
//SYSOUT DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//TSSTATS DD DISP=SHR,$csm
// DSN=$ablfP.TSSTATS
//SYSIN DD *
--- load raw data from unload as ?/? into part 1 ---------------------
LOAD DATA LOG NO
WORKDDN(TSYUTS,TSOUTS)
SORTKEYS
SORTDEVT DISK
MAPDDN TMAPD ERRDDN TERRD
STATISTICS INDEX(ALL) REPORT NO UPDATE ALL
INTO TABLE $tb
PART 1 INDDN TSSTATS RESUME NO REPLACE COPYDDN(TCOPYD)
(
$@¢ call loadCols $<$rzAblf.TSPUNCH $!
)
EXEC SQL
--- copy changed tablePart rows to rz/dbSys ---------------------------
insert into $tb
$@ if $rz = 'RR2' then $@=¢
with g2 as
( --- pta: date in future: find highest timestamp
select max(updateStatsTime) statsMax
, timestamp('$nowM') loadTs
$** , count(*) cnt
from $tb
where rz = '?' and dbSys = '?'
)
, g3 as
(
select g2.*
, days(statsMax) - days(loadTs) d1
from g2
)
, g as
( --- calculate days Difference to our date
select g3.*
, case when statsMax <= loadTs then 0
when statsMax - (d1-1) days <= loadTs then d1-1
when statsMax - (d1 ) days <= loadTs then d1
else d1+1 end di
from g3
)
, t2 as
$=comG= , g
$=diDy= - di days
$! $@ else $@=¢
with t2 as
$=comG= $''
$=diDy= $''
$!
( -- select loaded rows and previous timestamps/state
select t.*
, ( select char(a.validBegin)
|| char(a.updateStatsTime)
from $tb a
where a.rz='$rz' and a.dbSys = '$dbSys'
and t.dbName = a.dbName
and t.name = a.name
and t.partition = a.partition
and t.instance = a.instance
order by validBegin desc
fetch first 1 row only
) beSt
from $tb t
where rz = '?' and dbSys = '?'
)
, t as
( --- decode beSt and select only rows with changed updateStatsTime
select t2.*
, timestamp(substr(beSt, 1, 26)) prBeg
from t2
where beSt is null
or timestamp(substr(beSt, 27, 26)) <> updateStatsTime
)
--- select compute all columns to insert
select '$rz' RZ
, '$dbSys' DBSYS
, value(case --- statsTime in our calendar,
--- must be strictly increasing
--- should be <= loadTs
when ( t.updatestatsTime $diDy > prBeg
or prBeg is null )
and t.updatestatsTime $diDy
<= '$nowM'
then t.updatestatsTime $diDy
when '$nowM' <= prBeg
then trunc_timestamp(prBeg, 'mi') + 2 minutes
end, '$nowM') validBegin
, timestamp('9999-12-30-00.00.00') validEnd
, timestamp('$nowM') loadTs
, TSTYPE
, TSTY
, PGSIZE
, SEGSIZE
, PARTS
, MAXPARTS
, DSSIZE
, DSGB
, LIMGB
, LIMPART
, OBID
, CLONE
, TSINST
, TBCR
, TB
, TBTY
, TBOBID
, t.UPDATESTATSTIME
, NACTIVE
, NPAGES
, EXTENTS
, LOADRLASTTIME
, REORGLASTTIME
, REORGINSERTS
, REORGDELETES
, REORGUPDATES
, REORGUNCLUSTINS
, REORGDISORGLOB
, REORGMASSDELETE
, REORGNEARINDREF
, REORGFARINDREF
, STATSLASTTIME
, STATSINSERTS
, STATSDELETES
, STATSUPDATES
, STATSMASSDELETE
, COPYLASTTIME
, COPYUPDATEDPAGES
, COPYCHANGES
, COPYUPDATELRSN
, COPYUPDATETIME
, IBMREQD
, DBID
, PSID
, PARTITION
, INSTANCE
, SPACE
, TOTALROWS
, DATASIZE
, UNCOMPRESSEDDATASIZE
, DBNAME
, NAME
, REORGCLUSTERSENS
, REORGSCANACCESS
, REORGHASHACCESS
, HASHLASTUSED
, DRIVETYPE
, LPFACILITY
, STATS01
, UPDATESIZE
, LASTDATACHANGE
from t $comG
ENDEXEC
EXEC SQL
--- update validEnd of previous rows -----------------------------------
update $tb u
set validEnd =
( select n.validBegin
from $tb n
where u.rz = n.rz and u.dbSys = n.dbSys
and u.dbName = n.dbName and u.name = n.name
and u.partition = n.partition
and u.instance = n.instance
and u.validBegin < n.validBegin
and u.validEnd > n.validBegin
order by n.validBegin asc
fetch first 1 row only
)
where rz = '$rz' and dbSys = '$dbSys'
and validEnd > '9000-01-01-00.00.00'
and exists
( select 1
from $tb n
where u.rz = n.rz and u.dbSys = n.dbSys
and u.dbName = n.dbName and u.name = n.name
and u.partition = n.partition
and u.instance = n.instance
and u.validBegin < n.validBegin
and u.validEnd > n.validBegin
)
ENDEXEC
EXEC SQL
--- update validEnd for rows of dropped tablePartitions ---------------
update $tb u
set validEnd = '$nowM'
where rz = '$rz' and dbSys = '$dbSys'
and validBegin <= '$nowM'
and validEnd > '$nowM'
and not exists
( select 1 from $tb q
where q.rz = '?' and q.dbSys = '?'
and u.dbName = q.dbName and u.name = q.name
and u.partition = q.partition
and u.instance = q.instance
)
ENDEXEC
//***** delete input dsn **********************************************
// IF LOADTS.RUN AND (RC=0 OR RC=4) THEN
//DELTS EXEC PGM=IEFBR14
//DEL DD DISP=(OLD,DELETE),$csm
// DSN=$ablfP.TSSTATS
// ENDIF
// IF LOADTS.RUN AND (RC=0 OR RC=4) THEN
$=tb=OA1P.TQZ007GBGRIXSTATS
//*********************************************************************
//* --- load index data for $rz/$dbSys
//* --- load raw data into $tb part 1 mit ?/? (default)
//* --- insert active and drops'd rows if changed with $rz/$dbSys
//LOADIX EXEC PGM=DSNUTILB,
// PARM=(DP4G,'QZT0710P.LOAD')
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//IXSTATS DD DISP=SHR,$csm
// DSN=$ablfP.IXSTATS
//SYSIN DD *
LOAD DATA LOG NO
WORKDDN(TSYUTS,TSOUTS)
SORTKEYS
SORTDEVT DISK
MAPDDN TMAPD ERRDDN TERRD
STATISTICS INDEX(ALL) REPORT NO UPDATE ALL
INTO TABLE $tb
PART 1 INDDN IXSTATS RESUME NO REPLACE COPYDDN(TCOPYD)
(
$@¢ call loadCols $<$rzAblf.IXPUNCH $!
)
EXEC SQL
--- copy changed indexPart rows to rz/dbSys ---------------------------
insert into $tb
$@ if $rz = 'RR2' then $@=¢
with g2 as
( --- pta: date in future: find highest timestamp
select max(updateStatsTime) statsMax
, timestamp('$nowM') loadTs
$** , count(*) cnt
from $tb
where rz = '?' and dbSys = '?'
)
, g3 as
(
select g2.*
, days(statsMax) - days(loadTs) d1
from g2
)
, g as
( --- calculate days Difference to our date
select g3.*
, case when statsMax <= loadTs then 0
when statsMax - (d1-1) days <= loadTs then d1-1
when statsMax - (d1 ) days <= loadTs then d1
else d1+1 end di
from g3
)
, t2 as
$=comG= , g
$=diDy= - di days
$! $@ else $@=¢
with t2 as
$=comG= $''
$=diDy= $''
$!
( -- select loaded rows and previous timestamps/state
select t.*
, ( select char(a.validBegin)
|| char(a.updateStatsTime)
from $tb a
where a.rz='$rz' and a.dbSys = '$dbSys'
and t.dbName = a.dbName
and t.ts = a.ts
and t.indexSpace= a.indexSpace
and t.partition = a.partition
and t.instance = a.instance
order by validBegin desc
fetch first 1 row only
) beSt
from $tb t
where rz = '?' and dbSys = '?'
)
, t as
( --- decode beSt and select only rows with changed updateStatsTime
select t2.*
, timestamp(substr(beSt, 1, 26)) prBeg
from t2
where beSt is null
or timestamp(substr(beSt, 27, 26)) <> updateStatsTime
)
--- select compute all columns to insert
select '$rz' RZ
, '$dbSys' DBSYS
, value(case --- statsTime in our calendar,
--- must be strictly increasing
--- should be <= loadTs
when ( t.updatestatsTime $diDy > prBeg
or prBeg is null )
and t.updatestatsTime $diDy
<= '$nowM'
then t.updatestatsTime $diDy
when '$nowM' <= prBeg
then trunc_timestamp(prBeg, 'mi') + 2 minutes
end, '$nowM') validBegin
, timestamp('9999-12-30-00.00.00') validEnd
, timestamp('$nowM') loadTs
, INDEXTYPE
, COMPRESS
, IXPARTS
, IXPGSZ
, PIECESIZE
, PIECEGB
, LIMGB
, TBCREATOR
, TBNAME
, TS
, TSTY
, TSPARTS
, TSCLONE
, TSINST
, TSDSSIZE
, TSDSGB
, TSLIMGB
, TSLIMPART
, TSPGSZ
, t.UPDATESTATSTIME
, NLEVELS
, NPAGES
, NLEAF
, NACTIVE
, SPACE
, EXTENTS
, LOADRLASTTIME
, REBUILDLASTTIME
, REORGLASTTIME
, REORGINSERTS
, REORGDELETES
, REORGAPPENDINSERT
, REORGPSEUDODELETES
, REORGMASSDELETE
, REORGLEAFNEAR
, REORGLEAFFAR
, REORGNUMLEVELS
, STATSLASTTIME
, STATSINSERTS
, STATSDELETES
, STATSMASSDELETE
, COPYLASTTIME
, COPYUPDATEDPAGES
, COPYCHANGES
, COPYUPDATELRSN
, COPYUPDATETIME
, LASTUSED
, IBMREQD
, DBID
, ISOBID
, PSID
, PARTITION
, INSTANCE
, TOTALENTRIES
, DBNAME
, NAME
, CREATOR
, INDEXSPACE
, REORGINDEXACCESS
, DRIVETYPE
, STATS101
from t $comG
ENDEXEC
EXEC SQL
--- update validEnd of previous rows -----------------------------------
update $tb u
set validEnd =
( select n.validBegin
from $tb n
where u.rz = n.rz and u.dbSys = n.dbSys
and u.dbName = n.dbName and u.ts = n.ts
and u.indexSpace = n.indexSpace
and u.partition = n.partition
and u.instance = n.instance
and u.validBegin < n.validBegin
and u.validEnd > n.validBegin
order by n.validBegin asc
fetch first 1 row only
)
where rz = '$rz' and dbSys = '$dbSys'
and validEnd > '9000-01-01-00.00.00'
and exists
( select 1
from $tb n
where u.rz = n.rz and u.dbSys = n.dbSys
and u.dbName = n.dbName and u.ts = n.ts
and u.indexSpace = n.indexSpace
and u.partition = n.partition
and u.partition = n.partition
and u.instance = n.instance
and u.validBegin < n.validBegin
and u.validEnd > n.validBegin
)
ENDEXEC
EXEC SQL
--- update validEnd for rows of dropped indexPartitions ---------------
update $tb u
set validEnd = '$nowM'
where rz = '$rz' and dbSys = '$dbSys'
and validBegin <= '$nowM'
and validEnd > '$nowM'
and not exists
( select 1 from $tb q
where q.rz = '?' and q.dbSys = '?'
and u.dbName = q.dbName and u.ts = q.ts
and u.indexSpace = q.indexSpace
and u.partition = q.partition
and u.instance = q.instance
)
ENDEXEC
// ENDIF
// IF LOADTS.RUN AND LOADIX.RUN AND (RC=0 OR RC=4) THEN
//DELIX EXEC PGM=IEFBR14
//DEL DD DISP=(OLD,DELETE),$csm
// DSN=$ablfP.IXSTATS
// ENDIF
// IF RC = 0 OR RC = 4 THEN
//SQL EXEC PGM=IKJEFT01,DYNAMNBR=200,TIME=99
//SYSTSIN DD *
DSN SYSTEM(DP4G)
RUN PROGRAM(DSNTEP2) PARMS('ALIGN(LHS)') PLAN(DSNTEP2)
//SYSTSPRT DD SYSOUT=*
//SYSPRINT DD DSN=*.LOADTS.SQL,
// DISP=(,CATLG),
// MGMTCLAS=BAT#AT,
// SPACE=(CYL,(15,75),RLSE)
//SYSUDUMP DD SYSOUT=*
//SYSTERM DD DUMMY
//SYSIN DD *
-- GigaByte Grenze
-- for $rz/$dbSys
-- at $now
-- source DSN.ABUB.A.SKELS(QZT071)
--************************************************************
--$'$$' GigaByte Grenze überschrittene Schwellwerte:
--************************************************************
select substr(db, 1, 8) "db"
, substr(ts, 1, 8) "ts"
, substr(tsTy
|| case when tsClone = 'N' and inst = 1 and tsInst = 1 then ''
else case when inst=tsInst then 'b' else 'c' end
|| inst end, 1, 3) "yci"
, substr(ix, max(1, length(ix) - 7), 8) "...index"
, substr(case when part = 0 and tsParts = 0 then ''
else case when part is null then ' ---'
when part = 0 and ix <> ' --ts--' then ' npi'
when part = 0 and tsTy = 'G' then ' pbg'
when part = 0 then ' ???'
else right(' ' || part, 4)
end
||'/'|| value(right(' '|| tsParts, 4),'----')
end, 1, 9) "part/ tot"
, substr(right(case when actGB < 1000
then ' ' || dec(round(actGb, 2), 6, 2)
else ' ' || int(round(actGb, 0))
end, 7), 1, 7) "usedGB"
, substr(right(case when limGb/100*schwelle < 1000
then ' ' || dec(round(limGb/100*schwelle, 2), 6, 2)
else ' ' || int(round(limGb/100*schwelle, 0))
end, 7), 1, 7) "schwGB"
, substr(right(' ' || schwelle, 5), 1, 5) "schw%"
, substr(right(' ' || int(round(limGb)), 6), 1, 6) "limGB"
, date(updateStatsTime) "lastUpdate"
, substr(schwinfo, 23, 18) "schwellwert key"
from OA1P.vQZ006GbGrenze g
where rz = '$rz' and dbSys = '$dbSys'
and db <> 'DSNDB01' -- directory ist anders
and actGb > real(limGb / 100 * schwelle)
$@ if $dbSys = 'DVBP' then $@=¢
-- elar xb: nur partition die seit 1.12.14 noch wachsen
and ( db not like 'XB%'
or (validBegin >= '2015-02-20-00.00.00'
and (nActive, nPages, REORGINSERTS
, space, totalRows, dataSize)
not in ( select z.nActive, z.nPages, z.REORGINSERTS
, z.space, z.totalRows, z.dataSize
from oa1p.tqz006GBGRTSSTATS z
where g.rz = z.rz
and g.dbSys = z.dbSys
and g.DB = z.DBNAME
and g.ts = z.NAME
and g.PART = z.PARTITION
and g.INST = z.INSTANCE
and z.validBegin < '2015-02-20-00.00.00'
order by z.validBegin desc
fetch first 1 row only
) ) )
$!
order by db, ts, inst, ix, part
;
--
-- db = Datenbank
-- ts = Tablespace
-- yci = ts type oder s=Segmented,i=Simple p=PartitionedClassic,
-- clone und Instance (falls geKlont)
-- part/ tot = betroffene PartitionsNummer / Total Partitonen des ts
-- ...index = index oder --ts--
-- usedGB = aktuelle benutzter Platz in GB
-- schwGB = Schwellwert in GB
-- schw% = Schwellwert in Prozent der Limite
-- limGB = physische Limite in GB
-- lastUpdate = letzter update aus RealTimeStats
-- Schwellwert key = key des Schwellwerts in oa1p.tqz008GbGrSchwelle
// ENDIF
}¢--- A540769.WK.REXX(QZT071C) cre=2016-01-05 mod=2016-09-28-13.14.28 A540769 ---
$#=
$*( --- for test with wsh -------------
$>. fEdit()
$=rz=RZZ
$=dbSys=DPZG
$=nowM=- f('%t S')
$=now =- f('%tSs', $nowM)
$=ab=gbGr
$=ablfP=DSN.ABLF.GBGR.$dbSys
$=ablfRz=DSN.ABLF.GBGR.$dbSys.$rz
--- for test with wsh end ------------- $*)
//QZT0710P JOB (CP00,KE50),'DB2 GBGRENZE',
// MSGCLASS=T,TIME=1440,CLASS=M1,
// REGION=0M,SCHENV=DB2
$@¢
if $rz = sysvar(sysnode) then $@¢
$= csm = $''
$= rzAblf = $ablfP
$! else $@¢
$= csm = SUBSYS=(CSM,'SYSTEM=$rz'),
$= rzAblf = $rz/$ablfP
$!
$=tb=OA1P.TQZ006GBGRTSSTATS
$!
//*
//* db2 gbGrenze ablauf $ab from $rz/$dbSys
//* load into $tb
//* generated by abub skels(QZT071) at $now
//*
//* 5. 1.16 nur noch eine Utility fuer TS bzw. IX
//* updateStatsTime wird auf ZürichTime übersetzt
//* origStatsTime enthält originalZeit
$*( history
19.11.15 rename qzt31L --> qzt071
19. 2.15 load Columns aus Punchfile holen, v11 Kolonnen
12.12.14 elar xb: nur partition die seit 1.12.14 noch wachsen
25. 9.14 rz2/dvbp XB% bis ZS nov14 excluded
$*)
//*********************************************************************
//* --- load table data for $rz/$dbSys
//* --- load raw data into $tb part 1 mit ?/? (default)
//* --- insert active and drops'd rows if changed with $rz/$dbSys
//LOADTS EXEC PGM=DSNUTILB,
// PARM=(DP4G,'QZT0710P.LOAD')
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SQL DD DSN=$ablfRz.SQL,
// DISP=(MOD,DELETE)
//SYSOUT DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//TSSTATS DD DISP=SHR,$csm
// DSN=$ablfP.TSSTATS
//SYSIN DD *
--- load raw data from unload as ?/? into part 1 ---------------------
LOAD DATA LOG NO
WORKDDN(TSYUTS,TSOUTS)
SORTKEYS
SORTDEVT DISK
MAPDDN TMAPD ERRDDN TERRD
STATISTICS INDEX(ALL) REPORT NO UPDATE ALL
INTO TABLE $tb
PART 1 INDDN TSSTATS RESUME NO REPLACE COPYDDN(TCOPYD)
(
$@¢ call loadCols $<$rzAblf.TSPUNCH $!
)
EXEC SQL
--- insert 'a' rows for active tablePartitions ------------------------
insert into $tb
$@ if $rz = 'RR2' then $@=¢
with g2 as
( --- pta: date in future: find highest timestamp
select max(updateStatsTime) statsMax
, timestamp('$nowM') loadTs
$** , count(*) cnt
from $tb
where rz = '?' and dbSys = '?'
)
, g3 as
(
select g2.*
, days(statsMax) - days(loadTs) d1
from g2
)
, g as
( --- calculate days Difference to our date
select g3.*
, case when statsMax <= loadTs then 0
when statsMax - (d1-1) days <= loadTs then d1-1
when statsMax - (d1 ) days <= loadTs then d1
else d1+1 end di
from g3
)
, t2 as
$=comG= , g
$=diDy= - di days
$! $@ else $@=¢
with t2 as
$=comG= $''
$=diDy= $''
$!
( -- select loaded rows and previous timestamps/state
select t.*
, ( select char(a.updateStatsTime)
|| char(a.origStatsTime) || a.state
from $tb a
where a.rz='$rz' and a.dbSys = '$dbSys'
and t.dbName = a.dbName
and t.name = a.name
and t.partition = a.partition
and t.instance = a.instance
order by updateStatsTime desc
fetch first 1 row only
) uos
from $tb t
where rz = '?' and dbSys = '?'
)
, t as
( --- decode uos and select only rows with changed updateStatsTime
select t2.*
, timestamp(substr(uos, 1, 26)) prUpd
from t2
where uos is null
or timestamp(substr(uos, 27, 26)) <> updateStatsTime
or substr(uos, 53, 1) <> 'a'
)
--- select compute all columns to insert
select 'a' STATE
, '$rz' RZ
, '$dbSys' DBSYS
, TSTYPE
, TSTY
, PGSIZE
, SEGSIZE
, PARTS
, MAXPARTS
, DSSIZE
, DSGB
, LIMGB
, LIMPART
, OBID
, CLONE
, TSINST
, TBCR
, TB
, TBTY
, TBOBID
, timestamp('$nowM') loadTS
, t.UPDATESTATSTIME origStatsTime --- original statsTime
, value(case --- statsTime in our calendar,
--- must be strictly increasing
--- should be <= loadTs
when ( t.updatestatsTime $diDy > prUpd
or prUpd is null )
and t.updatestatsTime $diDy
<= '$nowM'
then t.updatestatsTime $diDy
when '$nowM' <= prUpd
then trunc_timestamp(prUpd, 'mi') + 2 minutes
end, '$nowM') updateStatsTime
, NACTIVE
, NPAGES
, EXTENTS
, LOADRLASTTIME
, REORGLASTTIME
, REORGINSERTS
, REORGDELETES
, REORGUPDATES
, REORGUNCLUSTINS
, REORGDISORGLOB
, REORGMASSDELETE
, REORGNEARINDREF
, REORGFARINDREF
, STATSLASTTIME
, STATSINSERTS
, STATSDELETES
, STATSUPDATES
, STATSMASSDELETE
, COPYLASTTIME
, COPYUPDATEDPAGES
, COPYCHANGES
, COPYUPDATELRSN
, COPYUPDATETIME
, IBMREQD
, DBID
, PSID
, PARTITION
, INSTANCE
, SPACE
, TOTALROWS
, DATASIZE
, UNCOMPRESSEDDATASIZE
, DBNAME
, NAME
, REORGCLUSTERSENS
, REORGSCANACCESS
, REORGHASHACCESS
, HASHLASTUSED
, DRIVETYPE
, LPFACILITY
, STATS01
, UPDATESIZE
, LASTDATACHANGE
from t $comG
$*(
)
select count(*) cc
, max(cnt) cnt
, sum(case when updateStatsTime < '1911-11-11-11.11.11'
then 1 else 0 end) b11
, sum(case when updateStatsTime <> origStatsTime
then 1 else 0 end) new
from i $comG $*)
ENDEXEC
EXEC SQL
--- insert 'd' rows for dropped tablePartitions -----------------------
insert into $tb
(state, loadTs, origStatsTime, updateStatsTime
, rz, dbSys, dbName, name, partition, instance
, tsType, tsTy, pgSize, segSize
, parts, maxParts, dsSize, dsGb, limGb, limPart
, obid, clone, tsInst, tbCr, tb, tbTy, tbObId
, dbid, psid, ibmReqD
)
with g as
( --- find highest timestamp
select max(updateStatsTime) statsMax
from $tb
where rz = '?' and dbSys = '?'
)
, a as
( --- find key of newest row
select rz, dbSys, dbName, name
, partition, instance, max(updateStatsTime) prStats
from $tb a
where rz='$rz' and dbSys = '$dbSys'
group by rz, dbSys, dbName, name, partition, instance
)
, b as
( --- join newest row
--- select only if missing in new import and not a 'd' row already
select b.*
from a join $tb b
on b.rz = a.rz
and b.dbSys = a.dbSys
and b.dbName = a.dbName
and b.Name = a.Name
and b.partition = a.partition
and b.instance = a.instance
and b.updateStatsTime = a.prStats
where b.state <> 'd'
and not exists (select 1
from $tb n
where n.rz = '?' and n.dbSys = '?'
and n.dbName = a.dbName
and n.Name = a.Name
and n.partition = a.partition
and n.instance = a.instance
)
)
--- select new values and non nullable rows
select 'd' state
, '$nowM' loadTs
, g.statsMax origStatsTime
, case when updateStatsTime
< '$nowM'
then timestamp('$nowM')
else trunc_timestamp(updateStatsTime, 'mi') + 2 minutes
end updateStatsTime
, rz, dbSys, dbName, name, partition, instance
, tsType, tsTy, pgSize, segSize
, parts, maxParts, dsSize, dsGb, limGb, limPart
, obid, clone, tsInst, tbCr, tb, tbTy, tbObId
, dbid, psid, ibmReqD
from b, g
ENDEXEC
//***** delete input dsn **********************************************
// IF LOADTS.RUN AND (RC=0 OR RC=4) THEN
//DELTS EXEC PGM=IEFBR14
//DEL DD DISP=(OLD,DELETE),$csm
// DSN=$ablfP.TSSTATS
// ENDIF
// IF LOADTS.RUN AND (RC=0 OR RC=4) THEN
$=tb=OA1P.TQZ007GBGRIXSTATS
//*********************************************************************
//* --- load index data for $rz/$dbSys
//* --- load raw data into $tb part 1 mit ?/? (default)
//* --- insert active and drops'd rows if changed with $rz/$dbSys
//LOADIX EXEC PGM=DSNUTILB,
// PARM=(DP4G,'QZT0710P.LOAD')
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//IXSTATS DD DISP=SHR,$csm
// DSN=$ablfP.IXSTATS
//SYSIN DD *
LOAD DATA LOG NO
WORKDDN(TSYUTS,TSOUTS)
SORTKEYS
SORTDEVT DISK
MAPDDN TMAPD ERRDDN TERRD
STATISTICS INDEX(ALL) REPORT NO UPDATE ALL
INTO TABLE $tb
PART 1 INDDN IXSTATS RESUME NO REPLACE COPYDDN(TCOPYD)
(
$@¢ call loadCols $<$rzAblf.IXPUNCH $!
)
EXEC SQL
--- insert 'a' rows for active indexPartitions ------------------------
insert into $tb
$@ if $rz = 'RR2' then $@=¢
with g2 as
( --- pta: date in future: find highest timestamp
select max(updateStatsTime) statsMax
, timestamp('$nowM') loadTs
$** , count(*) cnt
from $tb
where rz = '?' and dbSys = '?'
)
, g3 as
(
select g2.*
, days(statsMax) - days(loadTs) d1
from g2
)
, g as
( --- calculate days Difference to our date
select g3.*
, case when statsMax <= loadTs then 0
when statsMax - (d1-1) days <= loadTs then d1-1
when statsMax - (d1 ) days <= loadTs then d1
else d1+1 end di
from g3
)
, t2 as
$=comG= , g
$=diDy= - di days
$! $@ else $@=¢
with t2 as
$=comG= $''
$=diDy= $''
$!
( -- select loaded rows and previous timestamps/state
select t.*
, ( select char(a.updateStatsTime)
|| char(a.origStatsTime) || a.state
from $tb a
where a.rz='$rz' and a.dbSys = '$dbSys'
and t.dbName = a.dbName
and t.ts = a.ts
and t.indexSpace= a.indexSpace
and t.partition = a.partition
and t.instance = a.instance
order by updateStatsTime desc
fetch first 1 row only
) uos
from $tb t
where rz = '?' and dbSys = '?'
)
, t as
( --- decode uos and select only rows with changed updateStatsTime
select t2.*
, timestamp(substr(uos, 1, 26)) prUpd
from t2
where uos is null
or timestamp(substr(uos, 27, 26)) <> updateStatsTime
or substr(uos, 53, 1) <> 'a'
)
--- select compute all columns to insert
select 'a' STATE
, '$rz' RZ
, '$dbSys' DBSYS
, INDEXTYPE
, COMPRESS
, IXPARTS
, IXPGSZ
, PIECESIZE
, PIECEGB
, LIMGB
, TBCREATOR
, TBNAME
, TS
, TSTY
, TSPARTS
, TSCLONE
, TSINST
, TSDSSIZE
, TSDSGB
, TSLIMGB
, TSLIMPART
, TSPGSZ
, timestamp('$nowM') loadTS
, t.UPDATESTATSTIME origStatsTime --- original statsTime
, value(case --- statsTime in our calendar,
--- must be strictly increasing
--- should be <= loadTs
when ( t.updatestatsTime $diDy > prUpd
or prUpd is null )
and t.updatestatsTime $diDy
<= '$nowM'
then t.updatestatsTime $diDy
when '$nowM' <= prUpd
then trunc_timestamp(prUpd, 'mi') + 2 minutes
end, '$nowM') updateStatsTime
, NLEVELS
, NPAGES
, NLEAF
, NACTIVE
, SPACE
, EXTENTS
, LOADRLASTTIME
, REBUILDLASTTIME
, REORGLASTTIME
, REORGINSERTS
, REORGDELETES
, REORGAPPENDINSERT
, REORGPSEUDODELETES
, REORGMASSDELETE
, REORGLEAFNEAR
, REORGLEAFFAR
, REORGNUMLEVELS
, STATSLASTTIME
, STATSINSERTS
, STATSDELETES
, STATSMASSDELETE
, COPYLASTTIME
, COPYUPDATEDPAGES
, COPYCHANGES
, COPYUPDATELRSN
, COPYUPDATETIME
, LASTUSED
, IBMREQD
, DBID
, ISOBID
, PSID
, PARTITION
, INSTANCE
, TOTALENTRIES
, DBNAME
, NAME
, CREATOR
, INDEXSPACE
, REORGINDEXACCESS
, DRIVETYPE
, STATS101
from t $comG
ENDEXEC
EXEC SQL
--- insert 'd' rows for dropped indexPartitions -----------------------
insert into $tb
(state, loadTs, origStatsTime, updateStatsTime
, rz, dbSys
, indexType, compress, ixParts, ixPgSz
, pieceSize, pieceGB, limGB
, tbCreator, tbName
, ts, tsTy, tsParts, tsClone, tsInst, tsDsSize, tsDsGb
, tsLimGb, tsLimPart, tsPgSz
, dbName, indexSpace, creator, name, partition, instance
, ibmReqD, dbid, isobid, psid
)
with g as
( --- find highest timestamp
select max(updateStatsTime) statsMax
from $tb
where rz = '?' and dbSys = '?'
)
, a as
( --- find key of newest row
select rz, dbSys, dbName, ts, indexSpace
, partition, instance, max(updateStatsTime) prStats
from $tb a
where rz='$rz' and dbSys = '$dbSys'
group by rz, dbSys, dbName, ts, indexSpace, partition, instance
)
, b as
( --- join newest row
--- select only if missing in new import and not a 'd' row already
select b.*
from a join $tb b
on b.rz = a.rz
and b.dbSys = a.dbSys
and b.dbName = a.dbName
and b.ts = a.ts
and b.indexSpace= a.indexSpace
and b.partition = a.partition
and b.instance = a.instance
and b.updateStatsTime = a.prStats
where b.state <> 'd'
and not exists (select 1
from $tb n
where n.rz = '?' and n.dbSys = '?'
and n.dbName = a.dbName
and n.ts = a.ts
and n.indexSpace= a.indexSpace
and n.partition = a.partition
and n.instance = a.instance
)
)
--- select new values and non nullable rows
select 'd' state
, '$nowM' loadTs
, g.statsMax origStatsTime
, case when updateStatsTime
< '$nowM'
then timestamp('$nowM')
else trunc_timestamp(updateStatsTime, 'mi') + 2 minutes
end updateStatsTime
, rz, dbSys
, indexType, compress, ixParts, ixPgSz
, pieceSize, pieceGB, limGB
, tbCreator, tbName
, ts, tsTy, tsParts, tsClone, tsInst, tsDsSize, tsDsGb
, tsLimGb, tsLimPart, tsPgSz
, dbName, indexSpace, creator, name, partition, instance
, ibmReqD, dbid, isobid, psid
from b, g
ENDEXEC
// ENDIF
// IF LOADTS.RUN AND LOADIX.RUN AND (RC=0 OR RC=4) THEN
//DELIX EXEC PGM=IEFBR14
//DEL DD DISP=(OLD,DELETE),$csm
// DSN=$ablfP.IXSTATS
// ENDIF
// IF RC = 0 OR RC = 4 THEN
//SQL EXEC PGM=IKJEFT01,DYNAMNBR=200,TIME=99
//SYSTSIN DD *
DSN SYSTEM(DP4G)
RUN PROGRAM(DSNTEP2) PARMS('ALIGN(LHS)') PLAN(DSNTEP2)
//SYSTSPRT DD SYSOUT=*
//SYSPRINT DD DSN=*.LOADTS.SQL,
// DISP=(,CATLG),
// MGMTCLAS=BAT#AT,
// SPACE=(CYL,(15,75),RLSE)
//SYSUDUMP DD SYSOUT=*
//SYSTERM DD DUMMY
//SYSIN DD *
-- GigaByte Grenze
-- for $rz/$dbSys
-- at $now
-- source DSN.ABUB.A.SKELS(QZT071)
--************************************************************
--$'$$' GigaByte Grenze überschrittene Schwellwerte:
--************************************************************
select substr(db, 1, 8) "db"
, substr(ts, 1, 8) "ts"
, substr(tsTy
|| case when tsClone = 'N' and inst = 1 and tsInst = 1 then ''
else case when inst=tsInst then 'b' else 'c' end
|| inst end, 1, 3) "yci"
, substr(ix, max(1, length(ix) - 7), 8) "...index"
, substr(case when part = 0 and tsParts = 0 then ''
else case when part is null then ' ---'
when part = 0 and ix <> ' --ts--' then ' npi'
when part = 0 and tsTy = 'G' then ' pbg'
when part = 0 then ' ???'
else right(' ' || part, 4)
end
||'/'|| value(right(' '|| tsParts, 4),'----')
end, 1, 9) "part/ tot"
, substr(right(case when actGB < 1000
then ' ' || dec(round(actGb, 2), 6, 2)
else ' ' || int(round(actGb, 0))
end, 7), 1, 7) "usedGB"
, substr(right(case when limGb/100*schwelle < 1000
then ' ' || dec(round(limGb/100*schwelle, 2), 6, 2)
else ' ' || int(round(limGb/100*schwelle, 0))
end, 7), 1, 7) "schwGB"
, substr(right(' ' || schwelle, 5), 1, 5) "schw%"
, substr(right(' ' || int(round(limGb)), 6), 1, 6) "limGB"
, date(updStats) "lastUpdate"
, substr(schwinfo, 23, 18) "schwellwert key"
from OA1P.vQZ006GbGrenze g
where rz = '$rz' and dbSys = '$dbSys'
and db <> 'DSNDB01' -- directory ist anders
and actGb > real(limGb / 100 * schwelle)
$@ if $dbSys = 'DVBP' then $@=¢
-- elar xb: nur partition die seit 1.12.14 noch wachsen
and ( db not like 'XB%'
or (updStats >= '2015-02-20-00.00.00'
and (nActive, nPages, REORGINSERTS
, space, totalRows, dataSize)
not in ( select z.nActive, z.nPages, z.REORGINSERTS
, z.space, z.totalRows, z.dataSize
from oa1p.tqz006GBGRTSSTATS z
where g.rz = z.rz
and g.dbSys = z.dbSys
and g.DB = z.DBNAME
and g.ts = z.NAME
and g.PART = z.PARTITION
and g.INST = z.INSTANCE
and z.updateStatsTime < '2015-02-20-00.00.00'
order by z.updateStatsTime desc
fetch first 1 row only
) ) )
$!
order by db, ts, inst, ix, part
;
--
-- db = Datenbank
-- ts = Tablespace
-- yci = ts type oder s=Segmented,i=Simple p=PartitionedClassic,
-- clone und Instance (falls geKlont)
-- part/ tot = betroffene PartitionsNummer / Total Partitonen des ts
-- ...index = index oder --ts--
-- usedGB = aktuelle benutzter Platz in GB
-- schwGB = Schwellwert in GB
-- schw% = Schwellwert in Prozent der Limite
-- limGB = physische Limite in GB
-- lastUpdate = letzter update aus RealTimeStats
-- Schwellwert key = key des Schwellwerts in oa1p.tqz008GbGrSchwelle
// ENDIF
}¢--- A540769.WK.REXX(QZT09X1) cre=2016-03-14 mod=2016-09-28-15.03.04 A540769 ---
$#=
$*( für wsh test ..................
$>. fEdit()
$= rz = RZZ
$= dbSys = DE0G
$= jP =- iiRz2P($rz)iidbSys2c($dbSys)
$= ab = xDoc
$= now =- f('%t S')
$= p0 = A540769.TST.XDOC
$= pref =- $p0'.'f('%tSY', $now)
$= d = $rz/$p0.ABLF
$*)
$=job=QZT09X${jP}
$= isElar =- $dbSys = 'DVBP' | $dbSys = 'DEVG'
$** until Elar implements its own jobs|
$=doXbaCopy =- $dbSys == 'DVBP' & $rz = RZ2 & $now < '2016-05-10'
$= useLgRn =- wordPos($dbSys, 'DVBP DBOF') > 0 $*+
| ($rz=RZZ & wordPos($dbSys, 'DE0G DEVG') > 0)
$@jobHead
//*** submit to rz $rz ***********************************************
//SUB$rz EXEC PGM=IEBGENER
//SYSPRINT DD SYSOUT=*
//SYSUT2 DD SUBSYS=(CSM,'SYSTEM=$rz,SYSOUT=(A,INTRDR)')
//SYSUT1 DD DATA,DLM='}{'
$@jobHead
//*** load tecsv unload table ****************************************
//TECSVUNL EXEC PGM=IKJEFT01,DYNAMNBR=20
//SYSEXEC DD DSN=DSN.DB2.EXEC,DISP=SHR
//SYSTSPRT DD SYSOUT=*
//SYSPRINT DD SYSOUT=*
//SYSTSIN DD *
%tecSvUnl $dbSys
// IF TECSVUNL.RUN AND TECSVUNL.RC <= 4 THEN
$@ if $useLgRn then $@=¢
//*** load lgrn table ************************************************
//LGRNLOA EXEC PGM=DSNUTILB,PARM='$dbSys,$job.LGRNLOA'
//SYSMAP DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSERR DD SYSOUT=*
//SYSPRINT DD SYSOUT=*
//SYSTEMPL DD DSN=$dbSys.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
EXEC SQL
DECLARE CUR1 CURSOR FOR
with s as
(
select s.DBNAME db, s.NAME TS, p.partition PA
, value( ( select
max( max(value(timestamp(substr(max(LGRSLRSN), 2, 8))
, '1111-11-11-11.11.11')
, value(timestamp(substr(max(LGRELRSN), 2, 8))
, '1111-11-11-11.11.11')) + 7174 seconds
-- max(sommer, winterzeit) - 26 leapSeconds
-- do not use current timeZone there was a winter once
, value(timestamp(max(
TRANSLATE('20YZ-MN-DE-', LGRUCDT, 'MNDEYZ')
|| TRANSLATE('HI.MN.ST.UV', LGRUCTM, 'HIMNSTUV')))
, '1111-11-11-11.11.11')
)
from sysibm.sysLgRnX l
where l.lgrdbid = oa1p.fqzCastSmall2C(s.dbid)
and l.lgrpsid = oa1p.fqzCastSmall2c(s.psid)
and l.lgrpart = p.partition
), '1111-11-11-11.11.11') endTst
from sysibm.sysTableSpace s
join sysibm.sysTablePart p
on s.dbName = p.dbname and s.name = p.tsname
)
select *
from s
where endTst > '1919-01-01-00.00.00'
WITH UR
ENDEXEC
LOAD DATA INCURSOR CUR1 LOG NO RESUME NO REPLACE
COPYDDN TCOPYS STATISTICS INDEX ALL KEYCARD
SORTDEVT DISK
WORKDDN(TSYUTS,TSOUTS)
INTO TABLE OA1P.TQZ004TECSVLGRN
// ENDIF
// IF LGRNLOA.RUN AND LGRNLOA.RC <= 4 THEN
$!
//*** report statistics and list of xDoc partitions ******************
//REPORT EXEC PGM=IKJEFT01,DYNAMNBR=200,TIME=99
//SYSTSIN DD *
DSN SYSTEM($dbSys)
RUN PROGRAM(DSNTIAUL) PARMS('SQL')
//SYSTSPRT DD SYSOUT=*
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTERM DD SYSOUT=*
//SYSPUNCH DD SYSOUT=*,RECFM=FB,LRECL=100
//SYSREC00 DD DISP=(NEW,CATLG,DELETE),RECFM=FB,LRECL=133,
// SPACE=(CYL,(1,50),RLSE),MGMTCLAS=COM#A031,
// DSN=$pref.XSTATS
//SYSREC01 DD DISP=(NEW,CATLG,DELETE),RECFM=FB,LRECL=133,
// SPACE=(CYL,(1,50),RLSE),MGMTCLAS=COM#A031,
// DSN=$pref.XLIST
//SYSIN DD *
set current path oa1p;
set current application compatibility 'V11R1';
$**-- summary
$@repWith
, u (spc, spcU, parts, redo, stage, recState
, unlFrom, unlTo, staUpdFrom,staUpdTo) as
(
select 'spaceBy', 'spaceUn', ' parts', 'redo', 'stage'
, 'recoveryState', 'unlFrom', 'unlTo', 'staUpdFrom', 'staUpdTo'
from sysibm.sysDummy1
union all ( select fqzFmtBin7(sum(spc)), fqzFmtBin7(sum(spcU))
, ' ' || count(*)
, redo, stage, recState
, char(min(unlTst)), char(max(unlTst))
, char(min(staUpd)), char(max(staUpd))
from r
group by grouping sets ((), (redo), (redo, stage, recState) )
order by redo, stage, recState
)
)
select char(value(spc, ''), 8)
, char(value(spcU, ''), 8)
, char(right(value(parts, ''), 7), 8)
, char(value(redo, '***'), 9)
, char(value(stage, '***'), 6)
, char(left(value(recState, '***'), 120), 120)
, char(value(unlFrom, ''), 27)
, char(value(unlTo , ''), 27)
, char(value(staUpdFrom, ''), 27)
, char(value(staUpdTo, ''), 27)
from u
with ur
;
$**-- listing of parts
$@repWith
, u (db, ts, pa, redo, stage, spc, spcU, recState, staUpd, unlTst
,lastDataChange, basTyTx, basTst, lgrnEnd) as
(
select 'db', 'ts', ' part', 'redo', 'stage', 'spaceBy', 'spaceUn'
, 'recoveryState', 'staUpd', 'unlTst', 'lastDataChange'
, 'basText', 'basTst', 'lgRnEnd'
from sysibm.sysDummy1
union all ( select db, ts, ' ' || pa
, redo, stage, fqzFmtBin7(spc), fqzFmtBin7(spcU)
, recState, char(staUpd), char(unlTst), char(lastDatachange)
, basTyTx, char(basTst), char(lgrnEnd)
from r
where redo <> ''
order by r.db, r.ts, r.pa
)
)
select char(value(db, '') , 9)
, char(value(ts, '') , 9)
, char(right(value(pa, '') , 5), 6)
, char(value(redo, '') , 9)
, char(value(stage, '') , 6)
, char(left(value(recState, '') , 120), 120)
, char(value(staUpd, '') ,27)
, char(value(unlTst, '') ,27)
, char(value(lastDataChange, '') ,27)
, char(value(basTyTx, '') , 15)
, char(value(basTst, '') ,27)
, char(value(lgrnEnd, '') ,27)
, char(value(spc, '') , 8)
, char(value(spcU, '') , 8)
from u
fetch first 10000 rows only
with ur
;
// ENDIF
// IF REPORT.RUN AND REPORT.RC <= 4 THEN
//OK EXEC PGM=IEFBR14
//OK DD DISP=(NEW,CATLG,DELETE),RECFM=FB,LRECL=133,
// SPACE=(TRK,(1,1),RLSE),MGMTCLAS=COM#A031,
// DSN=$pref.OK
// ENDIF
$@ if $doXbaCopy then $** until Elar implements its own jobs|
$@xbaCopy
}{
$proc $@=/repWith/
$**-- list of partition recovery state --------------------------------
with q as
(
select qq.*
, fun || case when recLr in ('r', '2')
then ' ' || recover else '' end
|| case when recLr in ('l', '2')
then rtrim(' ' || load) else '' end recState
from oa1p.vQz005RecovDeltaLoadLgRn qq
$@ if $isElar then $@=¢
where db like 'XB%'
)
, r as
(
select case when stage not in ('-a', '-r', '-w'
, 'CL', 'DL', 'RW', 'UL') then 'fixMeta'
when stage in ('UL', 'DL') and lok <> 'l'
and '' = replace(replace(replace(replace(replace(
replace(' ' || substr(recState, 2) || ' '
, ' base=A=addPart ', ' ')
, ' base=S=LoaRpLoNo ', ' ')
, ' dataChange>base=A=addPart ', ' ')
, ' dataChangeV11>unl ', ' ')
, ' lgRnNone ', ' '), ' lgRn>base ', ' ')
then 'redoCopy'
when stage in ('UL', 'DL') and lok <> 'l' then 'redoUnl'
$! $@ else $@=¢
where (db like 'XC%' or db like 'XR%')
and (ts like 'A2%' or ts like 'A5%')
)
, r as
(
select case when posStr(recState, 'stillUnl') > 0 then 'cleanup'
when posStr(recState, 'punNotSo') > 0 then 'redoUnl'
when stage in ('UL', 'RD') and lok <> 'l'
and '' = replace(replace(
replace(' ' || substr(recState, 2) || ' '
, ' dataChangeV11>unl ', ' ')
, ' lgRnNone ', ' '), ' lgRn>base ', ' ')
then 'redoCopy'
when stage in ('UL', 'RD') and lok <> 'l' then 'redoUnl'
$!
when left(recState, 1) not in ('r', 'l', '-')
then 'recErr'
else '' end redo
, q.*
from q
)
$/repWith/
$proc $@=/xbaCopy/
//*
//* copy partitions in state -a ==> only in xba201
//*
//* delete old dsn
//XBADEL EXEC PGM=IEFBR14
//PL DD DSN=$pref.XBAUTIL,
// DISP=(MOD,DELETE)
//*
//XBASQL EXEC PGM=IKJEFT01,DYNAMNBR=20
//SYSTSPRT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSPRINT DD SYSOUT=*
//SYSTSIN DD *
DSN SYSTEM($dbSys)
RUN PROGRAM(DSNTIAUL) PARMS('SQL')
END
//SYSPUNCH DD SYSOUT=*
//SYSREC00 DD DSN=$pref.XBAUTIL,
// SPACE=(TRK,(1,1),RLSE),
// MGMTCLAS=COM#A013,
// RECFM=FB,LRECL=80,
// UNIT=DISK,DISP=(NEW,CATLG)
//SYSIN DD *
with a as
( /***** select segment from txba201 */
select enStorAr n , right('000' || enSeg, 3) seg
from bua.txba201 a
group by enStorAr, enSeg
)
, b as
( /***** exclude txbi003 */
select *
from a
where not exists (select 1
from BUA.TXBI003 i
where i.storageArea_N = a.n
and i.segment = a.seg
and i.partNumber = 1
)
)
, c as
( /***** compute alpha storage area from numeric */
select n, seg
, case when n <= 999 then right('000' || n, 3)
when n <= 35657 /* 1296 = 36**2 */
then substr('0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ'
, (n + 10998) / 1296 + 1, 1)
|| substr('0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ'
, mod(n + 10998, 1296) / 36 + 1, 1)
|| substr('0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ'
, mod(n + 10998, 36) + 1, 1)
end stoAr
from b
)
, t as
( /***** join sysTables */
select c.*, t.dbName db, t.tsName ts, t.creator cr, t.name tb
from c join sysibm.sysTables t
on left(t.name, 8) = 'XB' || c.stoAr || c.seg
)
, i0 as
( /***** create include statement and row number */
select ' INCLUDE TABLESPACE '
|| db || '.' || ts || ' PARTLEVEL 1 -- ' || tb li
, row_number() over(order by db, ts) rn
from t
)
, i as
( /***** add group number */
select 1 + floor(rn / 50) gr, rn, li
from i0
)
, g as
( /***** groups only */
select gr from i group by gr
)
, ut (gr, rn, li) as
( /***** union all of utility statements */
select 0 , -5, 'OPTIONS(EVENT ITEMERROR, SKIP)'
from sysibm.sysDummy1
/* on all select 0 , -4, 'OPTIONS PREVIEW'
from sysibm.sysDummy1 */
union all select gr , -1, 'LISTDEF LIST#' ||gr from g
union all select gr , rn, li from i
union all select gr+1, -9
, 'COPY LIST LIST#' || gr || ' COPYDDN(TCOPYD)' from g
union all select gr+1, -8
, ' FULL YES PARALLEL SHRLEVEL CHANGE' from g
)
select char(value(li, ' -- null'), 80)
from ut
order by gr, rn
;
//XBACOPY EXEC PGM=DSNUTILB,
// PARM='$dbSys,$job.COPY'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=$dbSys.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD DSN=$pref.XBAUTIL,
// DISP=SHR
$/xbaCopy/
$proc $@=/jobHead/
//$job JOB (CP00,KE50),'db2 abub xDoc',
// MSGCLASS=E,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M,SCHENV=DB2ALL,CLASS=M1
//*
//* weekly xDocs control for $rz/$dbSys/$ab job1
//* generated by abub at $now
//* source: rz4/dsn.abub.a.skels(qzt09X1)
//* version: 28.9.16 ohne lastEq mit lgrnEnd/endTst und spaceUn
//* p0 =$p0
//* pref=$pref
//* d =$d
//* =$rz/$dbSys
$/jobHead/
}¢--- A540769.WK.REXX(QZT09X2) cre=2016-09-23 mod=2016-09-23-14.39.56 A540769 ---
$#@
say 'start' $rz'/'$dbSys 'in rz4/dsn.abub.a.skels(qzt09X1)'
say 'p0 ='$p0
say 'pref ='$pref
say 'd ='$d
say 'iOK ='$iOK
iPre = left($iOK, lastPos('.', $iOK))
say 'iPre ='iPre
oStats = word($oStats, 1)
cx = $cx
m.cx.cuLink = oStats
say 'cx='cx 'cx.cuLink='m.cx.cuLink
nAtt = '::v700' subWord($oStats, 3)
say 'oStats='$oStats '==>' oStats
oList = word($oList, 1)
say 'oList ='$oList '==>' oList
call tsoFree word(dsnAlloc(oStats nAtt), 2) $** create correct atts
call csmCopy iPre'XSTATS', oStats
call tsoFree word(dsnAlloc(oList nAtt), 2) $** create with correct atts
call csmCopy iPre'XLIST', oList
if 0 then $@¢ $** test, mail nur an Walter
call mailHead qq, 'status xDocs' $rz'/'$dbSys ,
, 'walter.keller@credit-suisse.com' , m.my.mailId
$! else if $dbSys == 'DBOF' then $@¢
call mailHead qq, 'status XC/XR Docs' $rz'/'$dbSys ,
, 'nicole.melliniweber@credit-suisse.com' , m.my.mailId
call mAdd qq, 'to=armin.breyer@credit-suisse.com' ,
, 'to=arturo.quero@credit-suisse.com' ,
, 'cc=raymond.stofer@credit-suisse.com' ,
, 'cc=marc.streit.2@credit-suisse.com' ,
, 'cc=walter.keller@credit-suisse.com'
$! else if $dbSys == 'DVBP' then $@¢
call mailHead qq, 'status Elar Docs' $rz'/'$dbSys ,
, 'ashish.gupta.3@credit-suisse.com' , m.my.mailId
call mAdd qq, 'to=willy.heller@credit-suisse.com' ,
, 'to=rama.k.prayaga@credit-suisse.com' ,
, 'cc=petr.matulik@credit-suisse.com' ,
, 'cc=tal.friede@credit-suisse.com' ,
, 'cc=roland.wermelinger@credit-suisse.com' ,
, 'cc=marc.streit.2@credit-suisse.com' ,
, 'cc=walter.keller@credit-suisse.com'
$! else $@¢
call myMailHead qq, 'status xDocs' $rz'/'$dbSys
$!
call mAdd qq, 'TEXT=<h1>status xDocs' $rz'/'$dbSys m.my.resTst'</h1>' ,
, 'att=DSN¢'oStats'!FILE¢stats.txt!',
, 'att=DSN¢'oList'!FILE¢list.txt!' ,
, 'TEXT=<ul><li>summary: stats.txt' ,
'<a href="https://web-pd-sec.csintra.net/MVSDS/%27' ,
|| oStats'%27">RZ4/'oStats'</a></li>' ,
, 'TEXT=<li>partition list: list.txt' ,
'<a href="https://web-pd-sec.csintra.net/MVSDS/%27' ,
|| oList'%27">RZ4/'oList'</a></li></ul>'
call readDsn oStats, i.
call mAdd qq, 'TEXT=<pre><span' ,
'style="background-color:greenyellow;font-weight:bolder;">',
|| htmlEsc(strip(left(i.1, 100), 't')),
'</span>'
do ix=2 to i.0
call mAdd qq, 'TEXT='htmlEsc(strip(left(i.ix, 100), 't'))
end
call mAdd qq, 'TEXT=</pre>'
call mailSend qq
say 'end ok' $rz'/'$dbSys 'in rz4/dsn.abub.a.skels(qzt09X1)'
}¢--- A540769.WK.REXX(RANGE) cre=2011-01-14 mod=2011-01-14-16.01.00 A540769 ----
rangeTest:
call rt1 '', 1
call rt1 '5', 1
call rt1 '5', 4
call rt1 '5', 5
call rt1 '5', 6
call rt1 '5', 9
call rt1 '4-6', 1
call rt1 '4-6', 3
call rt1 '4-6', 4
call rt1 '4-6', 5
call rt1 '4-6', 6
call rt1 '4-6', 7
call rt1 '4-6', 9
call rt1 '0 4-6', 1
call rt1 '0 4-6', 3
call rt1 '0 4-6', 4
call rt1 '0 4-6', 5
call rt1 '0 4-6', 6
call rt1 '0 4-6', 7
call rt1 '0 4-6', 9
call rt1 '0 4-6 11-12 15', 1
call rt1 '0 4-6 11-12 15', 3
call rt1 '* 4-6 11-12 15', 4
call rt1 '* 4-6 11-12 15', 5
call rt1 '* 4-6 11-12 15', 6
call rt1 '* 4-6 11-12 15', 7
call rt1 '* 4-6 11-12 15', 9
return
endProcedure rangeTest
rt1:procedure
parse arg ra, nn
res = rangeAdd(ra, nn)
say 'rangeAdd' ra',' nn '->' res
return res
endProcedure rt1
/*--- add a member to a range
a range is a string of the form '7 6-9 11' ---------------------*/
rangeAdd: procedure expose m.
parse arg ra, nn
do wx=1 to words(ra)
parse value word(ra, wx) with von '-' bis
if bis = '' then
bis = von
if nn-1 > bis then
iterate
else if nn-1 = bis then
bis = nn
else if nn >= von then
return ra
else if nn+1 = von then
von = nn
else
return strip(subWord(ra, 1, wx-1) nn subWord(ra, wx))
return strip(subWord(ra, 1, wx-1) von'-'bis subWord(ra, wx+1))
end
return strip(ra nn)
endProcedure rangeAdd
/*--- return true/false whether nn is in range ra --------------------*/
rangeIsIn: procedure expose m.
parse arg ra, nn
do wx=1 to words(ra)
parse value word(ra, wx) with von '-' bis
if bis = '' then
bis = von
if nn < von then
return 0
if nn <= bis then
return 1
end
return 0
endProcedure rangeIsIn
/*--- next ele in range ----------------------------------------------*/
rangeNext: procedure expose m.
parse arg ra, la
do wx=1 to words(ra)
parse value word(ra, wx) with von '-' bis
if la < von then
return von
if bis = '' then
bis = von
if la < bis then
return la+1
end
return ''
endProcedure rangeNext
}¢--- A540769.WK.REXX(RCALLFAD) cre=2014-12-15 mod=2014-12-16-07.58.19 A540769 ---
/* REXX ----------------------------------------------------------------
START COMPUWARE FILEAID, ENTRY: EDIT TEMPLATE
---------------------------------------------
history
15.12.2014/WK: V3R4 FileAid Libraryfür fileAid 6.3 - 10.1.0.36
30.05.2013/WK: V3R3 FileAid Library nur noch fuer DB2 v10
10.02.2012/WK: V3R2 FileAid Library für DB2 V10 bzw. FA/DB2 V6.2
07.12.2007/STR: V3R1 FileAid Library angepasst
19.09.2006/STR: V3R0 RCALLFAD FÜR AUFRUF MIT 'TSO EXCP'
07.07.2006/STR: V2R0 XFAEDIT1 FÜR AUFRUF MIT IBM ADM TOOL
29.10.2001/HBD: V1R2 LOGIK FÜR SSID BEI REMOTE ZUGRIFFEN
18.12.2000/HBD: VERSION 1
test fileAid Version
primary command INFO zeigt FAD, DB2, usw. Version
----------------------------------------------------------------------*/
DEBUG=0
Pgm_VERS='V3R3'
ARG XMODE XSSID XNAME XQUAL
if 0 & xmode == '' then /* activate for test */
parse value 'browse DP4G TQZ008GBGRSCHWHIST OA1P' ,
with XMODE XSSID XNAME XQUAL
IF DEBUG THEN DO
SAY 'PGM-VERSION: 'PGM_VERS
SAY '.. PASSED VARIABLES: '
SAY '.. MODUS ='XMODE
SAY '.. XSSID ='XSSID', XNAME='XNAME', XQUAL='XQUAL
END
/* ISPF VARIABLEN ABFUELLEN FUER BENUTZER, DIE NOCH NIE IN FILEAID */
/* EINGELOGGT SIND */
/* F2SSID = DB2 Group Attach Name */
/* F2PLAN = FileAid Plan Name */
/* F2CAPS2 = Daten in Uppercase convertieren */
/* SPIMPNUL = Column-Defaults werden übernommen */
/* UPKEYEDI = Unique Key Informationen werden herausgelesen */
/**/
address ispexec "VGET (F2SSID F2PLAN F2CAPS2 SPIMPNUL UPKEYEDI) ASIS"
IF DEBUG THEN SAY "F2SSID ="F2SSID
IF DEBUG THEN SAY "F2PLAN ="F2PLAN
/* Alte Werte sichern */
F2SSID_o = F2SSID
F2PLAN_o = F2PLAN
F2CAPS2_o = F2CAPS2
SPIMPNUL_o = SPIMPNUL
UPKEYEDI_o = UPKEYEDI
/* Neue Werte setzen und in Profile schreiben */
F2SSID = XSSID
F2PLAN = "FILEAID"
F2CAPS2 = "IN"
SPIMPNUL = "ON"
UPKEYEDI = "OFF"
address ispExec "VPUT (F2SSID F2PLAN F2CAPS2 SPIMPNUL UPKEYEDI) PROFILE"
/* fileAid 6.2 und hoffentlich alle späteren */
syLib = COMPWARE.ALIAS.FD.ISRCLIB
csLib = COMPWARE.ALIAS.FD.ISRCLIB.CS
/* fileAid 6.3 und hoffentlich alle späteren */
syLib = COMPWARE.ALIAS.SXVJCLIB
csLib = COMPWARE.ALIAS.CXVJCLIB
if debug then
say 'csLib' cslib
address tso "ALTLIB ACTIVATE APPLICATION(CLIST) ",
"DSNAME('"cslib"', '"sylib"')"
/* FAD AUFRUFEN */
ADDRESS ISPEXEC "SELECT CMD(F2XNTRFC OPTION("XMODE") ENTRY(TEMPLATE)",
"SSID("XSSID") QUAL("XQUAL") NAME("XNAME") TRACE(OFF)) ",
"NEWAPPL PASSLIB"
ADDRESS TSO "ALTLIB DEACTIVATE APPLICATION(CLIST)"
/* Alte Werte wiederherstellen und in Profile speichern */
F2SSID = F2SSID_o
F2PLAN = F2PLAN_o
F2CAPS2 = F2CAPS2_o
SPIMPNUL = SPIMPNUL_o
UPKEYEDI = UPKEYEDI_o
address ispExec "VPUT (F2SSID F2PLAN F2CAPS2 SPIMPNUL UPKEYEDI) PROFILE"
EXIT;
}¢--- A540769.WK.REXX(RCM) cre=2015-11-16 mod=2015-11-16-08.09.41 A540769 ------
/* copy rcm begin ******** caDb2 RC/Migrator *************************/
/*--- add an objecct including explodes to quickmigrate input -------*/
rcmQuickAdd: procedure expose m.
parse arg o, aTy, qu, na
ty = rcmQuickType(aTy)
if ty == 'DB' then
call mAdd o, ' ' m.rcm_QuickT2QUICK.ty '=' na
else
call mAdd o, ' ' m.rcm_QuickT2QUICK.ty qu na
call rcmQuickAdaEI o, ty, 'DB' , 'EXPLODE TABLESPACE'
call rcmQuickAdaEI o, ty, 'T' , 'IMPLODE TABLESPACE'
call rcmQuickAdaEI o, ty, 'DB TS' , 'EXPLODE TABLE'
call rcmQuickAdaEI o, ty, 'DB TS T' , 'EXPLODE INDEX'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE VIEW'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE SYNONYM'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE TRIGGER'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE MQTB_T'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE MQTB_I'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE MQTB_V'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE MQTB_S'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE MQVW_VW'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE MQVW_I'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE MQVW_V'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE MQVW_S'
call rcmQuickAdaEI o, ty, 'I' , 'IMPLODE MQVW_VW'
return
endProcedure rcmQuickAdd
rcmQuickAdaEI: procedure expose m.
parse arg o, ty, types, l1 lR
if wordPos(ty, types) > 0 then
call mAdd o, ' ' left(l1, 11) lR
return
endProcedure rcmQuickAdaEI
rcmQuickType: procedure expose m.
parse upper arg ty
if symbol('m.rcm_quickA2T.ty') == 'VAR' then
return m.rcm_quickA2T.ty
call rcmQuickTyp1 'DATABASE' , 'DB'
call rcmQuickTyp1 'INDEX' , 'I IX'
call rcmQuickTyp1 'TABLE' , 'T TB'
call rcmQuickTyp1 'TABLESPACE' , 'TS'
call rcmQuickTyp1 'TRIGGER' , 'TG'
call rcmQuickTyp1 'VIEW' , 'V VW'
call rcmQuickTyp1 'PROCEDURE PROCEDUR', 'PR SP'
if symbol('m.rcm_quickA2T.ty') == 'VAR' then
return m.rcm_quickA2T.ty
call err 'rcmQuickType type='ty 'not implemented'
endProcedure rcmQuickType
rcmQuickTyp1: procedure expose m.
parse upper arg dTy qTy ., t aa
m.rcm_quickT2DB2.t = dTy
if qTy == '' then
m.rcm_quickT2QUICK.t = dTy
else
m.rcm_quickT2QUICK.t = qTy
m.rcm_quickA2T.dTy = t
if qTy \== '' then
m.rcm_quickA2T.qTy = t
m.rcm_quickA2T.t = t
do ax=1 to words(aa)
a = word(aa, ax)
m.rcm_quickA2T.a = t
end
return
endProcedure
/* copy rcm end ******** caDb2 RC/Migrator *************************/
}¢--- A540769.WK.REXX(RCSTOLD) cre=2009-05-05 mod=2009-09-24-11.42.27 A540769 ---
/*- rexx ---------------------------------------------------------------
recStatistics
----------------------------------------------------------------------*/
call errReset 'hI'
call adrEdit 'macro (arg)', '*'
parse arg pIn
call recStatsIni
call envIni
if pIn = '' then
pIn = '~rec.jobs(m05a)'
call envPush '> ~rec.jobs(all)'
call envBarBegin
ll = lmmBegin(dsn2jcl('~rec.jobs'))
do forever
mbr = lmmNext(ll)
if mbr = '' then
leave
if wordPos(mbr, 'ALL') > 0 then
iterate
say 'mbr' mbr '...'
pIn = '~rec.jobs('mbr')'
say pIn
call envPush '<' pIn
call recStats a
m.a.member = mbr
call jOuR a
call envPop
end
call envBarLast
call fmtFCsvAll
call envBarEnd
call envPop
exit
recStatsIni: procedure expose m.
if m.recStats.ini == 1 then
return
call classIni
call classNew 'n RecStats u f MEMBER v, f JOB v, f SYSTEM v,' ,
'f PARTS v, f COPIES v, f PAGES v,' ,
'f RBARANGE v, f RBAZERO v,',
'f CPU v, f SRB v, f ELAPSED v, f STARTED v'
return
endProcedure recStatsIni
recStats: procedure expose m.
parse arg m
numeric digits 20
call oMutate m, 'RecStats'
m.m.parts = 0
m.m.pages = 0
m.m.copies = 0
m.m.rbaRange = 0
m.m.rbaZero = 0
do while jIn(line)
if abbrev(m.line, 'DSNU504I') then
call recStatsMerge m, line
if abbrev(m.line, 'DSNU513I') then
call recStatsRange m, line
if abbrev(m.line, 'IEF376I ') then
call recStatsEoj m, line
if substr(m.line, 11, 9) = ' IEF403I ' then
call recStatsStartJ m, line
if substr(m.line, 11, 9) = ' IEF404I ' then
call recStatsEndJ m, line
end
return
endProcedure recStats
recStatsMerge: procedure expose m.
parse arg m, li1
cx = pos('MERGE STATISTICS FOR', m.li1)
if cx < 1 then
call err 'no merge statistics for in line:' m.li1
parse value substr(m.li1, cx+21) with ty obj c1 dsnu .
if \ (jIn(li2) & jIn(li3)) then
call err '2 lines required after line:' m.li1
parse var m.li2 e2 'NUMBER OF COPIES=' cop .
if \ (e2 = '' & datatype(cop , 'N')) then
call err 'bad copies line after line:' m.li1
parse var m.li3 e3 'NUMBER OF PAGES MERGED=' pag .
if \ (e3 = '' & datatype(pag , 'N')) then
call err 'bad pages line 2 after line:' m.li1
/* say obj'/'c1 dsNu':' ty 'merged co' cop 'pag' pag */
m.m.parts = m.m.parts + 1
m.m.copies = m.m.copies + cop
m.m.pages = m.m.pages + pag
return
endProcedure recStatsMerge
recStatsRange: procedure expose m.
parse arg m, li1
parse var m.li1 e1 'LOG APPLY RANGE IS RBA' fR e1e 'LRSN' fL e1To
if fR = '' | e1e \= '' | fL = '' | e1To \= 'TO' ,
| verify(fR || fL, '0123456789ABCDEF') > 0 then
call err 'bad log apply range line:' m.li1
if \ jIn(li2) then
call err '1 line required after line:' m.li1
parse var m.li2 e2 'RBA' tR e2e 'LRSN' tL e2To
if e2 \= '' | tR = '' | e2e \= '' | tL = '' | e2To \= '' ,
| verify(tR || tL, '0123456789ABCDEF') > 0 then
call err 'bad log apply range to line:' m.li2
di = x2d(tR) - x2d(fR)
if fR = 0 | tR = 0 | di < 1 then do
say 'rba ZeroRange' fR '-' tR 'line' m.li1
m.m.rbaZero = m.m.rbaZero + 1
end
else do
m.m.rbaRange = m.m.rbaRange + di
end
return
endProcedure recStatsRange
recStatsEoj: procedure expose m.
parse arg m, li1
parse var m.li1 e1 'JOB/'job'/STOP' ti e2 'CPU' cMi 'MIN' cSe 'SEC',
'SRB' sMi 'MIN' sSe 'SEC'
if e2 \= '' | \datatype(cMi, 'n') | \datatype(cSe, 'n') ,
| \datatype(sMi, 'n') | \datatype(sSe, 'n') then
call err 'bad eoj line:' m.li1
m.m.cpu = 60*cMi + cSe
m.m.srb = 60*sMi + sSe
return
endProcedure recStatsEoj
recStatsStartJ: procedure expose m.
parse arg m, li1
parse var m.li1 bH ':' bM ':' bS e1 'IEF403I' jo e2,
'- STARTED -' ti sys e3
if \dataType(bH, 'n') | \dataType(bM, 'n') | \dataType(bS, 'n') ,
| e1 \='' | jo ='' | e2 \='' | ti ='' | sys ='' | e2 \='' then
call err 'bad job ... started line:' m.li1
m.m.system = sys
m.m.job = jo
m.m.started = strip(bH':'bM':'bS)
m.m.ended = strip(eH':'eM':'eS)
return
09:10:17 IEF403I A540769R - STARTED - TIME=09.10.17 S12
09:11:56 IEF404I A540769R - ENDED - TIME=09.11.56 S12
endProcedure recStatsStartJ
recStatsEndJ: procedure expose m.
parse arg m, li1
parse var m.li1 eH ':' eM ':' eS e1 'IEF404I' eJ e2 '- ENDED -' ti
if \dataType(eH, 'n') | \dataType(eM, 'n') | \dataType(eS, 'n') ,
| e1 \='' | eJ \= m.m.job | e2 \='' | ti ='' then
call err 'bad job ... ended line:' m.li2
parse var m.m.started bH ':' bM ':' bS
m.m.elapsed = ((eH * 60) + eM) * 60 + eS ,
- (((bH * 60) + bM) * 60 + bS)
return
endProcedure recStatsEndJ
/* rexx ****************************************************************
wsh
***********************************************************************/
/*--- main code wsh --------------------------------------------------*/
call errReset 'h'
parse arg fun rest
os = errOS()
if 0 then do /* for special tests */
.output$mc$lineOut('hello walti')
x = .output
say .output$mc$class()
say x$mc$class()
x = file('&out')
call jWrite x, 'hallo walti'
call jClose x
exit
end
if 0 then do
call tstSort
call envIni
call tstFile
call tstTotal
exit
end
if 0 then do
do 2
call tstAll
end
exit
end
if 0 then do
call compIni
call tstScanWin
exit
call envIni
call tstFile
call tstFileList
call tstTotal
exit
call tstAll
call envIni
call tstTotal
exit
end
call compIni
/* if os == 'TSO' then
call oSqlIni
*/ if fun = '' & os == 'TSO' then do /* z/OS edit macro */
parse value wshEditMacro() with done fun rest
if done then
return
end
fun = translate(fun)
if fun = '' then
fun = 'S'
if fun = 'S' | fun = 'D' then /* batch interface */
if os == 'TSO' then
exit wshBatchTSO(fun)
else if os == 'LINUX' then
exit wshBatch(fun, '<-%' file('&in'), '>-%' file('&out'))
else
call err 'implemnt wshBatch' os
if wordPos(fun, 'R E S D') > 0 then /* interpreter */
exit wshInter('-'fun rest)
if wordPos(fun, '-R -E -S -D') > 0 then
exit wshInter(fun rest)
if \ abbrev(fun, 'T') then
call err 'bad fun' fun 'in arg' arg
if fun <> 'T' then do /* list of tests */
c = call fun rest
end
else do
c = ''
do wx=1 to words(rest)
c = c 'call tst'word(rest, wx)';'
end
if c = '' then
c = call 'tstAct;'
else if wx > 2 then
c = c 'call tstTotal;'
end
say 'wsh interpreting' c
interpret c
exit 0
/*--- actual test case ----------------------------------------------*/
tstAct: procedure expose m.
call classOut m.class.class, m.class.class
return 0
endProcedure tstAct
/*--- batch: compile shell or data from inp and
run it to output out -----------------------------------*/
wshBatch: procedure expose m.
parse upper arg ty, inp, out
i = cat(inp)
cmp = comp(i)
if pos('D', ty) || pos('d', ty) > 0 then
ty = 'd'
else
ty = 's'
r = compile(cmp, ty)
if out \== '' then
call envPush out
call oRun r
if out \== '' then
call envPop
return 0
endProcedure wshBatch
/*--- interpret user input: rexx, expr, data or shell ---------------*/
wshInter: procedure expose m.
parse arg inp
do forever
w1 = translate(word(inp, 1))
if abbrev(w1, '-') then do
mode = substr(w1, 2)
inp = subWord(inp, 2)
if mode = '' then
return 0
end
if inp <> '' then do
say 'as' mode 'interpreting' inp
if mode = 'R' then
interpret inp
else if mode = 'E' then
interpret 'say' inp
else if mode = 'S' | mode = 'D' then do
call errReset 'h', 'say "******* intercepting error";',
'call errSay ggTxt; return "";'
call oRun compile(comp(jBuf(inp)),
, translate(mode, 'ds', 'DS'))
call errReset 'h'
end
else
say 'mode' mode 'not implemented yet'
end
say 'enter' mode 'expression, - for end, -r or -e for Rexx' ,
'-s or -d for WSH'
parse pull inp
end
endProcedure wshInter
/*--- batch under tso: input dd(WSH), output dd(OUT) if allocated ---*/
wshBatchTSO: procedure expose m.
parse upper arg ty
i = cat("-WSH")
useOut = listDsi('OUT FILE')
if \ (useOut = 16 & sysReason = 2) then
out = '> -out'
else
out = ''
call wshBatch ty, '< -wsh', out
return 0
endProcedure wshBatchTso
/*--- if we are called
not as editmacro return 0
as an editmacro with arguments: return 0 arguments
without arguments: run editMacro interface ------------------*/
wshEditMacro: procedure expose m.
if \ (adrEdit('macro (mArgs) NOPROCESS', '*') == 0) then
return 0
if mArgs \== '' then
return 0 mArgs
call adrEdit '(d) = dataset'
call adrEdit '(m) = member'
if dsnSetMbr(d, m) = 'A540769.WK.REXX(WSH)' then
return 0
call adrIsp 'control errors return'
pc = adrEdit("process dest range Q", 0 4 8 12 16)
dst = ''
if pc = 0 | pc = 8 then do
call adrEdit "(rFi) = lineNum .zFrange"
call adrEdit "(rLa) = lineNum .zLrange"
if pc = 0 then
call adrEdit "(dst) = lineNum .zDest"
else
dst = rLa
end
else if pc = 12 then do
if adrEdit("find first '$***out' 1", 4) = 0 then do
call adrEdit "(dst) = cursor"
call adrEdit "(li) = line" dst
li = overlay(date(s) time(), li, 20)
call adrEdit "line_before" dst "= (li)"
rFi = 1
rLa = dst-1
end
end
if dst = '' then
msg = 'bitte Bereich mit q oder qq auswaehlen ???' rc ,
'oder $***out Zeile einfuegen'
else if rLa < rFi then
msg = 'firstLine' rFi 'before last' rLa
else
msg = ''
if msg \== '' then do
say msg
return 4
end
/* say 'range' c1 'rc' pc':' rFi '-' rLa 'after' dst */
i = jOpen(jBuf(), m.j.cWri)
o = jBuf()
do lx=rFi to rLa
call adrEdit "(li) = line" lx
call jWrite i, li
end
cmp = comp(jClose(i))
if pos('D', mArgs) > 0 then
ty = 'd'
else
ty = 's'
call errReset 'h',
, 'return wshEditCompErrH(ggTxt, ' rFi',' rLa')'
r = compile(cmp, ty)
call errReset 'h',
, 'return wshEditRunErrH(ggTxt, ' quote(o)',' dst')'
call envPush '>%' o
call oRun r
call envPop
lab = wshEditInsLinSt(dst+1, , o'.BUF')
call wshEditLocate dst-7
return 1
endProcedure wshEditMacro
wshEditLocate: procedure
parse arg ln
call adrEdit '(la) = linenum .zl'
if la < 40 then
return
if ln < 7 then
ln = 1
else
ln = min(ln, la - 40)
call adrEdit 'locate ' ln
return
endProcedure wshEditLocate
wshEditCompErrH: procedure expose m.
parse arg ggTxt, rFi, rLa
call errReset 'h'
oo = outDest('=')
call outDest 'i', outDest()';'outDest('s', mCut(ggStem, 0))
call errSay 'compErr' ggTxt
call outDest 'i', oo
parse var m.ggStem.3 "pos " pos . " in line " lin":"
if pos = '' then do
parse var m.ggStem.3 " line " lin":"
pos = 0
end
lab = rFi + lin
if pos \= '' then
lab = wshEditInsLin(lab, 'msgline', right('*',pos))
lab = wshEditInsLinSt((rFi+lin), 'msgline', ggStem)
call wshEditLocate rFi+lin-25
exit 0
endSubroutine wshEditCompErrH
wshEditRunErrH: procedure expose m.
parse arg ggTxt, so, dst
call errReset 'h'
call errSay ggTxt, '*** run error'
lab = wshEditInsLinSt(dst+1, , so'.BUF')
call outDest 's', mCut(ggStem, 0)
call errSay ggTxt, '*** run error'
call wshEditInsLinSt dst+1, msgline, ggStem
exit 0
endSubroutine wshEditRunErrH
wshEditInsLinCmd: procedure
parse arg wh
if dataType(wh, 'n') then do
if adrEdit("label" wh "= .a", 0 8 12) \= 12 then
return 'line_before .a ='
else
return 'line_after .zl ='
end
else if left(wh, 1) == '.' then
return 'line_before' wh '='
else
return wh
endProcedure wshEditInsLinCmd
wshEditInsLin: procedure
parse arg wh, type
cmd = wshEditInsLinCmd(wh)
do ax=3 to arg()
li = strip(arg(ax), 't')
if li == '' then
iterate
if translate(type) = 'MSGLINE' then do while length(li) > 72
sx = lastPos(' ', li, 72)
if sx < 10 then
sx = 72
one = left(li, sx)
li = ' 'strip(substr(li, sx))
call adrEdit cmd type "(one)"
end
call adrEdit cmd type "(li)", 0 4
end
return cmd
endProcedure wshEditInsLin
wshEditInsLinSt: procedure expose m.
parse arg wh, type, st
cmd = wshEditInsLinCmd(wh)
do ax=1 to m.st.0
call wshEditInsLin cmd, type, m.st.ax
end
return cmd
endProcedure wshEditInsLinSt
/*** end wsh, begin all copies ****************************************/
/* copy tstAll begin *************************************************/
tstAll: procedure expose m.
call tstBase
call tstComp
call tstDiv
return 0
endProcedure tstAll
/* copx tstZos begin **************************************************/
tstZOs:
call sqlIni
call tstSql
call tstSqlO
call tstSqlEnv
call tstTotal
return
endProcedure tstZOs
tstWshBatch:
call adrTso 'alloc dd(WSH) shr dsn(WK.TEXT(WSHBATCH))'
call wshBatch
return adrTso('free dd(WSH)')
tstLmdTiming:
parse arg lev
say timing() lev
call lmdBegin abc, lev
c = 0
do while lmdNext(abc, st.)
c = c + st.0
end
call lmdEnd abc
say timing() lev 'with group - without reading' c
call adrIsp 'lmdinit listid(lmdId) level('lev')'
do c=0 while adrIsp('lmdlist listid(&lmdId) dataset(abc)', 8) = 0
end
call adrIsp 'lmdfree listid(&lmdId)'
say timing() lev 'with list' c
return
endProcedure lmdTiming
tstCsi: procedure expose m.
if 0 then do
call lmd 'A540769.*K'
call tstCsiCla 'A540769.WK.REXX'
call tstCsiCla 'A540769.AAA.DATASETS'
call tstCsiCla 'A540769.RRR.DATASETS'
end
if 0 then do
call tstCsiOpNx 'A540769.WK.*E*'
call tstCsiOpNx 'A540769.AAA.DATASETS'
call tstCsiOpNx 'A540769.RRR.DATASETS'
end
if 1 then do
call tstCsiNxCl 'A540769.WK.**'
call tstCsiNxCl 'DBTF.M*.**'
call tstCsiNxCl 'DBTF.BE*.**'
end
return
tstCsi: procedure expose m.
/* call lmd 'A540769.*K' */
call tstCsi1 'A540769.WK.REXX'
call tstCsi1 'A540769.AAA.DATASETS'
call tstCsi1 'A540769.RRR.DATASETS'
return
tstCsiCla:
parse arg ds
say ds '-->' csiCla(ds)
return
tstCsiOpNx: procedure expose m.
parse arg ds
m = 'NUE123'
s = 'res89'
flds = 'devtyp volser mgmtclas comudsiz NOBYTTRK UDATASIZ HARBA'
say 'csiOpen' ds
call csiOpen m, ds, flds
do while csiNext(m, s)
say m.s 'dev' c2x(m.s.devTyp) ,
'vol' m.s.volSer 'cla' m.s.mgmtclas,
'comuDsiz' m.s.comuDsiz 'noBytTrk' m.s.noBytTrk,
'udatasiz' c2x(m.s.udatasiz) ,
'harba' c2x(m.s.harba)
end
return
tstCsiNxCl: procedure expose m.
parse arg ds
m = 'ABC123'
s = 'efg89'
flds = 'devtyp volser mgmtclas'
say 'csiOpen' ds
call csiOpen m, ds, flds
say timing() 'begin'
do i=1 while csiNext(m, s)
nn = csiArcTape(m.s.volser, m.s.mgmtClas, m.s.devtyp, m.s)
/* oo = csiCla(strip(m.s))
if oo <> nn then
say nn '<>' oo m.s
*/ if i // 1000 = 0 then
say timing() i nn m.s
end
say timing() (i-1) nn m.s
return
endProcedure tstCsiNxCl
listCatClass: procedure expose m.
parse upper arg dsn
call outtrap x., '*'
call adrTso "listcat volume entry('"dsn"')", 4
rt = rc
call outtrap off
/* say 'listct rc =' rt 'lines' x.0 */
cl = ''
vo = ''
if word(x.1, 3) \== dsn then
call jOut 'err ??? for dsn' dsn 'bad first line' x.1
else if pos('NOT FOUND', x.1) > 0 then
return 'notFound'
else if word(x.1, 1)\== 'NONVSAM' then
call jOut 'err ??? for dsn' dsn 'bad first line' x.1
do x=2 to x.0 while vo = '' & left(x.x, 1) = ' '
/* say x.x */
p = pos('MANAGEMENTCLASS-', x.x)
if p > 0 then
vo = strip(word(substr(x.x, p+16), 1), 'l', '-')
p = pos('VOLSER--', x.x)
if p > 0 then
vo = strip(word(substr(x.x, p+6), 1), 'l', '-')
p = pos('DEVCLASS--', x.x)
dt = strip(word(substr(x.x, p+8), 1), 'l', '-')
end
/* say 'lc' cl 'vo' vo 'dt' dt 'dsn' dsn */
if vo = '' then
call jOut '??? err no volume for dsn' dsn
else if vo = 'ARCIVE' then
res = 'arcive'
else if cl = '' then
res = 'tape'
else
res = cl
if abbrev(res, 'ar') \= abbrev(dt, "X'0") ,
| abbrev(res, 'ta') \= abbrev(dt, "X'7") ,
| (left(res, 1) >= 'A') \= abbrev(dt, "X'3") then
call jOut 'err ??? mismatch cl' cl 'vo' vo 'dt' dt 'dsn' dsn
return res
endProcedure listCatClass
/* copx tstZos end **************************************************/
/* copx tstDiv begin **************************************************/
tstDiv:
call tstSort
call tstMatch
call tstTotal
return
endProcedure tstDiv
tstSort: procedure expose m.
/*<<tstSort
### start tst tstSort #############################################
sort 29 c ACHT DREI DREIZEHN EINS ELF FUENF M.I.25 M.I.26 M.I.27 M+
..I.29 NEUN SECHS SIEBEN VIER VIERZEHN ZEHN ZWEI ZWOELF 0 1 1 1 2 2+
. 3 3 4 4
sort 22 c ACHT DREIZEHN ELF M.I.25 M.I.26 M.I.27 M.I.29 NEUN VIERZ+
EHN ZEHN ZWOELF 0 1 1 1 2 2 3 3 4 4
sort 15 c M.I.25 M.I.26 M.I.27 M.I.29 0 1 1 1 2 2 3 3 4 4
sort 8 c M.I.25 M.I.26 M.I.27 M.I.29 0 1 1
sort 1 M.I.29
tstSort */
/*<<tstSortAscii
### start tst tstSortAscii ########################################
sort 29 0 1 1 1 2 2 3 3 4 4 ACHT DREI DREIZEHN EINS ELF FUENF M.I.+
25 M.I.26 M.I.27 M.I.29 NEUN SECHS SIEBEN VIER VIERZEHN ZEHN ZWEI Z+
WOELF c
sort 22 0 1 1 1 2 2 3 3 4 4 ACHT DREIZEHN ELF M.I.25 M.I.26 M.I.27+
. M.I.29 NEUN VIERZEHN ZEHN ZWOELF c
sort 15 0 1 1 1 2 2 3 3 4 4 M.I.25 M.I.26 M.I.27 M.I.29 c
sort 8 0 1 1 M.I.25 M.I.26 M.I.27 M.I.29 c
sort 1 M.I.29
tstSortAscii */
if errOS() == 'LINUX' then
call tst t, "tstSortAscii"
else
call tst t, "tstSort"
call mAdd mCut(i, 0), eins, zwei, drei, vier, fuenf, sechs,
,sieben, acht, neun, zehn, elf, zwoelf, dreizehn, vierzehn
call mAdd i, 1, 2, 3, 4, 4, 3, 2, 1, 0, 1,
, 'M.I.25', 'M.I.26', 'M.I.27', 'c', 'M.I.29'
do yy = m.i.0 by -1 to 1
do x = 0 to yy
m.i.0 = x
call sort i, o
m = ''
la = ''
if x <> m.o.0 then
call err 'size mismatch' x '<>' m.o.0
do y=1 to m.o.0
m = m m.o.y
if \ (la << m.o.y) then
call err 'sort mismatch' yy x y '\' la '<<' m.o.y
end
end
if yy // 7 = 1 then
call tstOut t, 'sort' yy m
do x = 2 to yy
x1 = x-1
m.i.x1 = m.i.x
end
end
call tstEnd t
return
endProcedure tstSort
tstMatch: procedure expose m.
/*<<tstMatch
### start tst tstMatch ############################################
match(eins, e?n*) 1 1 2,i,s trans(E?N*) EiNs
match(eins, eins) 1 1 0 trans(EINS) EINS
match(e1nss, e?n*) 1 1 2,1,ss trans(?*) 1ss
match(eiinss, e?n*) 0 0 -9
match(einss, e?n *) 0 0 -9
match(ein s, e?n *) 1 1 2,i,s trans(E?N *) EiN s
match(ein abss , ?i*b*) 1 1 3,e,n a,ss trans(?I*B*) eIn aBss .
match(ein abss wie gehtsssxdirx und auch , ) 0 0 -9
match(ies000, *000) 1 1 1,ies trans(*000) ies000
match(xx0x0000, *000) 1 1 1,xx0x0 trans(*000) xx0x0000
match(000x00000xx, 000*) 1 1 1,x00000xx trans(000*) 000x00000xx
match(000xx, *0*) 1 1 2,00,xx trans(ab*cd*ef) ab00cdxxef
tstMatch */
call tst t, "tstMatch"
call tstOut t, matchTest1('eins', 'e?n*' )
call tstOut t, matchTest1('eins', 'eins' )
call tstOut t, matchTest1('e1nss', 'e?n*', '?*' )
call tstOut t, matchTest1('eiinss', 'e?n*' )
call tstOut t, matchTest1('einss', 'e?n *' )
call tstOut t, matchTest1('ein s', 'e?n *' )
call tstOut t, matchTest1('ein abss ', '?i*b*' )
call tstOut t, matchTest1('ein abss wie gehtsssxdirx und auch ' )
call tstOut t, matchTest1('ies000', '*000' )
call tstOut t, matchTest1('xx0x0000', '*000' )
call tstOut t, matchTest1('000x00000xx', '000*' )
call tstOut t, matchTest1('000xx', '*0*', 'ab*cd*ef' )
call tstEnd t
return
matchTest1:
parse arg w, m, m2
r = 'match('w',' m')' match(w, m) match(w, m, vv) m.vv.0
do x=1 to m.vv.0
r = r','m.vv.x
end
if m2 = '' then
m2 = translate(m)
if m.vv.0 >= 0 then
r = r 'trans('m2')' matchTrans(m2, vv)
return r
endProcedure matchTest1
/* copx tstDiv end **************************************************/
/* copx tstSql begin **************************************************/
tstSqlUtils: procedure expose m.
call sqlConnect 'DBAF'
id = 'A540769.dsnUtils'
rst = 'NO'
retcode = -9876
e = ''
z = 0
st = "TEMPLATE TCOPYD",
"DSN('&SSID..&JO..&US..P&PART(2)..D&DATE(3)..T&TIME.')",
"DATACLAS(NULL12) MGMTCLAS(COM#A011) STORCLAS(FAR$N)",
"SPACE (150,3750) TRK UNCNT 59;",
"listdef abc include tablespace DA540769.A002* partlevel;",
"listdef mf include tablespace MF01A1A.A110A partlevel;",
"copy list abc copyddn(tcopyd) shrlevel change;"
st = translate(st)
call sqlExec "call SYSPROC.DSNUTILS ( :id, :rst,",
":st,:retcode, :ANY" copies(',:e,:e,:z',12) ")"
call sqlExec ,
'ASSOCIATE LOCATOR (:RESULTS) WITH PROCEDURE SYSPROC.DSNUTILS'
say 'results' results
call sqlExec 'ALLOCATE C111 CURSOR FOR RESULT SET :RESULTS'
say 'allocated c111'
do while sqlExec('fetch c111 into :seq, :txt', 0 100) = 0
say 'sysPrint' seq strip(txt, 't')
end
call sqlExec 'close c111'
say 'closed'
call sqlDisconnect
exit
endProcedure tstSqlUtils
tstSqlStored: procedure expose m.
call sqlConnect 'DBAF'
rst = 'NO'
retcode = -9876
e = ''
z = 0
st = "abc"
call sqlExec "call SYSPROC.COMMAND ( :st, :rst)"
say 'after call st='st 'rst='rst
call sqlExec ,
'ASSOCIATE LOCATOR (:RESULTS) WITH PROCEDURE SYSPROC.COMMAND'
say 'results' results
call sqlExec 'ALLOCATE C111 CURSOR FOR RESULT SET :RESULTS'
say 'allocated c111'
do while sqlExec('fetch c111 into :seq, :txt', 0 100) = 0
say 'sysPrint' seq strip(txt, 't')
end
call sqlExec 'close c111'
say 'closed'
call sqlDisconnect
return
endProcedure tstSqlStored
tstSqlStoredWK: procedure expose m.
call sqlConnect 'DBAF'
/* st = "direct wkUtiSub"
rst = 'NO'
say 'before call st='st 'rst='rst
call sqlExec "call A540769.WKUTILSUB ( :st, :rst)"
say 'after call st='st 'rst='rst
*/ rst = 'NO'
retcode = -9876
e = ''
z = 0
prc = 'DB2UTIL.DB2UTIL'
st = "DA540769.A2*" /* DA540769.A1*" */
say "call" prc "("st", ...)"
call sqlExec "call" prc "(:st, :rst)"
say 'after call st='st 'rst='rst
call sqlExec ,
'ASSOCIATE LOCATOR (:RESULTS) WITH PROCEDURE' prc
/* say 'results' results */
call sqlExec 'ALLOCATE C111 CURSOR FOR RESULT SET :RESULTS'
say ''
say '***** utility output'
do while sqlExec('fetch c111 into :seq, :txt', 0 100) = 0
say 'sysPrint' seq strip(txt, 't')
end
call sqlExec 'close c111'
say '***** end output'
call sqlDisconnect
return 0
endProcedure tstSqlStoredWK
tstSqlStoredSQL1: procedure expose m.
call sqlConnect 'DBIA'
rst = 'NO'
retcode = -9876
e = ''
z = 0
st = "DA540769.A2* DA540769.A1*"
call sqlExec "call A540769.WKSQL1 ( :st, :rst)"
say 'after call st='st 'rst='rst
call sqlExec ,
'ASSOCIATE LOCATOR (:RESULTS) WITH PROCEDURE A540769.WKUTIL'
say 'results' results
call sqlExec 'ALLOCATE C111 CURSOR FOR RESULT SET :RESULTS'
say 'allocated c111'
do while sqlExec('fetch c111 into :seq, :txt', 0 100) = 0
say 'sysPrint' seq strip(txt, 't')
end
call sqlExec 'close c111'
say 'closed'
call sqlDisconnect
return
endProcedure tstSqlStoredSQL1
tstSqlTriggerTiming:
parse upper arg tb ni
m.noInsert = ni == 0
cnt = 200000
if tb = '' then
TB = 'GDB9998.TWK511TRI'
call sqlConnect dbaf
say timing() 'noInsert' m.noInsert 'tb' tb
call sql2St 49, '*', cc, 'select max(pri) MX from' tb
if m.cc.1.mx == m.sqlNull then
m.cc.1.mx = 0
von = m.cc.1.mx + 1
bis = m.cc.1.mx + cnt
say m.cc.0 'max' m.cc.1.mx 'von' von 'bis' bis 'count' cnt tb
if right(tb, 2) = 'A1' then do
call sqlPrepare 3, 'insert into' tb '(pri, short, long, par)' ,
'values (?, ?, ?, ?)'
do ax=von to bis
call sqlExecute 3, ax,
, ax 'wsh short', ax 'wsh long long long long long ',
, (ax-1) // 1000 + 1
end
end
else do
call sqlPrepare 3, 'insert into' tb '(pri, short, long)' ,
'values (?, ?, ?)'
do ax=von to bis
call sqlExecute 3, ax,
, ax 'wsh short', ax 'wsh long long long long long ',
, (ax-1) // 1000 + 1
end
end
/* call sqlLn 5,,, 'select * from' tb 'where pri >=' von */
call sqlExImm 'commit'
say timing()
call sqlDisconnect
return
endProcedure tstSqlTriggerTiming
tstSql: procedure expose m.
cx = 2
/*<<tstSql
### start tst tstSql ##############################################
*** err: sqlCode -204 A540769.SYSDUMMY IS AN UNDEFINED NAME .
. e 1: warnings
. e 2: state 42704
. e 3: stmt = execSql prepare s7 from :src
. e 4: with src = select * from sysdummy
fetchA 1 ab= m.abcdef.123.AB abc ef= efg
fetchA 0 ab= m.abcdef.123.AB abc ef= efg
sqlVars :M.STST.A :M.STST.A.SQLIND, :M.STST.B :M.STST.B.SQLIND, +
:M.STST.C :M.STST.C.SQLIND
1 all from dummy1
a=a b=2 c=0
sqlVarsNull 1
a=a b=2 c=---
fetchBT 1 SYSTABLES
fetchBT 0 SYSTABLES
fetchBI 1 SYSINDEXES
fetchBI 0 SYSINDEXES
opAllCl 3
fetchC 1 SYSTABLES
fetchC 2 SYSTABLESPACE
fetchC 3 SYSTABLESPACESTATS
PreAllCl 3
fetchD 1 SYSIBM.SYSTABLES
fetchD 2 SYSIBM.SYSTABLESPACE
fetchD 3 SYSIBM.SYSTABLESPACESTATS
tstSql */
call tst t, "tstSql"
call sqlConnect 'DBAF'
src = 'select * from sysdummy'
call sqlExec 'prepare s7 from :src'
call sqlPrepare cx, "select 'abc' , 'efg'",
'from sysibm.sysDummy1'
call sqlExec 'declare c'cx 'cursor for s'cx
call sqlOpen cx
a = 'abcdef'
b = 123
do i=1 to 2
call jOut 'fetchA' sqlFetchInto(cx, ':m.a.b.ab, :m.a.b.ef') ,
'ab= m.'a'.' || b'.'ab m.a.b.ab 'ef=' m.a.b.ef
end
call sqlClose cx
drop stst a b c m.stst.a m.stst.b m.stst.c
sv = sqlVars('M.STST', A B C , 1)
call jOut 'sqlVars' sv
call jOut sqlPreAllCl(cx,
, "select 'a', 2, case when 1=0 then 1 else null end ",
"from sysibm.sysDummy1",
, stst, sv) 'all from dummy1'
call jOut 'a='m.stst.a 'b='m.stst.b 'c='m.stst.c
call jOut 'sqlVarsNull' sqlVarsNull(stst, A B C)
call jOut 'a='m.stst.a 'b='m.stst.b 'c='m.stst.c
call sqlPreDeclare cx, "select name" ,
"from sysibm.sysTables" ,
"where creator = 'SYSIBM' and name = ?"
call sqlOpen cx, 'SYSTABLES'
call jOut 'fetchBT' sqlFetchInto(cx, ':NM') nm
call jOut 'fetchBT' sqlFetchInto(cx, ':NM') nm
call sqlClose cx
call sqlOpen cx, 'SYSINDEXES'
a = 'a b c'
b = 1234565687687234
call jOut 'fetchBI' sqlFetchInto(cx, ':NM') nm
call jOut 'fetchBI' sqlFetchInto(cx, ':NM') nm
call sqlClose cx
src = "select name" ,
"from sysibm.sysTables" ,
"where creator = 'SYSIBM' and name like 'SYSTABLES%'",
"fetch first 3 rows only"
call sqlPreDeclare cx, src
st = 'wie geht'' s'
call jOut 'opAllCl' sqlOpAllCl(cx, st, ':M.ST.SX.NAME')
do x=1 to m.st.0
call jOut 'fetchC' x m.st.x.name
end
st = 'auch noch'
src = "select strip(creator) || '.' || strip(name)" substr(src,12)
call jOut 'PreAllCl' sqlPreAllCl(cx+11, src, st, ':M.ST.SX.NAME')
do x=1 to m.st.0
call jOut 'fetchD' x m.st.x.name
end
call sqlDisconnect
call tstEnd t
return
endProcedure tstSql
tstSqlO: procedure expose m.
/*<<tstSqlO
### start tst tstSqlO #############################################
*** err: sqlCode -204 A540769.SYSDUMMY IS AN UNDEFINED NAME .
. e 1: warnings
. e 2: state 42704
. e 3: stmt = execSql prepare s7 from :src
. e 4: with src = select * from sysdummy
REQD=Y col=123 case=--- col5=anonym
NAME T DBNAME TSNAME .
SYSTABAUTH T DSNDB06 SYSDBASE .
SYSTABCONST T DSNDB06 SYSOBJ .
SYSTABLEPART T DSNDB06 SYSDBASE .
SYSTABLEPART_HI T DSNDB06 SYSHIST .
SYSTABLES T DSNDB06 SYSDBASE .
NAME T DBNAME TSNAME .
SYSTABAUTH T DSNDB06 SYSDBASE
SYSTABCONST T DSNDB06 SYSOBJ .
SYSTABLEPART T DSNDB06 SYSDBASE
SYSTABLEPART_HIST T DSNDB06 SYSHIST .
SYSTABLES T DSNDB06 SYSDBASE
tstSqlO */
call tst t, "tstSqlO"
call sqlConnect 'DBAF'
src = 'select * from sysdummy'
call sqlExec 'prepare s7 from :src'
call sql2Cursor 13,
, 'select d.*, 123, current timestamp "jetzt und heute",',
'case when 1=0 then 1 else null end caseNull,',
"'anonym'" ,
'from sysibm.sysdummy1 d'
call sqlOpen 13
do while sqlFetch(13, abc)
call jOut 'REQD='m.ABC.IBMREQD 'col='m.ABC.col2,
'case='m.ABC.CASENULL,
'col5='m.ABC.col5
je = 'jetzt'
jetzt = m.ABC.je
dd = date('s')
dd = left(dd, 4)'-'substr(dd, 5, 2)'-'right(dd, 2)'-' ,
|| left(time(), 2)'.'
say 'jetzt='jetzt 'date time' dd
if \ abbrev(jetzt, dd) then
call err 'date mismatch abbrev' dd
end
call sqlClose 13
call sql2Cursor 13 ,
, 'select name, class, dbName, tsName' ,
/* ,alteredTS, obid, cardf'*/ ,
'from sysibm.systables' ,
"where creator = 'SYSIBM' and name like 'SYSTA%'" ,
"fetch first 5 rows only",
, , 'sl<15'
call sqlOpen 13
call jOut fmtFldTitle(m.sql.13.fmt)
do while sqlFetchLn(13, li)
call jOut m.li
end
call sqlClose 13
call sqlGenFmt m.sql.13.fmt, 13, 'sst'
call sqlOpen 13
do ix=1 while sqlFetch(13, fe.ix)
end
m.fe.0 = ix-1
call fmtFldSquash sqFmt, sqlClass(13), fe
call jOut fmtFldTitle(sqFmt)
do ix=1 to m.fe.0
call jOut oFldCat(sqlClass(13), fe.ix, sqFmt)
end
call sqlClose 13
if 0 then do
call sql2Cursor 13 ,
, 'select *',
'from sysibm.systables' ,
"where creator = 'SYSIBM' and name like 'SYSTA%'" ,
"fetch first 1 rows only",
, , 'sl<15'
call sqlOpen 13
call jOut fmtFldTitle(m.sql.13.fmt)
do while sqlFetchLn(13, li)
call jOut m.li
end
call sqlClose 13
end
call sqlDisconnect
call tstEnd t
return
endProcedure tstSqlO
tstSqlEnv: procedure expose m.
/*<<tstSqlEnv
### start tst tstSqlEnv ###########################################
REQD=Y COL2=123 case=--- COL5=anonym
sql fmtFldRw sl<15
NAME T DBNAME TSNAME .
SYSTABAUTH T DSNDB06 SYSDBASE .
SYSTABCONST T DSNDB06 SYSOBJ .
SYSTABLEPART T DSNDB06 SYSDBASE .
SYSTABLEPART_HI T DSNDB06 SYSHIST .
SYSTABLES T DSNDB06 SYSDBASE .
sql fmtFldSquashRW
NAME T DBNAME TSNAME .
SYSTABAUTH T DSNDB06 SYSDBASE
SYSTABCONST T DSNDB06 SYSOBJ .
SYSTABLEPART T DSNDB06 SYSDBASE
SYSTABLEPART_HIST T DSNDB06 SYSHIST .
SYSTABLES T DSNDB06 SYSDBASE
sqlLn sl=
COL1 T DBNAME COL4 .
SYSTABAUTH T DSNDB06 SYSDBASE
SYSTABCONST T DSNDB06 SYSOBJ .
SYSTABLEPART T DSNDB06 SYSDBASE
SYSTABLEPART_ T DSNDB06 SYSHIST .
SYSTABLES T DSNDB06 SYSDBASE
sqlLn ---
NAME T DBNAME TSNAME .
SYSTABAUTH T DSNDB06 SYSDBASE
SYSTABCONST T DSNDB06 SYSOBJ .
SYSTABLEPART T DSNDB06 SYSDBASE
SYSTABLEPART_HIST T DSNDB06 SYSHIST .
SYSTABLES T DSNDB06 SYSDBASE
tstSqlEnv */
call tst t, "tstSqlEnv"
call sqlConnect 'DBAF'
call envBarBegin
call jOut 'select d.*, 123, current timestamp "jetzt und heute",'
call jOut 'case when 1=0 then 1 else null end caseNull,'
call jOut "'anonym'"
call jOut 'from sysibm.sysdummy1 d'
call envBar
call sql 13
call envBarLast
do while envRead(abc)
call jOut 'REQD='envGet('ABC.IBMREQD'),
'COL2='envGet('ABC.COL2'),
'case='envGet('ABC.CASENULL'),
'COL5='envGet('ABC.COL5')
jetzt = envGet('ABC.jetzt')
say 'jetzt='jetzt
dd = date('s')
dd = left(dd, 4)'-'substr(dd, 5, 2)'-'right(dd, 2)'-' ,
|| left(time(), 2)'.'
if \ abbrev(jetzt, dd) then
call err 'date mismatch abbrev' dd
end
call envBarEnd
call jOut 'sql fmtFldRw sl<15'
call envBarBegin
call jOut 'select name, class, dbName, tsName'
/* ,alteredTS, obid, cardf'*/
call jOut 'from sysibm.systables'
call jOut "where creator = 'SYSIBM' and name like 'SYSTA%'"
call jOut "fetch first 5 rows only"
call envBar
call sql 13
call envBarLast
call fmtFldRW sqlGenFmt(fmtAbc, 13, 'sl<15')
call envBarEnd
call jOut 'sql fmtFldSquashRW'
call envBarBegin
call jOut 'select name, class, dbName, tsName'
/* ,alteredTS, obid, cardf'*/
call jOut 'from sysibm.systables'
call jOut "where creator = 'SYSIBM' and name like 'SYSTA%'"
call jOut "fetch first 5 rows only"
call envBar
call sql 13
call envBarLast
call fmtFldSquashRW
call envBarEnd
call jOut 'sqlLn sl='
call envBarBegin
call jOut 'select char(name, 13), class, dbName, char(tsName, 8)'
/* ,alteredTS, obid, cardf'*/
call jOut 'from sysibm.systables'
call jOut "where creator = 'SYSIBM' and name like 'SYSTA%'"
call jOut "fetch first 5 rows only"
call envBarLast
call sqlLn 13, , ,'sl='
call envBarEnd
call jOut 'sqlLn ---'
call envBarBegin
call jOut 'select name, class, dbName, tsName'
/* ,alteredTS, obid, cardf'*/
call jOut 'from sysibm.systables'
call jOut "where creator = 'SYSIBM' and name like 'SYSTA%'"
call jOut "fetch first 5 rows only"
call envBarLast
call sqlLn 13
call envBarEnd
call sqlDisconnect
call tstEnd t
return
endProcedure tstSqlEnv
/* copx tstSql end ***************************************************/
/* copx tstComp begin **************************************************
test the wsh compiler
***********************************************************************/
tstComp: procedure expose m.
call compIni
call tstCompDataConst
call tstCompDataVars
call tstCompShell
call tstCompPrimary
call tstCompStmt
call tstCompDataIO
call tstCompPipe
call tstCompRedir
call tstCompComp
call tstTotal
return
endProcedure tstComp
tstCompRun: procedure expose m.
parse arg class cnt
src = jBuf()
call jOpen src, m.j.cWri
do sx=2 to arg()
call jWrite src, arg(sx)
end
cmp = comp(jClose(src))
call jOut 'compile' class',' (sx-2) 'lines:' arg(2)
r = compile(cmp, class)
say "compiled: >>>>" r "<<<<" m.r.code
call jOut "run without input"
call mCut 'T.IN', 0
call oRun r
if cnt == 3 then do
call jOut "run with 3 inputs"
call mAdd 'T.IN', "eins zwei drei", "zehn elf zwoelf?",
, "zwanzig 21 22 23 24 ... 29|"
m.t.inIx = 0
call oRun r
end
return
endProcedure tstCompRun
tstCompDataConst: procedure expose m.
/*<<tstCompDataConst
### start tst tstCompDataConst ####################################
compile d, 8 lines: Lline one, $** asdf
run without input
. Lline one, .
line two..
line threecontinued on 4
line five fortsetzung
line six fortsetzung
tstCompDataConst */
call tst t, 'tstCompDataConst'
call tstCompRun 'd' ,
, ' Lline one, $** asdf',
, 'line two.',
, 'line three$*+ bla bla' ,
, 'continued on 4',
, 'line five $*( und so',
, 'weiter $abc $? $''$*)'' $"$*)" und weiter $*) fortsetzung',
, 'line six $*( und $*( $** $*( so',
, 'weiter $abc $? $*)'' $"$*)" und weiter $*) fortsetzung'
call tstEnd t
return
endProcedure tstCompDataComm
tstCompDataVars: procedure expose m.
/*<<tstCompDataVars
### start tst tstCompDataVars #####################################
compile d, 4 lines: Lline one, $** asdf
run without input
. Lline one, .
lline zwei output
lline 3 .
variable v1 = valueV1 ${v1}= valueV1| .
tstCompDataVars */
call tst t, 'tstCompDataVars'
call tstCompRun 'd' ,
, ' Lline one, $** asdf',
, ' $$ lline zwei output',
, 'lline 3 $=v1= valueV1 ' ,
, 'variable v1 = $v1 $"${v1}=" ${ v1 }| '
call tstEnd t
return
endProcedure tstCompDataVars
tstCompShell: procedure expose m.
/*<<tstCompShell
### start tst tstCompShell ########################################
compile s, 9 lines: $$ Lline one, $** asdf
run without input
Lline one,
lline zwei output
v1 = valueV1 ${v1}= valueV1|
REXX JOUT L5 CONTINUED L6 CONTINUED L7
L8 ONE
L9 END
tstCompShell */
call tst t, 'tstCompShell'
call tstCompRun 's' ,
, ' $$ Lline one, $** asdf',
, ' $$ lline zwei output',
, ' $=v1= valueV1 ' ,
, '$$ v1 = $v1 $"${v1}=" ${ v1 }| ' ,
, 'call jOut rexx jout l5, ' ,
, ' continued l6 , ' ,
, ' continued l7 ' ,
, 'call jOut l8 one ' ,
, 'call jOut l9 end'
call tstEnd t
return
endProcedure tstCompDataVars
tstCompPrimary: procedure expose m.
/*<<tstCompPrimary
### start tst tstCompPrimary ######################################
compile d, 11 lines: Strings $"$""$""""$""" $'$''$''''$'''
run without input
Strings $"$""$" $'$''$'
rexx 3*5 = 15
data line three line four bis hier
shell line five line six bis hier
var get v1 value Eins, v1 value Eins .
var isDef v1 1, v2 0 .
#jIn eof 1#
var read >1 0 rr undefined
#jIn eof 2#
var read >2 0 rr undefined
run with 3 inputs
Strings $"$""$" $'$''$'
rexx 3*5 = 15
data line three line four bis hier
shell line five line six bis hier
var get v1 value Eins, v1 value Eins .
var isDef v1 1, v2 0 .
#jIn 1# eins zwei drei
var read >1 1 rr eins zwei drei
#jIn 2# zehn elf zwoelf?
var read >2 1 rr zehn elf zwoelf?
tstCompPrimary */
call tst t, 'tstCompPrimary'
call envRemove 'v2'
call tstCompRun 'd' 3 ,
, 'Strings $"$""$""""$"""' "$'$''$''''$'''",
, 'rexx 3*5 = $( 3 * 5 $)',
, 'data $-¢ line three',
, 'line four $! bis hier',
, 'shell $-{ $$ line five',
, '$$ line six $} bis hier',
, '$= v1 = value Eins $=rr=undefined',
, 'var get v1 $v1, v1 ${ v1 } ',
, 'var isDef v1 ${? v$( 1 * 1 + 0 $) }, v2 ${?v2 } ',
, 'var read >1 ${> rr} rr $rr' ,
, 'var read >2 ${> rr} rr $rr'
call tstEnd t
return
endProcedure tstCompPrimary
tstCompStmt: procedure expose m.
/*<<tstCompStmt1
### start tst tstCompStmt1 ########################################
compile s, 8 lines: $= v1 = value eins $= v2 % 3*5*7 .
run without input
data v1 value eins v2 105
eins
zwei
drei
vier
fuenf
elf
zwoelf dreiZ .
vierZ .
fuenfZ
lang v1 value eins v2 945
oRun ouput 1
tstCompStmt1 */
call tst t, 'tstCompStmt1'
call envPut 'oRun', oRunner('call jOut "oRun ouput" (1*1)')
call envRemove 'v2'
call tstCompRun 's' ,
, '$= v1 = value eins $= v2 % 3*5*7 ',
, '$$ data v1 $v1 v2 ${ v2 }',
, '$$eins $@{$$ zwei $$ drei ',
, ' $@{ $} $@{ $@{ $$vier $} $} $} $$fuenf',
, '$$elf $@¢ zwoelf dreiZ ',
, ' $@¢ $! $@¢ $@¢ vierZ $! $! $! $$fuenfZ',
, '$% "lang v1" $v1 "v2" ${v2}*9',
, '$@run $oRun'
call tstEnd t
/*<<tstCompStmt2
### start tst tstCompStmt2 ########################################
compile s, 1 lines: $@for qq $$ loop qq $qq
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
loop qq eins zwei drei
#jIn 2# zehn elf zwoelf?
loop qq zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
loop qq zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
tstCompStmt2 */
call tst t, 'tstCompStmt2'
call tstCompRun 's' 3 ,
, '$@for qq $$ loop qq $qq'
call tstEnd t
return
endProcedure tstCompStmt
tstCompDataIO: procedure expose m.
/*<<tstCompDataHereData
### start tst tstCompDataHereData #################################
compile d, 13 lines: herdata $<<stop .
run without input
. herdata .
heredata 1 $x
heredata 2 $y
nach heredata
. herdata ¢ .
heredata 1 xValue
heredata 2 yValueY
nach heredata ¢
. herdata { .
HEREDATA 1 xValue
heredata 2 yValueY
nach heredata {
tstCompDataHereData */
call tst t, 'tstCompDataHereData'
call tstCompRun 'd' ,
, ' herdata $<<stop ',
, 'heredata 1 $x',
, 'heredata 2 $y',
, 'stop $$ nach heredata',
, ' herdata ¢ $<<¢stop ',
, '$=x=xValue$=y=yValueY',
, 'heredata 1 $x',
, 'heredata 2 $y',
, 'stop $$ nach heredata ¢',
, ' herdata { $<<{st',
, 'call jOut heredata 1 $x',
, '$$heredata 2 $y',
, 'st $$ nach heredata {'
call tstEnd t
/*<<tstCompDataIO
### start tst tstCompDataIO #######################################
compile d, 5 lines: input 1 $<$dsn $*+.
run without input
. input 1 .
readInp line 1 .
readInp line 2 .
. nach dsn input und nochmals mit & .
readInp line 1 .
readInp line 2 .
. und schluiss..
tstCompDataIO */
dsn = word(tstPdsMbr(tstFilename('lib37', 'r'), 'readInp'), 1)
dsnFB = dsn tstFB('::F37', 0)
b = jBuf(tstFB('readInp line 1', 37),
,tstFB('readInp line 2', 37))
extFd = tstFB('&dsn('dsn') dd(xyz)', 0)
extFd = tstFB(dsn 'dd(xyz) ::f', 0)
if extFd = '' then
extFd = dsn
call jCat file(dsnFB), b
call envPut 'dsn', dsn
call tst t, 'tstCompDataIO'
call tstCompRun 'd' ,
, ' input 1 $<$dsn $*+',
, tstFB('::f', 0),
, ' nach dsn input und nochmals mit & ' ,
, ' $<'extFD,
, ' und schluiss.'
call tstEnd t
return
endProcedure tstCompDataIO
tstCompPipe: procedure expose m.
/*<<tstCompPipe1
### start tst tstCompPipe1 ########################################
compile s, 1 lines: call envPreSuf "(1 ", " 1)"
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
(1 eins zwei drei 1)
#jIn 2# zehn elf zwoelf?
(1 zehn elf zwoelf? 1)
#jIn 3# zwanzig 21 22 23 24 ... 29|
(1 zwanzig 21 22 23 24 ... 29| 1)
#jIn eof 4#
tstCompPipe1 */
call tst t, 'tstCompPipe1'
call tstCompRun 's' 3 ,
, ' call envPreSuf "(1 ", " 1)"'
call tstEnd t
/*<<tstCompPipe2
### start tst tstCompPipe2 ########################################
compile s, 2 lines: call envPreSuf "(1 ", " 1)"
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
#jIn 2# zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
¢2 (1 eins zwei drei 1) 2!
¢2 (1 zehn elf zwoelf? 1) 2!
¢2 (1 zwanzig 21 22 23 24 ... 29| 1) 2!
tstCompPipe2 */
call tst t, 'tstCompPipe2'
call tstCompRun 's' 3 ,
, ' call envPreSuf "(1 ", " 1)"' ,
, ' $| call envPreSuf "¢2 ", " 2!"'
call tstEnd t
/*<<tstCompPipe3
### start tst tstCompPipe3 ########################################
compile s, 3 lines: call envPreSuf "(1 ", " 1)"
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
#jIn 2# zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
<3 ¢2 (1 eins zwei drei 1) 2! 3>
<3 ¢2 (1 zehn elf zwoelf? 1) 2! 3>
<3 ¢2 (1 zwanzig 21 22 23 24 ... 29| 1) 2! 3>
tstCompPipe3 */
call tst t, 'tstCompPipe3'
call tstCompRun 's' 3 ,
, ' call envPreSuf "(1 ", " 1)"' ,
, ' $| call envPreSuf "¢2 ", " 2!"',
, ' $| call envPreSuf "<3 ", " 3>"'
call tstEnd t
/*<<tstCompPipe4
### start tst tstCompPipe4 ########################################
compile s, 7 lines: call envPreSuf "(1 ", " 1)"
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
#jIn 2# zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
<3 ¢222 ¢221 ¢21 ¢20 (1 eins zwei drei 1) 20! 21! 221! 222! 3>
<3 ¢222 ¢221 ¢21 ¢20 (1 zehn elf zwoelf? 1) 20! 21! 221! 222! 3>
<3 ¢222 ¢221 ¢21 ¢20 (1 zwanzig 21 22 23 24 ... 29| 1) 20! 21! 221!+
. 222! 3>
tstCompPipe4 */
call tst t, 'tstCompPipe4'
call tstCompRun 's' 3 ,
, ' call envPreSuf "(1 ", " 1)"' ,
, ' $| $@{ call envPreSuf "¢20 ", " 20!"',
, ' $| call envPreSuf "¢21 ", " 21!"',
, ' $| $@{ call envPreSuf "¢221 ", " 221!"',
, ' $| call envPreSuf "¢222 ", " 222!"',
, '$} $} ',
, ' $| call envPreSuf "<3 ", " 3>"'
call tstEnd t
return
endProcedure tstCompPipe
tstCompRedir: procedure expose m.
/*<<tstCompRedir
### start tst tstCompRedir ########################################
compile s, 6 lines: $>#eins $@for vv $$<$vv> $; .
run without input
#jIn eof 1#
output eins .
output piped zwei .
run with 3 inputs
#jIn 1# eins zwei drei
#jIn 2# zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
output eins <eins zwei drei> <zehn elf zwoelf?> <zwanzig 21 22 23 2+
4 ... 29|>
output piped zwei ab<eins zwei drei>yz ab<zehn elf zwoelf?>yz ab<zw+
anzig 21 22 23 24 ... 29|>yz
tstCompRedir */
call tst t, 'tstCompRedir'
dsn = word(tstPdsMbr(tstFilename('libvb', 'r'), 'redir1'), 1)
call envPut 'dsn', dsn
call tstCompRun 's' 3 ,
, ' $>#eins $@for vv $$<$vv> $; ',
, ' $$ output eins $-{$<#eins$}$; ',
, ' $@for ww $$b${ww}y ',
, ' $> $dsn 'tstFB('::v', 0),
, '$| call envPreSuf "a", "z" $<# eins',
, '$;$$ output piped zwei $-{$<$dsn$} '
call tstEnd t
return
endProcedure tstCompRedir
tstCompComp: procedure expose m.
/*<<tstCompCompShell
### start tst tstCompCompShell ####################################
compile s, 5 lines: $$compiling shell $; $= rrr = $-cmpShell $<<aaa
run without input
compiling shell
running einmal
RUN 1 COMPILED einmal
#jIn eof 1#
running zweimal
RUN 1 COMPILED zweimal
#jIn eof 2#
run with 3 inputs
compiling shell
running einmal
RUN 1 COMPILED einmal
#jIn 1# eins zwei drei
compRun eins zwei dreieinmal
#jIn 2# zehn elf zwoelf?
compRun zehn elf zwoelf?einmal
#jIn 3# zwanzig 21 22 23 24 ... 29|
compRun zwanzig 21 22 23 24 ... 29|einmal
#jIn eof 4#
running zweimal
RUN 1 COMPILED zweimal
#jIn eof 5#
tstCompCompShell */
call tst t, 'tstCompCompShell'
call tstCompRun 's' 3 ,
, "$$compiling shell $; $= rrr = $-cmpShell $<<aaa",
, "call jOut run 1*1*1 compiled $cc; $@for v $$ compRun $v$cc",
, "aaa $;",
, "$=cc=einmal $$ running $cc $@run $rrr",
, "$=cc=zweimal $$ running $cc $@run $rrr"
call tstEnd t
/*<<tstCompCompData
### start tst tstCompCompData #####################################
compile s, 5 lines: $$compiling data $; $= rrr = $-cmpData $<<aaa
run without input
compiling data
running einmal
call jOut run 1*1*1 compiled einmal
running zweimal
call jOut run 1*1*1 compiled zweimal
run with 3 inputs
compiling data
running einmal
call jOut run 1*1*1 compiled einmal
running zweimal
call jOut run 1*1*1 compiled zweimal
tstCompCompData */
call tst t, 'tstCompCompData'
call tstCompRun 's' 3 ,
, "$$compiling data $; $= rrr = $-cmpData $<<aaa",
, "call jOut run 1*1*1 compiled $cc",
, "aaa $;",
, "$=cc=einmal $$ running $cc $@run $rrr",
, "$=cc=zweimal $$ running $cc $@run $rrr"
call tstEnd t
return
endProcedure tstCompComp
/* copx tstComp end *************************************************/
/* copx tstBase begin **************************************************
test the basic classes
***********************************************************************/
tstBase: procedure expose m.
call tstTstSay
call oIni
call tstM
call tstMap
call tstMapVia
call tstClass
call tstClass2
call tstO
call jIni
call tstJSay
call tstJ
call tstJ2
call catIni
call tstCat
call envIni
CALL TstEnv
CALL TstEnvCat
call tstEnvBar
call tstEnvVars
call tstTotal
call tstEnvLazy
call tstEnvClass
call tstFile /* reimplent zOs ||| */
call tstFileList
call tstFmt
call tstTotal
call scanIni
call tstScan
call ScanReadIni
call tstScanRead
call tstScanWin
call tstScanSQL
call tstTotal
return
endProcedure tstBase
/*--- test the tst Module, check the output visually ----------------*/
tstTstSay: procedure expose m.
call tstIni
oldErr = m.tst.err
oldNames = m.tst.errNames
say '+++ tstTstSay start with' oldErr 'totErrs and',
m.tst.tests 'tests'
/*<<tstTstSayEins
### start tst tstTstSayEins #######################################
test eins einzige testZeile
tstTstSayEins */
call tst x, 'tstTstSayEins'
call tstOut x, "test eins einzige testZeile"
call tstEnd x
if m.x.err <> 0 then
call err '+++ tstTstSay errs' m.x.err 'expected' 0
/*<<tstTstSayZwei
### start tst tstTstSayZwei #######################################
zwei 1. testZeile
zwei 2. und letzte testZeile
tstTstSayZwei */
call tst x, 'tstTstSayZwei'
call tstOut x, "zwei 1. testZeile"
call tstOut x, "zwei 2. und letzte testZeile"
call tstEnd x
if m.x.err <> 0 then
call err '+++ tstTstSay errs' m.x.err 'expected' 0
call tst x, 'tstTstSayZwei'
call tstOut x, "zwei 1. testZeile " /* ein space zuviel */
call tstOut x, "zwei 2. und letzte testZeile"
call tstOut x, "zwei 3. zuviel"
call tstEnd x
if m.x.err <> 3 then
call err '+++ tstTstSay errs' m.x.err 'expected' 3
/*<<tstTstSayDrei
### start tst tstTstSayDrei #######################################
drei 1. testZeile vor empty Zeile
..
drei 3. testZeile vor 10 space
. .
drei 5. testZeile ziemlich lang 66 +
. 77 5 10 15++++++++++++++++++++
.+++++++++++++++++++++++++++++++++++++++++++.
tstTstSayDrei */
call tst y, 'tstTstSayDrei'
call tstOut y, 'drei 1. testZeile vor empty Zeile'
call tstOut y, ''
call tstOut y, 'drei 3. testZeile vor 10 space'
call tstOut y, left('', 10)
call tstOut y, 'drei 5. testZeile ziemlich lang',
left(66, 66) left('77 5 10 15', 77, '+')
call tstEnd y
if m.y.err <> 0 then
call err '+++ tstTstSay errs' m.x.err 'expected' 0
if m.tst.err <> oldErr + 3 then
call err '+++ tstTstSay totErrs' m.tst.err 'expected' 3
say '+++ tstTstSay end Ok with' m.tst.err 'totErrs and' ,
m.tst.tests 'tests'
m.tst.err = oldErr
m.tst.errNames = oldNames
return
endProcedure tstTstSay
tstM: procedure expose m.
/*<<tstM
### start tst tstM ################################################
symbol m.b LIT
mInc b 2 m.b 2
symbol m.a LIT
mAdd a A.2
mAdd a A.3
m.a: 3: 1=eins 2=zwei 3=drei 4=M.A.4
m.c: 5: 1=c vorAddSt a 2=eins 3=zwei 4=drei 5=c nacAddSt a 6=M.C.6
tstMSubj1 tstMSubj1 added listener 1
tstMSubj1 notified list1 1 arg tstMSubj1 registered list
tstMSubj1 notified list1 1 arg tstMSubj1 notify 11
tstMSubj1 tstMSubj1 added listener 2
tstMSubj1 notified list2 2 arg tstMSubj1 registered list
tstMSubj1 notified list1 1 arg tstMSubj1 notify 12
tstMSubj1 notified list2 2 arg tstMSubj1 notify 12
tstMSubj2 tstMSubj2 added listener 1
tstMSubj2 notified list1 1 arg tstMSubj2 registered list
tstMSubj2 tstMSubj2 added listener 2
tstMSubj2 notified list2 2 arg tstMSubj2 registered list
tstMSubj1 notified list1 1 arg tstMSubj1 notify 13
tstMSubj1 notified list2 2 arg tstMSubj1 notify 13
tstMSubj2 notified list1 1 arg tstMSubj2 notify 24
tstMSubj2 notified list2 2 arg tstMSubj2 notify 24
tstM */
drop m.b m.a m.a.0 m.a.1 m.a.2
call tst t, 'tstM'
call tstOut t, 'symbol m.b' symbol('m.b')
m.b = 1
call tstOut t, 'mInc b' mInc(b) 'm.b' m.b
call tstOut t, 'symbol m.a' symbol('m.a')
call tstOut t, 'mAdd a' mAdd(mCut(a, 0), 'eins', 'zwei')
call tstOut t, 'mAdd a' mAdd(a, 'drei')
call tstOut t, 'm.a:' m.a.0': 1='m.a.1 '2='m.a.2 '3='m.a.3 '4='m.a.4
call mAdd mCut(c, 0), 'c vorAddSt a'
call mAddSt c, a
call mAdd c, 'c nacAddSt a'
call tstOut t, 'm.c:' m.c.0': 1='m.c.1 '2='m.c.2 '3='m.c.3,
'4='m.c.4 '5='m.c.5 '6='m.c.6
s1 = 'tstMSubj1'
s2 = 'tstMSubj2'
/* we must unregister for the second test */
drop m.m.subLis.s1 m.m.subLis.s1.0 m.m.subLis.s2 m.m.subLis.s2.0
call mRegisterSubject s1,
, 'call tstOut t, "'s1'" subject "added listener" listener;',
'call mNotify1 "'s1'", listener, "'s1' registered list"'
call mRegister s1,
, 'call tstOut t, subject "notified list1" listener "arg" arg'
call mNotify s1, s1 'notify 11'
call mRegister s1,
, 'call tstOut t, subject "notified list2" listener "arg" arg'
call mRegister s2,
, 'call tstOut t, subject "notified list1" listener "arg" arg'
call mRegister s2,
, 'call tstOut t, subject "notified list2" listener "arg" arg'
call mNotify s1, s1 'notify 12'
call mRegisterSubject s2,
, 'call tstOut t, "'s2'" subject "added listener" listener;',
'call mNotify1 "'s2'", listener, "'s2' registered list"'
call mNotify s1, s1 'notify 13'
call mNotify s2, s2 'notify 24'
call tstEnd t
return
endProcedure tstM
tstMap: procedure expose m.
/*<<tstMap
### start tst tstMap ##############################################
mapNew m keys m-keys 0
map m zwei --> 2
map m Zwei is not defined
map stem m-keys 4
map m eins --> 1
map m zwei --> 2
map m drei --> 3
map m vier --> 4
*** err: duplicate key eins in map m
map m zwei is not defined
q 2 zw dr
map stem Q 2
map Q zw --> 2Q
map Q dr --> 3Q
map stem m 3
map m eins --> 1
map m zwei --> 2PUT
map m vier --> 4PUT
*** err: duplicate key zwei in map m
tstMapLong eins keys 3
tstMapLong zweiMal keys 48
tstMapLong dreiMal keys 93
tstMapLong vier keys 138
tstMapLong <fuenf> keys 188
tstMap clear keys 0
inline1 3
inline1 1 == inline1 eins==
inline1 2 ====
inline1 3 == inline1 drei==
inline2 1 1 == inline2 eins==
inline3 nicht gefunden
tstMap */
/*<<tstMapInline1
inline1 eins
inline1 drei
tstMapInline1 */
/*<<tstMapInline2
inline2 eins
tstMapInline2 */
call tst t, 'tstMap'
m = mapNew('K')
ky = mapKeys(m)
call mAdd t'.TRANS', m 'm', ky 'm-keys'
call tstOut t, 'mapNew' m 'keys' ky m.ky.0
call mapAdd m, 'eins', 1
call mapAdd m, 'zwei', 2
call mapAdd m, 'drei', 3
call mapAdd m, 'vier', 4
call tstMapShow m, 'zwei'
call tstMapShow m, 'Zwei'
call tstMapShowSt m, mapKeys(m)
call mapAdd m, 'eins', 1
call mapReset m, '='
call tstMapShow m, 'zwei'
call mapAdd m, 'eins', 1
call mapAdd m, 'zwei', 2
call mapPut m, 'zwei', 2Put
call mapPut m, 'vier', 4Put
call mapReset q, '='
call mapAdd q, 'zw', 2q
call mapAdd q, 'dr', 3q
call tstOut t, 'q' m.q.0 m.q.1 m.q.2
call tstMapShowSt q, mapKeys(q)
call tstMapShowSt m, mapKeys(m)
call mapAdd m, 'zwei', 2addDup
call tstMapLong m, 'eins' ,201, 2000, -2, 2
call tstMapLong m, 'zweiMal' ,201, 2000, -2, 2
call tstMapLong m, 'dreiMal' ,201, 2000, 2,-2
call tstMapLong m, 'vier ' ,2010, 201, -2, 2
call tstMapLong m, '<fuenf>' ,2010, 201, 2,-2
call mapClear m
keys = mapKeys(m)
call tstOut t, 'tstMap clear keys' m.keys.0
i = mapInline('tstMapInline1')
call tstOut t, 'inline1' m.i.0
do x=1 to m.i.0
call tstOut t, 'inline1' x '=='m.i.x'=='
end
i = mapInline('tstMapInline2')
call tstOut t, 'inline2' m.i.0 '1 =='m.i.1'=='
call tstOut t, 'inline3' mapInline('tstMapInline3', 'nicht gefunden')
call tstEnd t
return
endProcedure tstMap
tstMapLong: procedure expose m.
parse arg m, w, f1, t1, f2, t2
if f1 < t1 then
b1 = 201
else
b1 = -201
if f2 < t2 then
b2 = 1
else
b2 = -1
lo = copies(w, 2100 % length(w))
keys = mapKeys(m)
keyCn = m.keys.0
call tstOut t, 'tstMapLong' w 'keys' keyCn
do x = f1 by b1 to t1
do y = x+f2 by b2 to x+t2
k = left(lo, y)
if mapHasKey(m, k) then
call err 'mapLong hasKey before' w y
call mapAdd m, k, w y
if \ mapHasKey(m, k) then
call err 'mapLong \ hasKey after' w y
if mapGet(m, k) \== w y then
call err 'mapLong \ get <> ' w y
keys = mapKeys(m)
if keyCn + 1 \= m.keys.0 then
call err 'mapLong keys .0 <> ' w y
keyCn = m.keys.0
if k \== m.keys.keyCn then
call err 'mapLong keys . ' keyCn '<>' w y
end
end
return
endProcedure tstMapLong
tstMapVia: procedure expose m.
/*<<tstMapVia
### start tst tstMapVia ###########################################
map M K --> A
mapVia(m, K) A
*** err: missing m.A at 3 in mapVia(M, K*)
mapVia(m, K*) M.A
mapVia(m, K*) valAt m.a
mapVia(m, K*) valAt m.a
*** err: missing m.A.aB at 5 in mapVia(M, K*aB)
mapVia(m, K*aB) M.A.aB
mapVia(m, K*aB) valAt m.A.aB
*** err: missing m.valAt m.a at 4 in mapVia(M, K**)
mapVia(m, K**) M.valAt m.a
mapVia(m, K**) valAt m.valAt m.a
mapVia(m, K**F) valAt m.valAt m.a.F
tstMapVia */
call tst t, 'tstMapVia'
u = 'A.aB'
v = 'valAt m.a'
drop m.a m.u m.v m.v.f
call mapReset m, 'K'
call mapAdd m, k, a
call tstMapShow m, k
call tstOut t, 'mapVia(m, K) ' mapVia(m, 'K')
call tstOut t, 'mapVia(m, K*) ' mapVia(m, 'K*')
m.a = v
call tstOut t, 'mapVia(m, K*) ' mapVia(m, 'K*')
call tstOut t, 'mapVia(m, K*) ' mapVia(m, 'K*')
call tstOut t, 'mapVia(m, K*aB) ' mapVia(m, 'K*aB')
m.u = 'valAt m.'u
call tstOut t, 'mapVia(m, K*aB) ' mapVia(m, 'K*aB')
call tstOut t, 'mapVia(m, K**) ' mapVia(m, 'K**')
v = m.a
m.v = 'valAt m.'v
m.v.f = 'valAt m.'v'.F'
call tstOut t, 'mapVia(m, K**) ' mapVia(m, 'K**')
call tstOut t, 'mapVia(m, K**F) ' mapVia(m, 'K**F')
call tstEnd t
return
endProcedure tstMapVia
tstMapShow: procedure expose m.
parse arg a, key
if mapHasKey(a, key) then
call tstOut t, 'map' a key '-->' mapGet(a, key)
else
call tstOut t, 'map' a key 'is not defined'
return
endProcedure tstMapShow
tstMapShowSt: procedure expose m.
parse arg a, st
call tstOut t, 'map stem' st m.st.0
do wx=1 to m.st.0
call tstMapShow a, m.st.wx
end
return
endProcedure tstMapShow
tstClass2: procedure expose m.
/*<<tstClass2
### start tst tstClass2 ###########################################
@CLASS.4 isA :class union
. choice n union
. .NAME = class
. .CLASS refTo @CLASS.3 :class union
. choice u stem 8
. .1 refTo @CLASS.11 :class union
. choice c union
. .NAME = v
. .CLASS refTo @CLASS.1 :class union
. choice v = v
. .2 refTo @CLASS.12 :class union
. choice c union
. .NAME = r
. .CLASS refTo @CLASS.7 :class union
. choice f union
. .NAME = CLASS
. .CLASS refTo @CLASS.6 :class union
. choice r .CLASS refTo @CLASS.4 done :class @CLASS.4
. .3 refTo @CLASS.13 :class union
. choice c union
. .NAME = s
. .CLASS refTo @CLASS.7 done :class @CLASS.7
. .4 refTo @CLASS.15 :class union
. choice c union
. .NAME = u
. .CLASS refTo @CLASS.14 :class union
. choice s .CLASS refTo @CLASS.6 done :class @CLASS.6
. .5 refTo @CLASS.16 :class union
. choice c union
. .NAME = f
. .CLASS refTo @CLASS.8 :class union
. choice u stem 2
. .1 refTo @CLASS.5 :class union
. choice f union
. .NAME = NAME
. .CLASS refTo @CLASS.1 done :class @CLASS.1
. .2 refTo @CLASS.7 done :class @CLASS.7
. .6 refTo @CLASS.17 :class union
. choice c union
. .NAME = n
. .CLASS refTo @CLASS.8 done :class @CLASS.8
. .7 refTo @CLASS.18 :class union
. choice c union
. .NAME = c
. .CLASS refTo @CLASS.8 done :class @CLASS.8
. .8 refTo @CLASS.19 :class union
. choice c union
. .NAME = m
. .CLASS refTo @CLASS.10 :class union
. choice u stem 2
. .1 refTo @CLASS.5 done :class @CLASS.5
. .2 refTo @CLASS.9 :class union
. choice f union
. .NAME = MET
. .CLASS refTo @CLASS.1 done :class @CLASS.1
tstClass2 */
call tst t, 'tstClass2'
call classOut , m.class.class
call tstEnd t
/* call out 'nach pop' *** ???wktest */
return
endProcedure tstClass2
tstClass: procedure expose m.
/*<<tstClass
### start tst tstClass ############################################
Q n =className= tstClassTf12
Q.eins.zwei v ==> M.Q.eins.zwei
*** err: basicClass v end of Exp expected: v tstClassTf12 .
R n =className= uststClassTf12
R n =className= uststClassTf12in
R n =className= tstClassTf12
R.eins.zwei v ==> M.R.eins.zwei
R s =stem.0= 2
R.1 r ==> M.R.1
R.1 n =className= tstClassTf12
R.1.eins.zwei v ==> M.R.1.eins.zwei
R.2 r ==> M.R.2
R.2 n =className= tstClassTf12
R.2.eins.zwei v ==> M.R.2.eins.zwei
S s =stem.0= 2
S.1.eins v ==> M.S.1.eins
S.1 m =met-metA--> say "metA"
S.1 m =met-metB--> say "metB"
S.2.zwei v ==> M.S.2.zwei
S.2 m =met-metA--> say "metA"
S.2 m =met-metB--> say "metB"
class of mutate qq tstClassTf12
tstClass */
f = 'eins.zwei'
e = 'eins'
z = 'zwei'
drop m.q.f m.r.f m.r.0 m.r.1 m.r.1.f m.r.2 m.r.2.f
drop m.s.0 m.s.1 m.s.1.e m.s.2 m.s.2.z
call classIni
call tst t, 'tstClass'
t1 = classNew('n tstClassTf12 f eins f zwei v')
call tstClassOut t, t1, q
z = m.class.0
errDef = 'n tstClassB n tstClassC u tstClassTf12, s u v tstClassTf12'
if class4name(errDef, ' ') == ' ' then
t2 = classNew(errDef)
else /* the second time we do not get the error anymore,
because the err did not abend | */
call tstOut t,
,'*** err: basicClass v end of Exp expected: v tstClassTf12 '
t2 = classNew('n uststClassTf12 n uststClassTf12in u tstClassTf12',
, classNew('s u r, tstClassTf12'))
m.r.0 = 2
call tstClassOut t, t2, r
t3 = classNew('s u c 1 f eins v, c 2 f zwei v',
,'m', 'metA say "metA"', 'metB say "metB"')
m.s.0 = 2
m.s.1 = 1
m.s.2 = 2
call tstClassOut t, t3, s
call oMutate qq, 'tstClassTf12'
tt = objClass(qq)
call tstOut t, 'class of mutate qq' m.tt.name
call tstEnd t
return
endProcedure tstClass
tstClassOut: procedure expose m.
parse arg o, t, a
if pos(m.t, 'vr') > 0 then
return tstOut(o, a m.t '==>' m.a)
if m.t == 'n' then do
call tstOut o, a m.t '=className=' m.t.name
return tstClassOut(o, m.t.class, a)
end
if m.t == 'f' then
return tstClassOut(o, m.t.class, a'.'m.t.name)
if m.t = 'u' then do
do ux=1 to m.t.0
call tstClassOut o, m.t.ux, a
end
return 0
end
if m.t = 's' then do
call tstOut o, a m.t '=stem.0=' m.a.0
do ux=1 to m.a.0
call tstClassOut o, m.t.class, a'.'ux
end
return 0
end
if m.t = 'c' then do
if m.t.name = m.a then
call tstClassOut o, m.t.class, a
return 0
end
if m.t = 'm' then
return tstOut(o, a m.t '=met-'m.t.name'-->' m.t.met)
call err 'bad class type' m.t 1/0
endProcedure tstClassOut
tstO: procedure expose m.
/*<<tstO
### start tst tstO ################################################
class method calls of TstOEins
. met Eins.eins M
FLDS of <obj e of TstOEins> .FEINS, .FZWEI
methodcalls of object e of TstOEins
. met Eins.eins <obj e of TstOEins>
. met Eins.zwei <obj e2 of TstOEins>
*** err: no method nein in class TstOEins of object <obj e+
. of TstOEins>
*** err: no class found for object noObj
class method calls of TstOEins
. met Elf.zwei M
FLDS of <obj f of TstOElf> .FEINS, .FZWEI, .FELF
methodcalls of object f of TstOElf
. met Eins.eins <obj f of TstOElf>
. met Elf.zwei <obj f of TstOElf>
. met Elf.drei <obj f of TstOElf>
methodcalls of object f cast To TstOEins
. met Eins.eins <obj f of TstOElf>
. met Eins.zwei <obj f of TstOElf>
FLDS of <cast(f, TstOEins)> .FEINS, .FZWEI
oCopy c1 of class TstOEins, c2
C1 n =className= TstOEins
C1.FEINS v ==> M.C1.FEINS
C1.FZWEI v ==> M.C1.FZWEI
C1 m =met-eins--> call tstOut t, " met Eins.eins" m
C1 m =met-zwei--> call tstOut t, " met Eins.zwei" m
C2 n =className= TstOEins
C2.FEINS v ==> M.C1.FEINS
C2.FZWEI v ==> M.C1.FZWEI
C2 m =met-eins--> call tstOut t, " met Eins.eins" m
C2 m =met-zwei--> call tstOut t, " met Eins.zwei" m
oCopy c3 of class TstOElf, c4
C4 n =className= TstOElf
C4 n =className= TstOEins
C4.FEINS v ==> M.C3.FEINS
C4.FZWEI v ==> M.C3.FZWEI
C4 m =met-eins--> call tstOut t, " met Eins.eins" m
C4 m =met-zwei--> call tstOut t, " met Eins.zwei" m
C4.FELF r ==> M.C3.FELF
C4 m =met-zwei--> call tstOut t, " met Elf.zwei" m
C4 m =met-drei--> call tstOut t, " met Elf.drei" m
tEinsDop <class TstOEins>
oRun 7*3 21
oRun 12*12 144
tstO */
call tst t, 'tstO'
tEins = classNew('n TstOEins u f FEINS v,f FZWEI v', 'm',
, 'eins call tstOut t, " met Eins.eins" m',
, 'zwei call tstOut t, " met Eins.zwei" m')
call mAdd t.trans, tEins '<class TstOEins>'
call tstOut t, 'class method calls of TstOEins'
interpret classMet('TstOEins', 'eins')
e = oNew('TstOEins')
e2 = oNew('TstOEins')
call mAdd t.trans, e '<obj e of TstOEins>'
call mAdd t.trans, e2 '<obj e2 of TstOEins>'
tEins = classNew('n TstOEins u f FEINS v,f FZWEI v', 'm',
, 'eins call tstOut t, " met Eins.eins" m',
, 'zwei call tstOut t, " met Eins.zwei" m')
call tstOut t, 'FLDS of' e mCat(oFlds(e), ', ')
call tstOut t, 'methodcalls of object e of TstOEins'
call tstOmet e, 'eins'
call tstOmet e2, 'zwei'
call tstOmet e, 'nein'
call tstOmet 'noObj', 'nein'
tElf = classNew('n TstOElf u TstOEins, f FELF r', 'm',
, 'zwei call tstOut t, " met Elf.zwei" m',
, 'drei call tstOut t, " met Elf.drei" m')
call tstOut t, 'class method calls of TstOEins'
interpret classMet('TstOElf', 'zwei')
f = oNew('TstOElf')
call mAdd t.trans, f '<obj f of TstOElf>'
call tstOut t, 'FLDS of' f mCat(oFlds(f), ', ')
call tstOut t, 'methodcalls of object f of TstOElf'
call tstOmet f, 'eins'
call tstOmet f, 'zwei'
call tstOmet f, 'drei'
call tstOut t, 'methodcalls of object f cast To TstOEins'
call tstOmet oCast(f, 'TstOEins'), 'eins'
call tstOmet oCast(f, 'TstOEins'), 'zwei'
call tstOut t, 'FLDS of <cast(f, TstOEins)>',
mCat(oFlds(oCast(f, 'TstOEins')), ', ')
call oMutate c1, 'TstOEins'
call tstOut t, 'oCopy c1 of class TstOEins, c2'
call tstClassOut t, tEins, c1
call oCopy c1, c2
call tstClassOut t, tEins, c2
call tstOut t, 'oCopy c3 of class TstOElf, c4'
call oMutate c3, 'TstOElf'
call oCopy c3, c4
call tstClassOut t, tElf, c4
tEinsDop = classNew('n TstOEins u f FEINS v,f FZWEI v', 'm',
, 'eins call tstOut t, " met Eins.eins" m',
, 'zwei call tstOut t, " met Eins.zwei" m')
call tstOut t, 'tEinsDop' tEinsDop
e3 = oNew('TstOEins')
if e3 <<= e | e3 <<= e2 then
call err 'doppelt reinitialised objects'
rr = oRunner('return 7 * 3')
call tstOut t, 'oRun 7*3' oRun(rr)
r12 = oRunner('return 12 * 12')
call tstOut t, 'oRun 12*12' oRun(r12)
call tstEnd t
return
endProcedure tstO
tstOmet: procedure expose m.
parse arg m, met
interpret objMet(m, met)
return
endProcedure tstOmet
tstJSay: procedure expose m.
/*<<tstJSay
### start tst tstJSay #############################################
*** err: call of abstract method jOpen(<obj j of JRW>, openArg)
*** err: jWrite(<obj j of JRW>, writeArg) but not opened w
*** err: can only write JRWSay.jOpen(<obj s of JRWSay>, open<Arg)
*** err: jWrite(<obj s of JRWSay>, write s vor open) but not opened+
. w
*** err: can only read JRWEof.jOpen(<obj e of JRWEof>, open>Arg)
*** err: jRead(<obj e of JRWEof>, XX) but not opened r
read e vor open 0 m.xx valueBefore
read e nach open 0 m.xx M.XX
out eins
#jIn 1# tst in line 1 eins ,
out zwei jIn 1 vv=readAdrVV
#jIn 2# tst in line 2 zwei ; .
out drei jIn 1 vv=readAdrVV Schluss
tstJSay */
call tst t, 'tstJSay'
call jIni
j = oNew('JRW')
call mAdd t'.TRANS', j '<obj j of JRW>'
call jOpen j, 'openArg'
call jWrite j, 'writeArg'
s = oNew('JRWSay')
call mAdd t'.TRANS', s '<obj s of JRWSay>'
call jOpen s, 'open<Arg'
call jWrite s, 'write s vor open'
call jOpen s
call jWrite s, 'write s nach open'
e = oNew('JRWEof')
call mAdd t'.TRANS', e '<obj e of JRWEof>'
call jOpen e, 'open>Arg'
m.xx = 'valueBefore'
call tstOut t, 'read e vor open' jRead(e, xx) 'm.xx' m.xx
call jOpen e
call tstOut t, 'read e nach open' jRead(e, xx) 'm.xx' m.xx
call jOut 'out eins'
vv = 'readAdrVV'
m.vv = 'readAdrVVValueBefore'
call jOut 'out zwei jIn' jIn(vv) 'vv='vv
m.vv = 'readAdrVVValueBefore'
call jOut 'out drei jIn' jIn(vv) 'vv='vv 'Schluss'
call tstEnd t
return
endProcedure tstJSay
tstJ: procedure expose m.
/*<<tstJ
### start tst tstJ ################################################
out eins
#jIn 1# tst in line 1 eins ,
1 jIn() tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
2 jIn() tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
3 jIn() tst in line 3 drei .schluss..
#jIn eof 4#
jIn() 3 reads vv VV
*** err: already opened jOpen(<buf b>, <)
line buf line one
line buf line two
line buf line three
line buf line four
*** err: jWrite(<buf b>, buf line five while reading) but not opene+
d w
tstJ */
call jIni
call tst t, "tstJ"
b = jOpen(jBuf(), '>')
call mAdd t'.TRANS', b '<buf b>'
call jOut 'out eins'
do lx=1 by 1 while jIn(var)
call jOut lx 'jIn()' m.var
end
call jOut 'jIn()' (lx-1) 'reads vv' vv
call jWrite b, 'buf line one'
call mAdd m.b.stem, 'buf line two', 'buf line three'
call jWrite b, 'buf line four'
call jOpen b, '<'
call jClose b
call jOpen b, '<'
do while (jRead(b, line))
call jOut 'line' m.line
end
call jWrite b, 'buf line five while reading'
call jClose b
call tstEnd t
return
endProcedure tstJ
tstJ2: procedure expose m.
/*<<tstJ2
### start tst tstJ2 ###############################################
class1 <Tst?1 class> <Tst?1 name>
class2 <Tst?1 class> <Tst?1 name>
class3 <Tst?1 class> <Tst?1 name>
b read EINS feld eins, ZWEI feld zwei, DREI feld drei
b read EINS feld eins, ZWEI feld zwei 2, DREI feld drei
c read EINS feld eins, ZWEI feld zwei, DREI drei cat 1
tstR: @CCC isA :<Tst?1 name> union
tstR: .EINS = feld eins
tstR: .ZWEI = feld zwei
tstR: .DREI = drei cat 1
c read EINS feld eins, ZWEI feld zwei 2, DREI drei cat 2
tstR: @CCC isA :<Tst?1 name> union
tstR: .EINS = feld eins
tstR: .ZWEI = feld zwei 2
tstR: .DREI = drei cat 2
tstJ2 */
call tst t, "tstJ2"
ty = classNew('n Tst* u f EINS v, f ZWEI v, f DREI v')
call mAdd t'.TRANS', ty '<Tst?1 class>'
call mAdd t'.TRANS', m.ty.name '<Tst?1 name>'
call tstOut t, 'class1' ty m.ty.name
ty = classNew('n Tst* u f EINS v, f ZWEI v, f DREI v')
call tstOut t, 'class2' ty m.ty.name
ty = classNew('n Tst* u f EINS v, f ZWEI v, f DREI v')
call tstOut t, 'class3' ty m.ty.name
call oMutate qq, m.ty.name
m.qq.eins = 'feld eins'
m.qq.zwei = 'feld zwei'
m.qq.drei = 'feld drei'
b = jBuf()
call jOpen b, '>'
call jWriteR b, qq
m.qq.zwei = 'feld zwei 2'
call jWriteR b, qq
call jOpen jClose(b), '<'
c = jOpen(jBuf(), '>')
do xx=1 while jRead(b, res)
call jOut 'b read EINS' m.res.eins', ZWEI' m.res.zwei,
|| ', DREI' m.res.drei
m.res.drei = 'drei cat' xx
call jWriteR c, res
end
call jOpen jClose(c), '<'
do while jRead(c, ccc)
call jOut 'c read EINS' m.ccc.eins', ZWEI' m.ccc.zwei,
|| ', DREI' m.ccc.drei
call jOuR ccc
end
call tstEnd t
return
endProcedure tstJ2
tstCat: procedure expose m.
/*<<tstCat
### start tst tstCat ##############################################
catRead 1 line 1
catRead 2 line 2
catRead 3 line 3
appRead 1 line 1
appRead 2 line 2
appRead 3 line 3
appRead 4 append 4
appRead 5 append 5
tstCat */
call tst t, "tstCat"
i = cat('%' jBuf('line 1', 'line 2'), '%' jBuf('line 3'))
call jOpen i, m.j.cRead
do lx=1 by 1 while jRead(i, v)
call tstOut t, 'catRead' lx m.v
end
call jOpen jClose(i), m.j.cApp
call jWrite i, 'append 4'
call jWrite i, 'append 5'
call jOpen jClose(i), m.j.cRead
do lx=1 by 1 while jRead(i, v)
call tstOut t, 'appRead' lx m.v
end
call tstEnd t
return
endProcedure tstCat
tstEnv: procedure expose m.
/*<<tstEnv
### start tst tstEnv ##############################################
before envPush
after envPop
*** err: jWrite(<jBuf c>, write nach pop) but not opened w
#jIn 1# tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
before writeNow 2 c --> std
before writeNow 1 b --> c
b line eins
b zwei |
nach writeNow 1 b --> c
add nach pop
after push c only
tst in line 1 eins ,
tst in line 2 zwei ; .
tst in line 3 drei .schluss..
nach writeNow 2 c --> std
*** err: jWrite(<jBuf c>, ) but not opened w
tstEnv */
call tst t, "tstEnv"
c = jBuf()
call mAdd t'.TRANS', c '<jBuf c>'
call jOut 'before envPush'
b = jBuf("b line eins", "b zwei |")
call envPush '<%' b, '>%' c
call jOut 'before writeNow 1 b --> c'
call envwriteNow
call jOut 'nach writeNow 1 b --> c'
call envPop
call jOut 'after envPop'
call jWrite c, 'write nach pop'
call mAdd c'.BUF', 'add nach pop'
call envPush '>>%' c
call jOut 'after push c only'
call envwriteNow
call envPop
call envPush '<%' c
call jOut 'before writeNow 2 c --> std'
call envwriteNow
call jOut 'nach writeNow 2 c --> std'
call envPop
call jWrite c
call tstEnd t
return
endProcedure tstEnv
tstEnvCat: procedure expose m.
/*<<tstEnvCat
### start tst tstEnvCat ###########################################
c1 contents
c1 line eins |
before writeNow 1 b* --> c*
b1 line eins|
b2 line eins
b2 zwei |
c2 line eins |
after writeNow 1 b* --> c*
c2 contents
c2 line eins |
tstEnvCat */
call tst t, "tstEnvCat"
b0= jBuf()
b0= jBuf()
b1= jBuf("b1 line eins|")
b2 = jBuf("b2 line eins", "b2 zwei |")
c1 = jBuf("c1 line eins |")
c2 = jBuf("c2 line eins |")
call envPush '<+%' b0, '<+%' b1, '<+%' b2, '<%' c2,'>>%' c1
call jOut 'before writeNow 1 b* --> c*'
call envwriteNow
call jOut 'after writeNow 1 b* --> c*'
call envPop
call jOut 'c1 contents'
call envPush '<%' c1
call envwriteNow
call envPop
call envPush '<%' c2
call jOut 'c2 contents'
call envwriteNow
call envPop
call tstEnd t
return
endProcedure tstEnvCat
tstEnvBar: procedure expose m.
/*<<tstEnvBar
### start tst tstEnvBar ###########################################
.+0 vor envBarBegin
#jIn 1# tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
.+7 nach envBarLast
¢7 +6 nach envBar 7!
¢7 +2 nach envBar 7!
¢7 +4 nach nested envBarLast 7!
¢7 (4 +3 nach nested envBarBegin 4) 7!
¢7 (4 (3 +1 nach envBarBegin 3) 4) 7!
¢7 (4 (3 tst in line 1 eins , 3) 4) 7!
¢7 (4 (3 tst in line 2 zwei ; 3) 4) 7!
¢7 (4 (3 tst in line 3 drei .schluss. 3) 4) 7!
¢7 (4 (3 +1 nach writeNow vor envBar 3) 4) 7!
¢7 (4 +3 nach preSuf vor nested envBarLast 4) 7!
¢7 +4 nach preSuf vor nested envBarEnd 7!
¢7 +5 nach nested envBarEnd vor envBar 7!
¢7 +6 nach writeNow vor envBarLast 7!
.+7 nach writeNow vor envBarEnd
.+8 nach envBarEnd
tstEnvBar */
call tst t, 'tstEnvBar'
call jOut '+0 vor envBarBegin'
call envBarBegin
call jOut '+1 nach envBarBegin'
call envwriteNow
call jOut '+1 nach writeNow vor envBar'
call envBar
call jOut '+2 nach envBar'
call envBarBegin
call jOut '+3 nach nested envBarBegin'
call envPreSuf '(3 ', ' 3)'
call jOut '+3 nach preSuf vor nested envBarLast'
call envBarLast
call jOut '+4 nach nested envBarLast'
call envPreSuf '(4 ', ' 4)'
call jOut '+4 nach preSuf vor nested envBarEnd'
call envBarEnd
call jOut '+5 nach nested envBarEnd vor envBar'
call envBar
call jOut '+6 nach envBar'
call envwriteNow
say 'jOut +6 nach writeNow vor envBarLast'
call jOut '+6 nach writeNow vor envBarLast'
call envBarLast
call jOut '+7 nach envBarLast'
call envPreSuf '¢7 ', ' 7!'
call jOut '+7 nach writeNow vor envBarEnd'
call envBarEnd
call jOut '+8 nach envBarEnd'
call tstEnd t
return
endProcedure tstEnvBar
tstEnvVars: procedure expose m.
/*<<tstEnvVars
### start tst tstEnvVars ##########################################
put v1 value eins
v1 hasKey 1 get value eins
v2 hasKey 0
via v1.fld via value
one to theBur
two to theBuf
tstEnvVars */
call tst t, "tstEnvVars"
call envRemove 'v2'
put1 = envPut('v1', 'value eins')
call tstOut t, 'put v1' put1
call tstOut t, 'v1 hasKey' envHasKey('v1') 'get' envGet('v1')
call tstOut t, 'v2 hasKey' envHasKey('v2')
if 0 then
call tstOut t, 'v2 get' envGet('v2')
m.put1.fld = 'via value'
call tstOut t, 'via v1.fld' envVia('v1*FLD')
call envPush '># theBuf'
call jOut 'one to theBur'
call jOut 'two to theBuf'
call envPop
call envPush '<# theBuf'
call envwriteNow
call envPop
call tstEnd t
return
endProcedure tstEnvVars
tstEnvLazy: procedure expose m.
/*<<tstEnvLazy
### start tst tstEnvLazy ##########################################
a1 vor envBarBegin loop lazy 0 writeNow *** <class TstEnvLazyBuf>
bufOpen <%
bufClose
#jIn 2# tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
a5 vor 2 writeNow jIn inIx 4
a2 vor writeNow jBuf
jBuf line 1
jBuf line 2
a3 vor writeNow jIn inIx 1
tst in line 2 zwei ; .
tst in line 3 drei .schluss..
a4 vor barLast inIx 4
a6 vor barEnd inIx 4
a7 nach barEnd lazy 0 writeNow ***
b1 vor barBegin lazy 0 writeNow *** <class TstEnvLazyRdr>
RdrOpen <%
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
rdrClose
b4 vor writeNow
b2 vor writeNow rdr inIx 2
jRead lazyRdr
tst in line 3 drei .schluss..
jRead lazyRdr
b3 vor barLast inIx 4
b5 vor barEnd inIx 4
b6 nach barEnd lazy 0 writeNow ***
a1 vor envBarBegin loop lazy 1 writeAll *** <class TstEnvLazyBuf>
a5 vor 2 writeAll jIn inIx 0
a2 vor writeAll jBuf
bufOpen <%
jBuf line 1
jBuf line 2
bufClose
a3 vor writeAll jIn inIx 0
#jIn 1# tst in line 1 eins ,
tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
tst in line 3 drei .schluss..
#jIn eof 4#
a4 vor barLast inIx 0
a6 vor barEnd inIx 4
a7 nach barEnd lazy 1 writeAll ***
b1 vor barBegin lazy 1 writeAll *** <class TstEnvLazyRdr>
b4 vor writeAll
b2 vor writeAll rdr inIx 1
RdrOpen <%
*** err: jWrite(ENV.lazyNoOut, jRead lazyRdr) but not opened w
#jIn 2# tst in line 2 zwei ; .
tst in line 2 zwei ; .
*** err: jWrite(ENV.lazyNoOut, jRead lazyRdr) but not opened w
#jIn 3# tst in line 3 drei .schluss..
tst in line 3 drei .schluss..
*** err: jWrite(ENV.lazyNoOut, jRead lazyRdr) but not opened w
#jIn eof 4#
rdrClose
b3 vor barLast inIx 1
b5 vor barEnd inIx 4
b6 nach barEnd lazy 1 writeAll ***
tstEnvLazy */
call tst t, "tstEnvLazy"
do lz=0 to 1
if lz then
w = 'writeAll'
else
w = 'writeNow'
m.t.inIx = 1-lz
ty = classNew('n TstEnvLazyBuf u JBuf', 'm',
, 'jOpen call tstOut "T", "bufOpen" opt;',
'return jOpen(oCast(m, "JBuf"), opt)',
, 'jClose call tstOut "T", "bufClose";',
'return jClose(oCast(m, "JBuf"), opt)')
if \ lz then
call mAdd t'.TRANS', ty '<class TstEnvLazyBuf>'
call jOut 'a1 vor envBarBegin loop lazy' lz w '***' ty
call envBarBegin
call jOut 'a2 vor' w 'jBuf'
b = oMutate(jBuf('jBuf line 1','jBuf line 2'),
,'TstEnvLazyBuf')
interpret 'call env'w '"<%" b'
call jOut 'a3 vor' w 'jIn inIx' m.t.inIx
interpret 'call env'w
call jOut 'a4 vor barLast inIx' m.t.inIx
call envBarLast
call jOut 'a5 vor 2' w 'jIn inIx' m.t.inIx
interpret 'call env'w
call jOut 'a6 vor barEnd inIx' m.t.inIx
call envBarEnd
call jOut 'a7 nach barEnd lazy' lz w '***'
ty = classNew('n TstEnvLazyRdr u JRW', 'm',
, 'jOpen call tstOut "T", "RdrOpen" opt;m.m.jReading=1',
, 'jRead call jOut "jRead lazyRdr"; return jIn(var);',
, 'jClose call tstOut "T", "rdrClose";')
if \ lz then
call mAdd t'.TRANS', ty '<class TstEnvLazyRdr>'
r = oNew('TstEnvLazyRdr')
if lz then
call mAdd t'.TRANS', r '<lazyRdr>'
m.t.inIx = 2-lz
call jOut 'b1 vor barBegin lazy' lz w '***' ty
call envBarBegin
if lz then
call mAdd t'.TRANS', m.j.jOut '<barBegin out>'
call jOut 'b2 vor' w 'rdr inIx' m.t.inIx
interpret 'call env'w 'm.j.cRead || m.j.cObj r'
call jOut 'b3 vor barLast inIx' m.t.inIx
call envBarLast
call jOut 'b4 vor' w
interpret 'call env'w
call jOut 'b5 vor barEnd inIx' m.t.inIx
call envBarEnd
call jOut 'b6 nach barEnd lazy' lz w '***'
end
call tstEnd t
return
endProcedure tstEnvLazy
tstEnvClass: procedure expose m.
/*<<tstEnvClass
### start tst tstEnvClass #########################################
a0 vor envBarBegin loop lazy 0 writeNow *** TY
#jIn 2# tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
a5 vor writeNow
a1 vor jBuf()
a2 vor writeNow b
tstR: @LINE isA :TstEnvClass10 union
tstR: .f11 = M.<o20 of TstEnvClass10>.f11
tstR: .F12 = value F12 of o1 <o20 of TstEnvClass10>
tstR: .f13 = M.<o20 of TstEnvClass10>.f13
writeR o2
tstR: @LINE isA :TstEnvClass20 union = valueO2Lazy0
tstR: .f24 = M.<o20 of TstEnvClass20>.f24
tstR: .F25 = value F25 of o20 <o20 of TstEnvClass20>
a3 vor writeNow
tst in line 2 zwei ; .
tst in line 3 drei .schluss..
a4 vor barLast inIx 4
a6 vor barEnd
a7 nach barEnd lazy 0 writeNow ***
a0 vor envBarBegin loop lazy 1 writeAll *** TY
a5 vor writeAll
a1 vor jBuf()
a2 vor writeAll b
tstR: @LINE isA :TstEnvClass10 union
tstR: .f11 = M.<o21 of TstEnvClass10>.f11
tstR: .F12 = value F12 of o1 <o21 of TstEnvClass10>
tstR: .f13 = M.<o21 of TstEnvClass10>.f13
writeR o2
tstR: @LINE isA :TstEnvClass20 union = valueO2Lazy1
tstR: .f24 = M.<o21 of TstEnvClass20>.f24
tstR: .F25 = value F25 of o21 <o21 of TstEnvClass20>
a3 vor writeAll
#jIn 1# tst in line 1 eins ,
tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
tst in line 3 drei .schluss..
#jIn eof 4#
a4 vor barLast inIx 0
a6 vor barEnd
a7 nach barEnd lazy 1 writeAll ***
tstEnvClass */
call tst t, "tstEnvClass"
do lz=0 to 1
if lz then
w = 'writeAll'
else
w = 'writeNow'
m.t.inIx = 1-lz
t10 = classNew('n TstEnvClass10 u f f11 v, f F12 v, f f13 v')
t20 = classNew('n TstEnvClass20 u v, f f24 v, f F25 v')
call jOut 'a0 vor envBarBegin loop lazy' lz w '***' ty
call envBarBegin
call jOut 'a1 vor jBuf()'
b = jOpen(jBuf(), m.j.cWri)
o1 = oNew('TstEnvClass10')
m.o1.F12 = 'value F12 of o1' o1
call mAdd t'.TRANS', o1 '<o2'lz 'of TstEnvClass10>'
call jWriteR b, o1
call jWrite b, 'writeR o2'
o2 = oNew('TstEnvClass20')
m.o2 = 'valueO2Lazy'lz
m.o2.F25 = 'value F25 of o2'lz o2
oc = oCopyNew(oCopyNew(o2))
call mAdd t'.TRANS', o2 '<o2'lz 'of TstEnvClass20>'
call mAdd t'.TRANS', oc '<oc'lz 'of TstEnvClass20>'
call jWriteR b, oc
call jOut 'a2 vor' w 'b'
interpret 'call env'w '"<%"' jClose(b)
call jOut 'a3 vor' w
interpret 'call env'w
call jOut 'a4 vor barLast inIx' m.t.inIx
call envBarLast
call jOut 'a5 vor' w
interpret 'call env'w
call jOut 'a6 vor barEnd'
call envBarEnd
call jOut 'a7 nach barEnd lazy' lz w '***'
end
call tstEnd t
return
endProcedure tstEnvClass
tstFile: procedure expose m.
/*<<tstFile
### start tst tstFile #############################################
write read 0 last 10 vor anfang
write read 1 last 80 links1 1 und rechts | ..
write read 2 last 80 liinks2 2 und rechts | ..
write read 5 last 80 links5 5 rechts5
write read 99 last 80 links99 99 rechts
write read 100 last 80 links100 100 rechts
write read 101 last 80 links101 101 rechts
write read 999 last 80 links999 999 rechts
write read 1000 last 80 links1000 1000 rechts
write read 1001 last 80 links1001 1001 rechts
write read 2109 last 80 links2109 2109 rechts
out > eins 1 +
. .
out > eins 2 schluss. +
. .
buf eins
buf zwei
buf drei
out > zwei mit einer einzigen Zeile +
. .
. links1 1 und rechts | . +
. .
tstFile */
call tst t, "tstFile"
pds = tstFilename('lib', 'r')
call tstFileWr pds, 0, ' links0', ' und rechts | . '
call tstFileWr pds, 1, ' links1', ' und rechts | . '
call tstFileWr pds, 2, 'liinks2', ' und rechts | . '
call tstFileWr pds, 5, 'links5', 'rechts5'
call tstFileWr pds, 99, 'links99', 'rechts'
call tstFileWr pds, 100, 'links100', 'rechts'
call tstFileWr pds, 101, 'links101', 'rechts'
call tstFileWr pds, 999, 'links999', 'rechts'
call tstFileWr pds, 1000, 'links1000', 'rechts'
call tstFileWr pds, 1001, 'links1001', 'rechts'
call tstFileWr pds, 2109, 'links2109', 'rechts'
pd2 = tstFilename('li2', 'r')
call envPush '>' tstPdsMbr(pd2, 'eins')
call jOut tstFB('out > eins 1') /* simulate fixBlock on linux */
call jOut tstFB('out > eins 2 schluss.')
call envPop
call envPush '>' tstPdsMbr(pd2, 'zwei')
call jOut tstFB('out > zwei mit einer einzigen Zeile')
call envPop
b = jBuf("buf eins", "buf zwei", "buf drei")
call envPush '<' tstPdsMbr(pd2, 'eins'), '<%' b,
,'<%' jBuf(),
,'<' tstPdsMbr(pd2, 'zwei'),
,'<' tstPdsMbr(pds, 'wr0'),
,'<' tstPdsMbr(pds, 'wr1')
call envwriteNow
call envPop
call tstEnd t
return
endProcedure tstFile
/*--- simulate fixBlock 80 on linux ---------------------------------*/
tstFB: procedure expose m.
parse arg line, recL
if errOS() \== 'LINUX' then
return line
else if recL == '' then
return left(line, 80)
else
return left(line, recL)
endProcedure tstFB
tstPdsMbr: procedure expose m.
parse arg pds, mbr
os = errOS()
if os = 'TSO' then
return pds'('mbr') ::F'
if os = 'LINUX' then
return pds'.'mbr
call err 'tstPdsMbr implement os' os
endProcedure tstPdsMbr
tstFileWR: procedure expose m.
parse arg dsn, num, le, ri
io = file(tstPdsMbr(dsn, 'wr'num))
call jOpen io, m.j.cWri
do x = 1 to num /* simulate fixBlock 80 on LINUX*/
call jWrite io, tstFB(le x ri)
end
if num > 100 then
call jReset jClose(io), tstPdsMbr(dsn, 'wr'num)
call jOpen jClose(io), m.j.cRead
m.vv = 'vor anfang'
do x = 1 to num
if \ jRead(io, vv) then
call err x 'not jRead'
else if m.vv <> le x ri then
call err x 'read mismatch' m.vv
end
if jRead(io, vv) then
call err x 'jRead'
if jRead(io, vv) then
call err x'+1 jRead'
call jClose io
call tstOut t, 'write read' num 'last' length(m.vv) strip(m.vv,'t')
return
endProcedure tstFileRW
tstFileList: procedure expose m.
/*<<tstFileList
### start tst tstFileList #########################################
empty dir
filled dir
<<pref 2 List>>drei
<<pref 2 List>>eins
<<pref 2 List>>zwei
<<pref 2 List>>vier
filled dir recursive
<<pref 2 List>>drei
<<pref 2 List>>eins
<<pref 2 List>>zwei
<<pref 2 List>>vier
<<pref 1 vier>>drei
<<pref 1 vier>>eins
<<pref 1 vier>>zwei
tstFileList */
/*<<tstFileListTSO
### start tst tstFileListTSO ######################################
empty dir
filled dir
<<pref 2 LIST>>DREI
<<pref 2 LIST>>EINS
<<pref 2 LIST>>ZWEI
filled dir recursive
<<pref 2 LIST>>DREI
<<pref 2 LIST>>EINS
<<pref 1 VIER>>DREI
<<pref 1 VIER>>EINS
<<pref 1 VIER>>ZWEI
<<pref 2 LIST>>ZWEI
tstFileListTSO */
if errOS() = 'TSO' then
call tst t, "tstFileListTSO"
else
call tst t, "tstFileList"
fi = file(tstFileName('FileList', 'r'))
call fileMkDir fi
fl = fileList(fi)
call tstOut t, 'empty dir'
call jWriteNow t, fl
call tstFileListMake t, fi, 2
call tstOut t, 'filled dir'
call jWriteNow t, fl
call tstOut t, 'filled dir recursive'
call jWriteNow t, fileList(fi, 'r')
call tstEnd t
return
endProcedure tstFileList
tstFileListMake: procedure expose m.
parse arg t, fi, lev
if \ fileIsDir(fi) then
call fileMkDir fi
call mAdd t'.TRANS', filePath(fi) || m.file.sep ,
'<<pref' lev right(filePath(fi),4)'>>'
call jCat fileChild(fi, 'eins','::F'),jBuf('zeile eins', 'eins' lev)
call jCat fileChild(fi, 'zwei','::F'),jBuf('zeile zwei', 'zwei' lev)
call jCat fileChild(fi, 'drei','::F'),jBuf('zeile drei', 'drei' lev)
if lev > 1 then
call tstFileListMake t, fileChild(fi, 'vier'), lev-1
return
endProcedure tstFileListMake
tstFmt: procedure expose m.
/*<<tstFmt
### start tst tstFmt ##############################################
= a2i b3b d4 fl5 ex6
-11 -11 b3 d4-11+d4++++ -111.1000000 -1.11000E-12
-1 -10 b d4-10+d4+++ null1 null3
- -9 b3b-9 d4-9+d4+++ -11.0000000 -1.11900E-10
-8+ -8 b3b- d4-8+d4++ -18.0000000 -1.18000E010
-7 -7 b3b d4-7+d4+ -7.0000000 -1.70000E-07
- -6 b3 d4-6+d4 -0.1111160 -6.00000E006
-5+ -5 b d4-5+d null2 null2
-4 -4 b3b-4 d4-4+ -11114.0000000 -1.11140E008
- -3 b3b- d4-3 -0.1130000 -1.13000E-04
-2+ -2 b3b d4- -0.1200000 -1.20000E001
-1 -1 b3 d4 -0.1000000 -1.00000E-02
0 0 b d null1 null1
1+ 1 b3 d4 0.1000000 1.00000E-02
2++ 2 b3b d42 0.1200000 1.20000E001
3 3 b3b3 d43+ 0.1130000 1.13000E-04
4+ 4 b3b4+ d44+d 11114.0000000 1.11140E008
5++ 5 b d45+d4 null2 null2
6 6 b3 d46+d4+ 0.1111160 1.11116E005
7+ 7 b3b d47+d4++ 0.1111117 7.00000E-08
8++ 8 b3b8 d48+d4+++ 8.0000000 1.80000E009
9 9 b3b9+ d49+d4++++ 0.9000000 1.19000E-08
10 10 b d410+d4++++ null1 null3
11+ 11 b3 d411+d4+++++ 0.1110000 1.00000E-12
1 12 b3b d412+d4++++++ 11112.0000000 2.00000E012
13 13 b3b1 d 1111.3000000 1.13000E-12
14+ 14 b3b14 d4 111111.0000000 1.40000E013
1 15 b d41 null2 null1
16 16 b3 d416 6.0000000 1.16000E003
17+ 17 b3b d417+ 0.7000000 1.11170E-03
1 18 b3b1 d418+d 11.0000000 1.11800E003
19 19 b3b19 d419+d4 0.1190000 9.00000E-05
20+ 20 b d420+d4+ null1 null2
2 21 b3 d421+d4++ 11.1210000 1.11000E-05
22 22 b3b d422+d4+++ 11111.2000000 2.00000E007
23+ 23 b3b2 d423+d4++++ 0.1111123 1.11230E-09
c3L a2i drei d4 fl5 ex6
-11 -1.10E01 b3 d4-11+d -111.1000000 -1.11000E-12
-1 -1.00E01 b d4-10+d null1 null3
- -9.00E00 b3b-9 d4-9+d4 -11.0000000 -1.11900E-10
-8+ -8.00E00 b3b- d4-8+d4 -18.0000000 -1.18000E010
-7 -7.00E00 b3b d4-7+d4 -7.0000000 -1.70000E-07
- -6.00E00 b3 d4-6+d4 -0.1111160 -6.00000E006
-5+ -5.00E00 b d4-5+d null2 null2
-4 -4.00E00 b3b-4 d4-4+ -11114.0000000 -1.11140E008
- -3.00E00 b3b- d4-3 -0.1130000 -1.13000E-04
-2+ -2.00E00 b3b d4- -0.1200000 -1.20000E001
-1 -1.00E00 b3 d4 -0.1000000 -1.00000E-02
0 0.00E00 b d null1 null1
1+ 1.00E00 b3 d4 0.1000000 1.00000E-02
2++ 2.00E00 b3b d42 0.1200000 1.20000E001
3 3.00E00 b3b3 d43+ 0.1130000 1.13000E-04
4+ 4.00E00 b3b4+ d44+d 11114.0000000 1.11140E008
5++ 5.00E00 b d45+d4 null2 null2
6 6.00E00 b3 d46+d4+ 0.1111160 1.11116E005
7+ 7.00E00 b3b d47+d4+ 0.1111117 7.00000E-08
8++ 8.00E00 b3b8 d48+d4+ 8.0000000 1.80000E009
9 9.00E00 b3b9+ d49+d4+ 0.9000000 1.19000E-08
10 1.00E01 b d410+d4 null1 null3
11+ 1.10E01 b3 d411+d4 0.1110000 1.00000E-12
1 1.20E01 b3b d412+d4 11112.0000000 2.00000E012
13 1.30E01 b3b1 d 1111.3000000 1.13000E-12
14+ 1.40E01 b3b14 d4 111111.0000000 1.40000E013
1 1.50E01 b d41 null2 null1
16 1.60E01 b3 d416 6.0000000 1.16000E003
17+ 1.70E01 b3b d417+ 0.7000000 1.11170E-03
1 1.80E01 b3b1 d418+d 11.0000000 1.11800E003
19 1.90E01 b3b19 d419+d4 0.1190000 9.00000E-05
20+ 2.00E01 b d420+d4 null1 null2
2 2.10E01 b3 d421+d4 11.1210000 1.11000E-05
22 2.20E01 b3b d422+d4 11111.2000000 2.00000E007
23+ 2.30E01 b3b2 d423+d4 0.1111123 1.11230E-09
tstFmt */
call tst t, "tstFmt"
b = jBuf()
st = b'.BUF'
call envPush m.j.cWri || m.j.cObj b
call tstDataClassOut '. c3 a2i i b3b c5 d4 c13 fl5 f8n2 ex6 e9n3',
, -11, + 23
call envPop
call fmtFWriteAll fmtFreset(abc), m.j.cRead || m.j.cObj b
call fmtFAddFlds fmtFReset(abc), oFlds(st'.'1)
m.abc.1.tit = 'c3L'
m.abc.2.fmt = 'e'
m.abc.3.tit = 'drei'
m.abc.4.fmt = 'l7'
call fmtFWriteAll abc, m.j.cRead || m.j.cObj b
call tstEnd t
/*<<tstFmtCSV
### start tst tstFmtCSV ###########################################
, a2i, b3b, d4, fl5, ex6
-5+, -5, b, d4-5+d, null2, null2
-4, -4, b3b-4, d4-4+, -11114, -11114e4
-, -3, b3b-, d4-3, -.113, -.113e-3
-2+, -2, b3b, d4-, -.12, -.12e2
-1, -1, b3, d4, -.1, -.1e-1
0, 0, b, d, null1, null1
1+, 1, b3, d4, .1, .1e-1
2++, 2, b3b, d42, .12, .12e2
3, 3, b3b3, d43+, .113, .113e-3
4+, 4, b3b4+, d44+d, 11114, 11114e4
5++, 5, b, d45+d4, null2, null2
6, 6, b3, d46+d4+, .111116, .111116e6
7+, 7, b3b, d47+d4++, .1111117, .7e-7
tstFmtCSV */
call tst t, 'tstFmtCSV'
call envBarBegin
call tstDataClassOut '. c3 a2i i b3b c5 d4 c13 fl5 f8n2 ex6 e9n3',
, -5, + 7
call envBarLast
call fmtFCsvAll
call envBarEnd
call tstEnd t
return
endProcedure tstFmt
tstScan: procedure expose m.
/*<<tstScan.1
### start tst tstScan.1 ###########################################
scan src a034,Und hr123sdfER"st1" 'str2''mit''apo''s' .
scan n tok 4: a034 key val .
scan , tok 1: , key val .
scan n tok 3: Und key val .
scan v tok 1: key val .
scan n tok 10: hr123sdfER key val .
scan q tok 5: "st1" key val st1
scan v tok 1: key val st1
scan a tok 19: 'str2''mit''apo''s' key val str2'mit'apo's
scan v tok 1: key val str2'mit'apo's
tstScan.1 */
call tst t, 'tstScan.1'
call tstScan1 ,'l"litEins"l"litZwei"ndv" "aq1' ,
,"a034,Und hr123sdfER""st1"" 'str2''mit''apo''s' "
call tstEnd t
/*<<tstScan.2
### start tst tstScan.2 ###########################################
scan src a034,Und hr123sdfER"st1" 'str2''mit''apo''s' .
scan n tok 4: a034 key val .
scan , tok 1: , key val .
scan n tok 3: Und key val .
scan b tok 0: key val .
scan n tok 10: hr123sdfER key val .
scan " tok 5: "st1" key val st1
scan b tok 0: key val st1
scan ' tok 19: 'str2''mit''apo''s' key val str2'mit'apo's
scan b tok 0: key val str2'mit'apo's
tstScan.2 */
call tst t, 'tstScan.2'
call tstScan1 , 'ndsb1' ,
,"a034,Und hr123sdfER""st1"" 'str2''mit''apo''s' "
call tstEnd t
/*<<tstScan.3
### start tst tstScan.3 ###########################################
scan src a034,'wie 789abc
scan n tok 4: a034 key val .
scan , tok 1: , key val .
*** err: scanErr ending Apostroph(') missing
. e 1: last token scanPosition 'wie 789abc
. e 2: pos 6 in string a034,'wie 789abc
scan ' tok 1: ' key val .
scan n tok 3: wie key val .
scan s tok 0: key val .
*** err: scanErr illegal number end after 789
. e 1: last token 789 scanPosition abc
. e 2: pos 14 in string a034,'wie 789abc
scan d tok 3: 789 key val .
scan n tok 3: abc key val .
tstScan.3 */
call tst t, 'tstScan.3'
call tstScan1 , 'nds1' ,
,"a034,'wie 789abc"
call tstEnd t
/*<<tstScan.4
### start tst tstScan.4 ###########################################
scan src litEinsefr 23 sdfER'str1'litZwei "str2""mit quo"s .
scan l tok 7: litEins key val .
scan n tok 3: efr key val .
scan b tok 0: key val .
scan d tok 2: 23 key val .
scan b tok 0: key val .
scan n tok 5: sdfER key val .
scan a tok 6: 'str1' key val str1
scan l tok 7: litZwei key val str1
scan b tok 0: key val str1
scan q tok 15: "str2""mit quo" key val str2"mit quo
scan n tok 1: s key val str2"mit quo
scan b tok 0: key val str2"mit quo
tstScan.4 */
call tst t, 'tstScan.4'
call tstScan1 , 'l"litEins"l"litZwei"ndbaq1' ,
,"litEinsefr 23 sdfER'str1'litZwei ""str2""""mit quo""s "
call tstEnd t
/*<<tstScan.5
### start tst tstScan.5 ###########################################
scan src aha;+-=f ab=cdEf eF='strIng' .
scan b tok 0: key val .
scan k tok 4: no= key aha val def
scan ; tok 1: ; key aha val def
scan + tok 1: + key aha val def
scan - tok 1: - key aha val def
scan = tok 1: = key aha val def
scan k tok 4: no= key f val def
scan k tok 4: cdEf key ab val cdEf
scan b tok 4: cdEf key ab val cdEf
scan k tok 8: 'strIng' key eF val strIng
scan b tok 8: 'strIng' key eF val strIng
tstScan.5 */
call tst t, 'tstScan.5'
call tstScan1 , 'bk1'," aha;+-=f ab=cdEf eF='strIng' "
call tstEnd t
return
endProcedure tstScan
tstScanRead: procedure expose m.
/*<<tstScanRead
### start tst tstScanRead #########################################
name erste
space
name Zeile
space
nextLine
nextLine
space
name dritte
space
name Zeile
space
name schluss
space
tstScanRead */
call tst t, 'tstScanRead'
b = jBuf('erste Zeile ',,' dritte Zeile schluss ')
s = jOpen(scanRead(b))
do while \scanAtEnd(s)
if scanName(s) then call tstOut t, 'name' m.s.tok
else if scanVerify(s, ' ') then call tstOut t, 'space'
else if scanReadNL(s) then call tstOut t, 'nextLine'
else if \scanAtEnd(s) then call scanErr s, 'cannot scan'
end
call jClose s
call tstEnd t
/*<<tstScanReadMitSpaceLn
### start tst tstScanReadMitSpaceLn ###############################
name erste
spaceLn
name Zeile
spaceLn
name dritte
spaceLn
name Zeile
spaceLn
name schluss
spaceLn
tstScanReadMitSpaceLn */
call tst t, 'tstScanReadMitSpaceLn'
s = jOpen(scanRead(b))
do forever
if scanName(s) then call jOut 'name' m.s.tok
else if scanSpaceNL(s) then call jOut 'spaceLn'
else if \scanAtEnd(s) then call scanErr s, 'cannot scan'
else leave
end
call jClose s
call tstEnd t
/*<<tstScanJRead
### start tst tstScanJRead ########################################
1 jRead n tok erste val .
2 jRead s tok val .
3 jRead n tok Zeile val .
4 jRead s tok val .
5 jRead n tok dritte val .
6 jRead s tok val .
7 jRead n tok Zeile val .
8 jRead s tok val .
9 jRead n tok schluss val .
10 jRead s tok val .
11 jRead 0 tok 1 val 1
12 jRead s tok val 1
13 jRead + tok + val 1
14 jRead s tok val 1
15 jRead 0 tok 2. val 2..
16 jRead s tok val 2..
17 jRead + tok + val 2..
18 jRead . tok . val 2..
19 jRead s tok val 2..
20 jRead 0 tok +.3 val +.3
21 jRead 0 tok -45e-3 val -45E-3
22 jRead s tok val -45E-3
23 jRead " tok "a""b" val a"b
24 jRead s tok val a"b
25 jRead ' tok 'c''d' val c'd
className 1: Scan 18: Scan
tstScanJRead */
call tst t, 'tstScanJRead'
call jWrite jOpen(b,'>>'), '1 + 2. +. +.3-45e-3 "a""b"' "'c''d'"
s = jOpen(scanRead(jClose(b)))
do x=1 while jRead(s, v.x)
call jOut x 'jRead' m.v.x.type 'tok' m.v.x.tok 'val' m.v.x.val
end
call jClose s
call jOut 'className 1:' className(objClass(v.1)),
'18:' className(objClass(v.18))
call tstEnd t
return
endProcedure tstScanRead
tstScanWin: procedure expose m.
/*<<tstScanWin
### start tst tstScanWin ##########################################
info 0: last token scanPosition erste Zeile dr+
itteZe\npos 1 in line 1: erste Zeile
name erste
spaceNL
name Zeile
spaceNL
name dritteZeeeile
info 5: last token dritteZeeeile scanPosition zeile4 +
. fuenfueberSechs\npos 1 in line 4: zeile4
spaceNL
name zeile4
spaceNL
name fuenfueberSechsUnddSiebenUNDundUndUAcht
spaceNL
info 10: last token scanPosition undZehnueberElfundNochWeiterZwoel+
fundim1\npos 9 in line 10: undZehn
name undZehnueberElfundNochWeiterZwoelfundim13
spaceNL
name Punkt
infoE 14: last token Punkt scanPosition \natEnd after line 13: im13+
. Punkt
tstScanWin */
call scanWinIni
call tst t, 'tstScanWin'
b = jBuf('?erste Zeile?',,'? dritteZeeeile?', '? zeile4 ',
,'? fuenf?', '?ueberSechsUnddS?', '?iebenUNDundUndU?',
,'?Acht ?', '? ?', '? undZehn?',
,'?ueberElfundNoch?', '?WeiterZwoelfund?', '?im13 Punkt?')
s = jOpen(scanWin(b, , , 2, 15))
call tstOut t, 'info 0:' scanInfo(s)
do sx=1 while \scanAtEnd(s)
if scanName(s) then call tstOut t, 'name' m.s.tok
else if scanSpaceNL(s) then call tstOut t, 'spaceNL'
else if \scanAtEnd(s) then call scanErr s, 'cannot scan'
if sx // 5 = 0 then
call tstOut t, 'info' sx':' scanInfo(s)
end
call tstOut t, 'infoE' sx':' scanInfo(s)
call tstEnd t
/*<<tstScanWinRead
### start tst tstScanWinRead ######################################
info 0: last token scanPosition erste Zeile z3 +
com Ze\npos 1 in line 1: erste Zeile
name erste
spaceNL
name Zeile
spaceNL
name z3
info 5: last token z3 scanPosition com Zeeeile z4 come4 f+
uenf\npos 4 in line 3: z3 com Zeeeile
spaceNL
name z4
spaceNL
name fuenf
spaceNL
info 10: last token scanPosition com Sechs com sieben comAc+
ht com\npos 15 in line 5: fuenf c
name com
spaceNL
tstScanWinRead */
call tst t, 'tstScanWinRead'
call mAdd t.cmp,
, "name Sechs",
, "spaceNL",
, "name com",
, "info 15: last token com scanPosition sieben comAcht c",
|| "om com com\npos 2 in line 7: m sieben com" ,
, "spaceNL",
, "name sieben",
, "spaceNL",
, "name Acht",
, "spaceNL",
, "info 20: last token scanPosition ueberElfundNochWeit com ",
|| "elfundim13\npos 1 in line 11: ueberElfundNoch",
, "name ueberElfundNochWeit",
, "spaceNL",
, "name im13",
, "spaceNL",
, "name Punkt",
, "info 25: last token Punkt scanPosition \natEnd after line ",
|| "13: im13 Punkt",
, "infoE 26: last token Punkt scanPosition \natEnd after line",
|| " 13: im13 Punkt"
b = jBuf('?erste Zeile?',,'? z3 com Zeeeile?', '? z4 come4 ',
,'? fuenf c?', '?om Sechs co?', '?m sieben com?',
,'?Acht com com ?', '? com ?', '? com undZehn?',
,'?ueberElfundNoch?', '?Weit com elfund?', '?im13 Punkt?')
s = scanWin(b, , , 2, 15)
call scanOpts s, , , 'com'
call tstOut t, 'info 0:' scanInfo(jOpen(s))
do sx=1 while \scanAtEnd(s)
if scanName(s) then call tstOut t, 'name' m.s.tok
else if scanSpaceNL(s) then call tstOut t, 'spaceNL'
else if \scanAtEnd(s) then call scanErr s, 'cannot scan'
if sx // 5 = 0 then
call tstOut t, 'info' sx':' scanInfo(s)
end
call tstOut t, 'infoE' sx':' scanInfo(s)
call tstEnd t
return
endProcedure tstScanWin
tstScanSql: procedure expose m.
call scanWinIni
/*<<tstScanSqlId
### start tst tstScanSqlId ########################################
sqlId ABC
spaceNL
sqlId AB__345EF
spaceNL
tstScanSqlId */
call tst t, 'tstScanSqlId'
b = jBuf('abc -- kommentar', right('ab_', 72), '_345ef-- kom')
s = jOpen(scanSql(b))
do sx=1 while \scanAtEnd(s)
if scanSqlID(s) then call tstOut t, 'sqlId' m.s.val
else if scanSpaceNL(s) then call tstOut t, 'spaceNL'
else call scanErr s, 'cannot scan'
end
call tstEnd t
/*<<tstScanSqlDelimited
### start tst tstScanSqlDelimited #################################
sqlDeId ABC
spaceNL
sqlDeId AB_3F
spaceNL
sqlDeId abc
spaceNL
sqlDeId ab_Ef
spaceNL
tstScanSqlDelimited */
call tst t, 'tstScanSqlDelimited'
b = jBuf('abc -- kommentar',,' -- ',,right('ab_', 72),'3F-- kom',
, '"abc" -- ko', ' -- ',,right('"ab_', 72),'Ef"-- kom')
s = jOpen(scanSql(b))
do sx=1 while \scanAtEnd(s)
if scanSqlDeID(s) then call tstOut t, 'sqlDeId' m.s.val
else if scanSpaceNL(s) then call tstOut t, 'spaceNL'
else call scanErr s, 'cannot scan'
end
call tstEnd t
/*<<tstScanSqlQualified
### start tst tstScanSqlQualified #################################
sqlQuId ABC 1 ABC
sqlQuId AB_3F 1 AB_3F
sqlQuId abc 1 abc
sqlQuId ab_Ef 1 ab_Ef
sqlQuId EINS.Zwei.DREI 3 EINS
sqlQuId vi er.fu enf 2 vi er
tstScanSqlQualified */
call tst t, 'tstScanSqlQualified'
b = jBuf('abc -- kommentar',,' -- ',,right('ab_', 72),'3F-- kom',
, '"abc" -- ko', ' -- ',right('"ab_', 72),'Ef"-- kom',
, 'eins."Zwei', '" -- com', ' . -- com', ' -- com',
, 'drei -- ko', '"vi er"."fu enf " -- co')
s = jOpen(scanSql(b))
do sx=1 while \scanAtEnd(s)
if scanSqlQuID(s) then
call tstOut t, 'sqlQuId' m.s.val m.s.val.0 m.s.val.1
else if scanSpaceNL(s) then call tstOut t, 'spaceNL'
else call scanErr s, 'cannot scan'
end
call tstEnd t
/*<<tstScanSqlNum
### start tst tstScanSqlNum #######################################
sqlNum 1
spaceNL
sqlNum 2..
spaceNL
sqlNum .3
spaceNL
sqlNum 4.5
spaceNL
sqlNum +6
spaceNL
sqlNum +7.03
spaceNL
sqlNum -8
spaceNL
sqlNum -.9
spaceNL
sqlNum 1E2
spaceNL
sqlNum -2.E-2
spaceNL
sqlNum +.3E+3
spaceNL
tstScanSqlNum */
call tst t, 'tstScanSqlNum'
b = jBuf('1 2. .3 4.5 +6 + --kom', , ' -- com ', , ' 7.03 -8 - .9',
'1e2 - 2.e-2 + .3e+3')
s = jOpen(scanSql(b))
do sx=1 while \scanAtEnd(s)
if scanSqlNum(s) then
call tstOut t, 'sqlNum' m.s.val
else if scanSpaceNL(s) then call tstOut t, 'spaceNL'
else call scanErr s, 'cannot scan'
end
call tstEnd t
/*<<tstScanSqlNumUnit
### start tst tstScanSqlNumUnit ###################################
sqlNumUnit 1 KB
spaceNL
sqlNumUnit .3 MB
sqlNumUnit .5
sqlNumUnit +6.E-5 B
spaceNL
sqlNumUnit -7
char *
spaceNL
sqlNumUnit -.8
char T
char B
spaceNL
*** err: scanErr scanSqlNumUnit after +9. bad unit TB
. e 1: last token Tb scanPosition .
. e 2: pos 41 in line 1: 1 kb .3mB.5 + 6.e-5B -7* -.8 TB + 9.T+
b
sqlNumUnit +9..
spaceNL
tstScanSqlNumUnit */
call tst t, 'tstScanSqlNumUnit'
b = jBuf('1 kb .3mB.5 + 6.e-5B -7* -.8 TB + 9.Tb')
s = jOpen(scanSql(b))
do sx=1 while \scanAtEnd(s)
if scanSqlNumUnit(s, 0, 'B KB MB') then
call tstOut t, 'sqlNumUnit' m.s.val
else if scanSpaceNL(s) then call tstOut t, 'spaceNL'
else if scanChar(s ,1) then call tstOut t, 'char' m.s.tok
else call scanErr s, 'cannot scan'
end
call tstEnd t
return
endProcedure tstScanSql
/*--- one single test scan with lines to scan in stem ln -------------*/
tstScan1:
parse arg sc, classs, ln
if sc == '' then do
call tstOut t, 'scan src' ln
call scanSrc scanReset(s), ln
end
else do
call tstOut t, 'scan scanner' sc
s = sc
end
do forever
x = tstScanType(s, classs)
if x == '' then
leave
call tstOut t, 'scan' x 'tok' length(m.s.tok)':' m.s.tok ,
'key' m.s.key 'val' m.s.val
end
return
endProcedure tstScan1
tstScanType: procedure expose m.
parse arg s, opt
cx = 1
a2 = ''
res = 0
do while cx <= length(opt)
f = substr(opt, cx, 1)
cx = cx + 1
if pos(substr(opt, cx, 1), "'""") > 0 then do
m.tstScanType.src = opt
m.tstScanType.pos = cx
call scanString tstScanType
a2 = m.tstScanType.val
cx = m.tstScanType.pos
end
if f == 'a' then
res = scanString(s, "'")
else if f == 'b' then
res = scanSpaceNl(s)
else if f == 'c' then
res = scanChar(s, a2)
else if f == 'd' then
res = scanNat(s, a2)
else if f == 'k' then
res = scanKeyValue(s, 'def')
else if f == 'l' then
res = scanLit(s, a2)
else if f == 'q' then
res = scanString(s, '"')
else if f == 'v' then
res = scanVerify(s, a2)
else if f == 'w' then
res = scanWord(s)
else if f == 'y' then
res = scanVerify(s, a2, 'm')
if res then
return f
end
return scanType(s)
endProcedure tstScanType
/* copx tstBase end *************************************************/
/* copx tst begin ****************************************************
test infrastructure
***********************************************************************/
/*--- migrate all compares to new ones:
tstCI input compare
tstCO ouptut migrated compares
tstCIO inpunt and output -------------------------------------*/
tstCI: procedure expose m.
parse arg m, nm
m.m.CIO = 0
signal tstCIwork
tstCIO: procedure expose m.
parse arg m, nm
m.m.CIO = 1
tstCIwork:
m.m.name = nm
m.m.cmp.1 = left('### start tst' nm '', 67, '#')
do ix=2 to arg()-1
m.m.cmp.ix = arg(ix+1)
end
m.m.cmp.0 = ix-1
if m.m.CIO then
call tstCO m
return
tstCO: procedure expose m.
parse arg m
call tst2dpSay m.m.name, m'.CMP', 68
return
/*--- initialise m as tester with name nm
use inline input nm as compare lines -----------------------*/
tst: procedure expose m.
parse arg m, nm, cmpSt
call tstIni
m.m.name = nm
m.m.inIx = 0
m.m.out.0 = 0
m.m.err = 0
m.tst.act = m
m.tst.tests = m.tst.tests+1
m.m.trans.0 = 0
if cmpSt == '' then do
cmpSt = mCut(t'.CMP', 0)
call tst4dp cmpSt, mapInline(nm)
end
m.m.cmp = cmpSt
call mAdd mCut(m'.IN', 0), 'tst in line 1 eins ,' ,
, 'tst in line 2 zwei ; ' ,
, 'tst in line 3 drei .schluss.'
call tstOut m, left('### start tst' nm '', 67, '#')
call errReset 'h', 'return tstErrHandler(ggTxt)'
if m.tst.ini.j \== 1 then do
call outDest 'i', 'call tstOut' quote(m)', msg'
end
else do
call oMutate m, 'Tst'
m.m.jReading = 1
m.m.jWriting = 1
if m.tst.ini.e \== 1 then do
m.m.oldJin = m.j.jIn
m.m.oldJOut = m.j.jOut
m.j.jIn = m
m.j.jOut = m
end
else do
if m.env.0 <> 1 then
call tstErr m, 'm.env.0' m.env.0 '<> 1'
call envPush '<-%' m, '>-%' m
end
end
return m
endProcedure tst
tstEnd: procedure expose m.
parse arg m, opt
cmp = m.m.cmp
m.m.jReading = 0
m.m.jWriting = 0
m.tst.act = ''
if m.tst.ini.j == 1 then do
m.m.jReading = 0
m.m.jWriting = 0
if m.tst.ini.e \== 1 then do
m.j.jIn = m.m.oldJin
m.j.jOut = m.m.oldJOut
end
else do
if m.j.jIn \== m | m.j.jOut \== m then
call tstErr m, m.j.jIn '\==' m '|' m.j.jOut '\==' m
call envPop
if m.env.0 <> 1 then
call tstErr m, 'm.env.0' m.env.0 '<> 1'
end
end
if m.m.out.0 \= m.cmp.0 then do
call tstErr m, 'old' m.cmp.0 'lines \= new' m.m.out.0
do nx = m.m.out.0 + 1 to min(m.m.out.0+10, m.cmp.0)
say 'old - ' m.cmp.nx
end
end
call errReset 'h'
if m.m.err > 0 then do
say 'new lines:' (m.m.out.0 - 1)
call tst2dpSay m.m.name, m'.OUT', 68
end
say left('###' m.m.name 'end with' m.m.err 'errors ', 67, '#')
return
endProcedure tstEnd
tst2dp: procedure expose m.
parse arg st, dp, ml
dx = m.dp.0
do sx=1 to m.st.0
li = m.st.sx
cx = 1
do until cx > length(li)
c = substr(li, cx, 1)
ou = left('.', strip(c) == '' | pos(c, '.+') > 0)
ex = min(length(li),cx+ml-length(ou)-2)
ou = ou || substr(li, cx, ex+1-cx)
dx = dx + 1
c = right(ou, 1)
if ex < length(li) then
m.dp.dx = ou || '+'
else if strip(c) == '' | pos(c, '.+') > 0 then
m.dp.dx = ou || '.'
else
m.dp.dx = ou
cx = ex +1
end
end
m.dp.0 = dx
return
endProcedure tst2dp
tst2dpSay: procedure expose m.
parse arg name, st, ml
say '/*<<'name
call tst2dp st, mCut('TST.TMP', 0), 68
do nx=1 to m.tst.tmp.0
say ' ' m.tst.tmp.nx
end
say name '*/'
return tst2dpSay
tst4dp: procedure expose m.
parse arg st, dp
sx = m.st.0
inData = 0
data = ''
do dx=1 to m.dp.0
li = strip(m.dp.dx)
if pos(left(li, 1), '.+') > 0 then
li = substr(li, 2)
if right(li, 1) == '+' then do
inData = 1
data = data || left(li, length(li)-1)
iterate
end
if right(li, 1) == '.' then
li = left(li, length(li)-1)
sx = sx + 1
m.st.sx = data || li
inData = 0
data = ''
end
m.st.0 = sx
if inData then
call err 'end inData'
return
endProcedure tst4dp
/*--- write to test: say lines and compare them ----------------------*/
tstWrite: procedure expose m.
parse arg m, arg
call tstOut m, 'jOut:' arg
return
endProcedure tstWrite
tstOut: procedure expose m.
parse arg m, arg
do tx=m.m.trans.0 by -1 to 1
arg = repAll(arg, word(m.m.trans.tx, 1), subword(m.m.trans.tx, 2))
end
call mAdd m'.OUT', arg
nx = m.m.out.0
cmp = m.m.cmp
c = m.cmp.nx
if nx > m.cmp.0 then do
if nx = m.cmp.0+1 then
call tstErr m, 'more new Lines' nx
end
else if c \== arg then do
do cx=1 to min(length(c), length(arg)) ,
while substr(c, cx, 1) == substr(arg, cx, 1)
end
msg = 'old line' nx '<> new overnext, firstDiff' cx',',
'len old' length(c)', new' length(arg)
if cx > 10 then
msg = overlay('|', msg, cx-10)
call tstErr m, msg
say c
end
say arg
return 0
endProcedure tstOut
tstWriteR: procedure expose m.
parse arg m, var
if symbol('m.class.o2c.var') \== 'VAR' then
call tstOut t, m.var
else do
oo = outDest('=')
call outDest 'i', 'call tstOut "'m'", msg'
call classOut , var, 'tstR: '
call outDest 'i', oo
end
return
endProcedure tstWriteR
tstRead: procedure expose m.
parse arg m, arg
ix = m.m.inIx + 1
m.m.inIx = ix
if ix <= m.m.in.0 then do
m.arg = m.m.in.ix
drop m.class.o2c.arg
call tstOut m, '#jIn' ix'#' m.arg
return 1
end
call tstOut m, '#jIn eof' ix'#'
return 0
endProcedure tstRead
tstFilename: procedure
parse arg suf, opt
os = errOS()
if os == 'TSO' then do
dsn = dsn2jcl('~tmp.tst.'suf)
if opt = 'r' then do
if sysDsn("'"dsn"'") \== 'DATASET NOT FOUND' then
call adrTso "delete '"dsn"'"
end
call csiOpen 'TST.CSI', dsn'.**'
do while csiNext('TST.CSI', 'TST.FINA')
say 'deleting csiNext' m.tst.fina
call adrTso "delete '"m.tst.fina"'"
end
end
return dsn
end
else if os == 'LINUX' then do
if abbrev(suf, '/') then
fn = suf
else
fn = .Stream$mc$new('~/tmp/tst/'suf)$mc$qualify /* full path */
if opt \= 'r' then
nop
else if sysIsFile(fn) then
call sysFileDelete fn
else if sysIsFileDirectory(fn) then
call adrSh 'rm -r' fn
return fn
end
else
call err 'tstFilename does not implement os' os
endProcedure tstFilename
/*--- say total errors and fail if not zero --------------------------*/
tstTotal: procedure expose m.
say '######'
say '######'
say '######' m.tst.tests 'tests with' ,
m.tst.err 'errors in' m.tst.errNames
say '######'
say '######'
if m.tst.err \== 0 then
call err m.tst.err 'errors total'
return
endProcedure tstTotal
/*--- test err: message, count it and continue -----------------------*/
tstErr: procedure expose m.
parse arg m, msg
say '### error' msg
m.m.err = m.m.err + 1
m.tst.err = m.tst.err + 1
nm = m.m.name
if wordPos(nm, m.tst.errNames) < 1 then
m.tst.errNames = m.tst.errNames nm
return
endProcedure tstErr
/*--- tstErrHandler: intercept errors --------------------------------*/
tstErrHandler: procedure expose m.
parse arg ggTxt
if m.tst.act == '' then
call err ggTxt
m.tstErrHandler.0 = 0
oo = outDest('=')
call outDest 's', tstErrHandler
call errSay ggTxt
call outDest 'i', oo
call tstOut m.tst.act, '*** err:' m.tstErrHandler.1
do x=2 to m.tstErrHandler.0
call tstOut m.tst.act, ' e' (x-1)':' m.tstErrHandler.x
end
return 0
endSubroutine tstErrHandler
/*--- tstIni: global initialization ----------------------------------*/
tstIni: procedure expose m.
if m.tst.ini \== 1 then do
m.tst.ini = 1
call mapIni
m.tst.err = 0
m.tst.errNames = ''
m.tst.tests = 0
m.tst.act = ''
end
if m.tst.ini.j \== 1 & m.j.ini == 1 then do
m.tst.ini.j = 1
call classNew 'n Tst u JRW', 'm',
, "jRead return tstRead(m, var)",
, "jWrite call tstOut m, line",
, "jWriteR call tstWriteR m, var"
end
if m.tst.ini.e \== 1 & m.env.ini == 1 then do
m.tst.ini.e = 1
end
return
endProcedure tstIni
/* copx tst end **************************************************/
/* copx tstData begin *************************************************/
tstData: procedure expose m.
parse arg ty 2 le 'n' nu, l, r, num
abs = abs(num)
if nu \== '' then do
if abs // 5 = 0 then
return 'null' || (abs % 5 // nu + 1)
end
if ty = 'c' then do
if le = '' then
le = 8
le = abs // le + 1
if r = '' then
r = '+'
return left(l || num || r, le, right(r, 1))
end
if pos(ty, 'ief') < 1 then
call err 'bad type' ty
nn = abs
if abbrev(num, '-') | abbrev(num, '+') then
parse var num si 2 nn
else
si = ''
if ty == 'e' then
ex = 'e' || left('-', abs // 2) || (abs // 15)
else
ex = ''
if le \== '' then
nn = right(nn, abs // max(1, le - length(si||ex)) + 1, 1)
if ty \== 'i' & (abs // 4) \= 0 & length(nn) > 1 then
nn = overlay('.', nn, length(nn) - abs // length(nn))
return si || nn || ex
endProcedure tstData
tstDataClassFo: procedure expose m.
parse arg flds
ty = ''
do fx=1 by 2 to words(flds)
if word(flds, fx) = '.' then
ty = ty', v'
else
ty = ty', f' word(flds, fx) 'v,'
end
t = classNew('n tstData* u' substr(ty, 2))
fo = oNew(m.t.name)
fs = oFlds(fo)
do fx=1 to m.fs.0
f = fo || m.fs.fx
m.f = word(flds, 2*fx)
end
return fo
endProcedure tstDataClassFo
tstDataClassOut: procedure expose m.
parse arg flds, f, t
fo = tstDataClassFo(flds)
fs = oFlds(fo)
do x=f to t
o = oCopyNew(fo)
do fx=1 to m.fs.0
na = substr(m.fs.fx, 2)
f = o || m.fs.fx
m.f = tstData(m.f, na, '+'na'+', x)
end
call jOuR o
end
return
endProcedure tstDataClassOut
/* copx tstData end ***************************************************/
/* copy tstAll end **************************************************/
/* copy fmt begin **************************************************/
/*--- format the first arg by the format in the second ---------------*/
fmt: procedure
parse arg v, f 2 l
/* say 'fmt' v',' f l */
if abbrev('-', f) then
return v
else if f == 'l' then
return left(v, l)
else if f == 'r' then
return right(v, l)
else if f == 'f' then do
parse value l'.0.0.' with b '.' a '.' e '.'
return format(v, b, a, e, 0)
end
else if f == 'e' then do
parse var l b '.' a '.' e '.'
if b == '' then b = 2
if a == '' then a = 2
if e == '' then e = 2
res = format(v, b, a, e, 0)
y = length(res)-e-1
if substr(res, y) = '' then
return left(res, y-1)left('E', e+1, 0)
else if substr(res, y+1, 1) == '+' then
return left(res, y)substr(res, y+2)
else if substr(res, y+2, 1) == '0' then
return left(res, y+1)substr(res, y+3)
else
call err 'formatoverflow' f || l 'for' v '-->' res
end
else if f = 's' then
if l == '' then
return strip(v, 't')
else
return strip(v, l)
else if f == 'w' then do
parse var l st ',' le
return substr(v, st, le)
end
else
call err 'bad format' f l 'for' v
endProcedure fmt
/*--- format special (title, null Value also for numbers) ------------*/
fmtS: procedure expose m.
parse arg v, ty 2 l
if ty == 'f' then do
if \ dataType(v, 'n') then do
parse value l'.0.0.' with b '.' a '.' e '.'
return right(v, b + a + (a \== 0) + e + 2 * (e > 0))
end
end
else if ty == 'e' then do
if \ dataType(v, 'n') then do
parse var l b '.' a '.' e '.'
if b == '' then b = 2
if a == '' then a = 2
if e == '' then e = 2
return right(v, b + a + (a \== 0) + e + (e > 0))
end
end
return fmt(v, ty || l)
endProcedure fmtS
/* copy fmt end **************************************************/
/* copy fmtF begin **************************************************/
fmtFCsvAll: procedure expose m.
parse arg fSep
if fSep = '' then
fSep = ','
if \ jIn(i) then
return
f = oFlds(i)
li = ''
do fx=1 to m.f.0
li = li',' substr(m.f.fx, 2)
end
call jout substr(li, 3)
do until \ jIn(i)
li = ''
do fx=1 to m.f.0
if m.f.fx = '' then do
li = li',' m.i
end
else do
fld = substr(m.f.fx, 2)
li = li',' m.i.fld
end
end
call jout substr(li, 3)
end
return
endProcedure fmtFCsvAll
fmtFAdd: procedure expose m.
parse arg m
fx = m.m.0
do ax=2 to arg()
fx = fx + 1
parse value arg(ax) with m.m.fx.fld m.m.fx.fmt m.m.fx.tit
end
m.m.0 = fx
return m
endProcedure fmtFAdd
fmtFAddFlds: procedure expose m.
parse arg m, st
fx = m.m.0
do sx=1 to m.st.0
fx = fx + 1
parse value m.st.sx with m.m.fx.fld m.m.fx.fmt m.m.fx.tit
end
m.m.0 = fx
return m
endProcedure fmtFAddFlds
fmtF: procedure expose m.
parse arg m, st
if arg() >= 3 then
mid = arg(3)
else
mid = ' '
li = ''
do fx=1 to m.m.0
f = st || m.m.fx.fld
li = li || mid || fmtS(m.f, m.m.fx.fmt)
end
return substr(li, 1 + length(mid))
endProcedure fmtF
fmtFReset: procedure expose m.
parse arg m
m.m.0 = 0
return m
endProcedure fmtFReset
fmtFWriteAll: procedure expose m.
parse arg m, optRdr, wiTi
b = env2buf(optRdr)
st = b'.BUF'
if m.st.0 < 1 then
return
if m.m.0 < 1 then
call fmtFAddFlds m, oFlds(st'.1')
call fmtFDetect m, st
if wiTi \== 0 then
call jOut fmtFTitle(m)
do sx=1 to m.st.0
call jOut fmtF(m, st'.'sx)
end
return
fmtFWriteAll
fmtFTitle: procedure expose m.
parse arg m
if arg() >= 2 then
mid = arg(2)
else
mid = ' '
li = ''
do fx=1 to m.m.0
if m.m.fx.tit \= '' then
t = m.m.fx.tit
else if m.m.fx.fld = '' then
t = '='
else
t = substr(m.m.fx.fld, 1+abbrev(m.m.fx.fld, '.'))
li = li || mid || fmtS(t, m.m.fx.fmt)
end
return substr(li, 1 + length(mid))
res = ''
fs = m.form.FLDS
do ix=1 to m.fs.0
res = res fmtS(m.fs.ix, m.form.ix)
end
return substr(res, 2)
endProcedure fmtFldTitle
fmtFldTitle: procedure expose m.
parse arg form
res = ''
fs = m.form.FLDS
do ix=1 to m.fs.0
res = res fmtS(m.fs.ix, m.form.ix)
end
return substr(res, 2)
endProcedure fmtFldTitle
fmtFld: procedure expose m.
parse arg form, st
res = ''
fs = m.form.FLDS
do ix=1 to m.fs.0
f = m.fs.ix
res = res fmt(m.st.f, m.form.ix)
end
return substr(res, 2)
endProcedure fmtData
fmtFldSquash: procedure expose m.
parse arg newFo, class, src
fs = oFlds(class)
do fx = 1 to m.fs.0
fd = m.fs.fx
lMi = 9e9
lMa = 0
rMi = 9e9
rMa = 0
len = 0
do sx = 1 to m.src.0
x = verify(m.src.sx.fd, ' ', 'n')
if x < 1 then
iterate
lMi = min(lMi, x)
lMa = max(lMa, x)
x = length(strip(m.src.sx.fd, 't'))
rMi = min(rMi, x)
rMa = max(rMa, x)
end
if rMa = 0 then
m.newFo.fx = 'w1,1'len
else
m.newFo.fx = 'w'lMi',' || (rMa+1-lMi)
end
m.newFo.0 = m.fs.0
m.newFo.flds = fs
return newFo
endProcedure fmtFldSquash
fmtFDetect: procedure expose m.
parse arg m, st
do fx=1 to m.m.0
if m.m.fx.fmt = '' then
m.m.fx.fmt = fmtFDetect1(st, m.m.fx.fld)
end
return m
endProcedure fmtDetect
fmtFDetect1: procedure expose m.
parse arg st, suf
aMa = -1
aCnt = 0
aDiv = 0
nCnt = 0
nMi = ''
nMa = ''
nDi = -1
nBe = -1
nAf = -1
eMi = ''
eMa = ''
do sx=1 to m.st.0
f = st'.'sx || suf
v = m.f
aMa = max(aMa, length(v))
if \ dataType(v, 'n') then do
aCnt = aCnt + 1
if aDiv <=3 then
if aDiv.v \== 1 then do
aDiv.v = 1
aDiv = aDiv + 1
end
iterate
end
nCnt = nCnt + 1
if nMi == '' then
nMi = v
else
nMi = min(nMi, v)
if nMa == '' then
nMa = v
else
nMa = max(nMa, v)
parse upper var v man 'E' exp
if exp \== '' then do
en = substr(format(v, 2, 2, 9, 0), 7)
if en = '' then
en = exp
if eMi == '' then
eMi = en
else
eMi = min(eMi, en)
if eMa == '' then
eMa = en
else
eMa = max(eMa, en)
end
parse upper var man be '.' af
nBe = max(nBe, length(be))
nAf = max(nAf, length(af))
nDi = max(nDi, length(be || af))
end
/* say 'suf' suf aCnt 'a len' aMa 'div' aDiv
say ' ' nCnt 'n' nMi'-'nMa 'be' nBe 'af' nAf 'di' nDi 'ex' eMi'-'eMa
*/ if nCnt = 0 | aDiv > 3 then
newFo = 'l'max(0, aMa)
else if eMi \== '' then do
eMa = max(eMa, substr(format(nMa, 2, 2, 9, 0), 7))
newFo = 'e' || (1+(eMi < 0)) || '.' || (max(0, nDi-1))'.' ,
|| max(length(eMa+0), length(eMi+0))
end
else if nAf > 0 then
newFo ='f'nBe'.'nAf
else
newFo ='f'nBe'.0'
/* say ' ' newFo
*/ return newFo
endProcedure fmtFDetect1
fmtFldRW: procedure expose m.
parse arg fo
ty = oGetClassPara(m.j.jIn)
call assert 'oFlds(ty) == m.fo.flds', 'fo different flds than class'
call jOut fmtFldTitle(fo)
do while jIn(ii)
call jOut fmtFld(fo, ii)
end
return
endProcedure fmtClassRW
fmtFldSquashRW: procedure expose m.
parse arg in, opCl
if in = '' then
in = m.j.jIn
if opCl == 'opCl' then
call jOpen in, 'r'
ty = oGetClassPara(in)
flds = oFlds(ty)
st = 'FMT.CLASSAD'
do ix=1 while jRead(in, st'.'ix)
end
m.st.0 = ix - 1
fo = fmtFldSquash(sqFo, ty, st)
call jOut fmtFldTitle(fo)
do ix = 1 to m.st.0
call jOut fmtFld(fo, st'.'ix)
end
if opCl == 'opCl' then
call jClose in
return
endProcedure fmtFldSquashRW
/* copy fmtF end * **************************************************/
/* copy sort begin ****************************************************/
sort: procedure expose m.
parse arg i, o
call sort1 i, 1, m.i.0, o, 1, sort.work, 1
m.o.0 = m.i.0
return
endProcedure sort
sort1: procedure expose m.
parse arg i, i0, le, o, o0, w, w1
if le <= 1 then do
if le = 1 then
m.o.o0 = m.i.i0
return
end
h = (le + 1) % 2
call sort1 i, i0, h, o, o0+le-h, w, w1
call sort1 i, i0+h, le-h, w, w1, o, o0
call sortMerge o, o0+le-h, o0+le, w, w1, w1+le-h, o, o0
return
endProcedure sort1
sortMerge: procedure expose m.
parse arg l, l0, le, r, r0, re, o, o0
do while l0 < le & r0 < re
if m.l.l0 <<= m.r.r0 then do
m.o.o0 = m.l.l0
l0 = l0 + 1
end
else do
m.o.o0 = m.r.r0
r0 = r0 + 1
end
o0 = o0 + 1
end
do while l0 < le
m.o.o0 = m.l.l0
l0 = l0 + 1
o0 = o0 + 1
end
do while r0 < re
m.o.o0 = m.r.r0
r0 = r0 + 1
o0 = o0 + 1
end
return
endProcedure sortWork
/* copy sort end ****************************************************/
/* copy match begin ***************************************************/
/************************************* begin copy match ******/
/*--- wildCard matching with the following wildchars:
* 0-n chars
? 1 char
fill matched expressions instem st if st is non empty
return 1 if mask matches wert ----------------------------------*/
match: procedure expose m.
parse arg wert, mask, st
if st == '' then
return matchRO(wert, mask)
m.st.0 = -9
return matchSt(wert, mask, st, 0)
endProcedure match
/*--- return the fixed prefix of maskt -------------------------------*/
matchPref: procedure
arg mask, suff
ix = verify(mask, '*?', 'm')
if ix = 0 then
return mask
else
return left(mask, ix-1)suff
endProcedure matchPref
/*--- return true if mask matches wert -------------------------------*/
matchRO: procedure
arg wert, mask
ix = verify(mask, '*?', 'm')
if ix < 1 then return (mask == wert)
if length(wert) < ix-1 then return 0
if left(mask, ix-1) \== left(wert, ix-1) then return 0
if substr(mask, ix, 1) == '?' then do
if length(wert) < ix then return 0
return matchRO(substr(wert, ix+1), substr(mask, ix+1))
end
mask = substr(mask, ix+1) /* * 0 - n Chars */
do ex = 1+length(wert) to ix by -1
if matchRO(substr(wert, ex), mask) then return 1
end
return 0
endProcedure matchRO
/*--- wildCard matching: fill matched expressions instem st
return 1 if mask matches wert ----------------------------------*/
matchSt: procedure expose m.
parse arg wert, mask, st, sx
ix = verify(mask, '*?', 'm')
if ix < 1 then do
if mask \== wert then
return 0
m.st.0 = sx
return 1
end
if \ abbrev(wert, left(mask, ix-1)) then
return 0
reMa = substr(mask, ix+1)
sx = sx + 1
if substr(mask, ix, 1) == '?' then do /* ? 1 Character */
if length(wert) < ix then
return 0
m.st.sx = substr(wert, ix, 1)
return matchSt(substr(wert, ix+1), reMa, st, sx)
end
do lx = 1+length(wert) to ix by -1 /* greedy: from all to empty */
if matchSt(substr(wert, lx), reMa, st, sx) then do
m.st.sx = substr(wert, ix, lx-ix)
return 1
end
end
return 0
endProcedure matchSt
matchTrans: procedure expose m.
parse arg mask, st
r = ''
ox = 1
sx = 0
ix = verify(mask, '*?', 'm')
do sx=1 to m.st.0 while ix > 0
if sx > m.st.0 then
call err 'matchTrans('mask',' st') has only' ,
m.st.0 'variables'
r = r || substr(mask, ox, ix-ox)m.st.sx
ox = ix+1
ix = verify(mask, '*?', 'm', ox)
end
if ix > 0 then
call err 'matchTrans('mask',' st') has only' ,
m.st.0 'variables'
return r || substr(mask, ox)
endProcedure matchTrans
/* copy match end *****************************************************/
/* copy comp begin *****************************************************
the shell compiler
syntax and semantics of the shell language see javaDoc
***********************************************************************/
/*--- module initialisation ------------------------------------------*/
compIni: procedure expose m.
if m.compIni = 1 then
return
m.compIni = 1
call envIni
call scanReadIni
cc = classNew('n Compiler u')
return
endProcedure compIni
/*--- constructor of Compiler ----------------------------------------*/
comp: procedure expose m.
parse arg src
nn = oNew('Compiler')
m.nn.scan = jOpen(scanRead(src))
return compReset(nn, src)
endProcedure comp
compReset: procedure expose m.
parse arg m, src
call scanReadReset m.m.scan, src, , ,'$*'
m.m.chDol = '$'
m.m.chSpa = ' '
m.m.chNotWord = '${}=%:' || m.m.chSpa
m.m.stack = 0
return m
endProceduere compReset
/*--- push an empty stem on the stack --------------------------------*/
compPushStem: procedure expose m.
parse arg m
m.m.stack = m.m.stack + 1
pp = m'.STACK'm.m.stack
m.pp.0 = 0
return pp
endProcedure compPushStem
/*--- push a stem from the stack -------------------------------------*/
compPop: procedure expose m.
parse arg m, pp
if pp \== m'.STACK'm.m.stack then
call err 'compPop pp' pp 'mismatch to' m'.STACK'm.m.stack
m.m.stack = m.m.stack - 1
return m
endProcedure compPop
/*--- compile the source and return an oRunner with the code ---------*/
compile: procedure expose m.
parse arg m, type
if type == 's' then do
what = "shell"
expec = "pipe or $;";
call compSpNlComment m
src = compShell(m)
end
else if type == 'd' then do
what = "data";
expec = "sExpression or block";
src = compData(m, 0)
end
else do
call err "bad type" type
end
if \ scanAtEnd(m.m.scan) then
call scanErr m.m.scan, expec "expected: compile" what ,
" stopped before end of input"
call jClose m.m.scan
r = oRunner(src)
return r
endProcedure compile
/*--- compile data lines return stmts or expr ------------------------*/
compData: procedure expose m.
parse arg m, makeExpr
s = m.m.scan
exprs = compPushStem(m)
do forever
aftEol = 0
do forever
text = "";
do forever
if scanVerify(s, m.m.chDol, 'm') then
text = text || m.s.tok
if \ compComment(m) then
leave
end
nd = compExpr(m, 'd')
befEol = scanReadNL(s)
if nd <> '' | (aftEol & befEol) ,
| verify(text, m.m.chSpa) > 0 then do
if text \== '' then
text = quote(text)
if text \== '' & nd \= '' then
text = text '|| '
call mAdd exprs, 'e' compNull2EE(text || nd)
end
if \ befEol then
leave
aftEol = 1
end
one = compStmt(m)
if one == '' then
one = compRedirIO(m, 0)
if one == '' then
leave
call mAdd exprs, 's' one
end
if m.exprs.0 < 1 then do
if makeExpr then
res = '""'
else
res = ';'
end
else do
do x=1 to m.exprs.0 while left(m.exprs.x, 1) = 'e'
end
res = ''
if makeExpr & x > m.exprs.0 then do
res = substr(m.exprs.1, 3)
do x=2 to m.exprs.0
res = res substr(m.exprs.x, 3)
end
end
else do
do x=1 to m.exprs.0
if left(m.exprs.x, 1) = 'e' then
res = res 'call jOut'
res = res substr(m.exprs.x, 3)';'
end
if makeExpr then
res = "mCat("compStmts2ExprBuf(res)"'.BUF', ' ')"
end
end
call compPop m, exprs
return res
endProcedure compData
/*--- compile shell and return code ----------------------------------*/
compShell: procedure expose m.
parse arg m
res = ''
do forever
one = compPipe(m)
if one \== '' then
res = res one
if \ scanLit(m.m.scan, '$;') then
return strip(res)
call compSpNlComment m
end
endProcedure compShell
/*--- compile an expression, type d=data, w=word, s=strip ------------*/
compExpr: procedure expose m.
parse arg m, type
res = ''
if type == 'w' then
charsNot = m.m.chNotWord
else
charsNot = m.m.chDol
s = m.m.scan
if pos(type, 'sw') > 0 then
call compSpComment m
do forever
txt = ''
do forever
if scanVerify(s, charsNot, 'm') then
txt = txt || m.s.tok
if \ compComment(m) then
leave
end
pr = compPrimary(m)
if pr = '' & pos(type, 'sw') > 0 then
txt = strip(txt, 't')
if txt \== '' then
res = res '||' quote(txt)
if pr = '' then do
if pos(type, 'sw') > 0 then
call compSpComment m
if res == '' then
return ''
return substr(res, 5)
end
res = res '||' pr
end
return ''
endProcedure compExpr
/*--- push an empty stem on the stack --------------------------------*/
compPushStem: procedure expose m.
parse arg m
m.m.stack = m.m.stack + 1
pp = m'.STACK'm.m.stack
m.pp.0 = 0
return pp
endProcedure compPushStem
/*--- push a stem from the stack -------------------------------------*/
compPop: procedure expose m.
parse arg m, pp
if pp \== m'.STACK'm.m.stack then
call err 'compPop pp' pp 'mismatch to' m'.STACK'm.m.stack
m.m.stack = m.m.stack - 1
return m
endProcedure compPop
/*--- compile a primary and return code ------------------------------*/
compPrimary: procedure expose m.
parse arg m
s = m.m.scan
if \ scanLit(s, '$') then
return ''
if scanString(s) then
return m.s.tok
if scanLit(s, '(') then do
one = compCheckNN(m, compLang(m, 0), 'rexx expexted after $(')
if \ scanLit(s, '$)') then
call scanErr s, 'closing $) missing after $(...'
return '('one')'
end
if scanLit(s, '-¢') then do
res = compData(m, 1)
if \scanLit(s, '$!') then
call scanErr s, 'closing $! missing after $-¢ data'
return res
end
if scanLit(s, '-{') then do
res = compShell(m)
if \scanLit(s, '$}') then
call scanErr s, 'closing $} missing after $-{ shell'
return "mCat("compStmts2ExprBuf(res)"'.BUF', ' ')"
end
if scanLit(s, '-cmpShell', '-cmpData') then do
return 'compile(comp(env2Buf()),' ,
'"'substr('ds', 1+(m.s.tok == '-cmpShell'), 1)'")'
end
if scanLit(s, '{') then do
if scanLit(s, '?') then
f = 'envIsDefined'
else if scanLit(s, '>') then
f = 'envRead'
else
f = 'envGet'
nm = compExpr(m, 'w')
if \scanLit(s, '}') then
call scanErr s, 'closing } missing after ${'
return f'('nm')'
end
if scanName(s) then
return 'envGet('quote(m.s.tok)')'
call scanBack s, '$'
return ''
endProcedure compPrimary
/*--- compile a pipe and return code ---------------------------------*/
compPipe: procedure expose m.
parse arg m
s = m.m.scan
ios = ''
stmts = ''
stmtLast = ''
do forever
io1 = compRedirIO(m, 1)
if io1 \== '' then do
ios = ios',' io1
call compSpNlComment m
end
else do
if stmtLast \== '' then do
if \ scanLit(s, '$|') then
leave
call compSpNlComment m
end
one = compStmts(m)
if one == '' then do
if stmtLast \== '' then
call scanErr s, 'stmts expected afte $|'
if ios == '' then
return ''
leave
end
if stmtLast \== '' then
stmts = stmts 'call envBar;' stmtLast
stmtLast = one
end
end
if stmts \== '' then
stmtLast = insert('Begin', stmts, pos('envBar;', stmts)+5) ,
'call envBarLast;' stmtLast 'call envBarEnd;'
if ios \== '' then do
if stmtLast == '' then
stmtLast = 'call envWriteAll;'
stmtLast = 'call envPush 'substr(ios, 3)';' stmtLast ,
'call envPop;'
end
return stmtLast
endProcedure compPipe
/*--- compile an io redirection, return
if makeExpr then "option", expr
else code write inut to standard out -------------*/
compRedirIO: procedure expose m.
parse arg m, makeExpr
s = m.m.scan
if \ scanLit(s, '$&', '$<<', '$<', '$>>', '$>') then
return ''
opt = substr(m.s.tok, 2)
call scanVerify s, '+-%#¢{'
opt = opt || m.s.tok
/* ???? call compSpComment m */
if left(opt, 2) \== '<<' then do
if verify(opt, '¢{', 'm') > 0 ,
| (left(opt, 1) == '&' & pos('%', opt) > 0) then
call scanErr s, 'inconsistent io redirection option' opt
ex = compCheckNN(m, compExpr(m, 's'),
, 'expression expected after $'opt)
end
else do
if verify(opt, '-%#', 'm') > 0 then
call scanErr s, 'inconsistent io redirection option' opt
if \ scanName(s) then
call scanErr s, 'stopper expected in heredata after $'opt
stopper = m.s.tok
call scanVerify s, m.m.chSpa
if \ scanReadNl(s) then
call scanErr s,
, 'space nl expected in heredata after $'opt||stopper
buf = jOpen(jBuf(), m.j.cWri)
do while \ scanLit(s, stopper)
call jWrite buf, m.s.src
if \ scanReadNl(s, 1) then
call scanErr s, 'eof in heredata after $'opt||stopper
end
call jClose buf
if verify(opt, '¢{', 'm') > 0 then do
if pos('¢', opt) > 0 then
ex = compile(comp(buf), 'd')
else
ex = compile(comp(buf), 's')
if makeExpr then
return "'<%' envRun("quote(ex)")"
else
return "call oRun" quote(ex)";"
end
opt = '<%'
ex = quote(buf)
end
if makeExpr then
return "'"opt"'" ex
else if left(opt, 1) = '>' then
call scanErr s, 'cannot write ioRedir $'opt
else
return "call envWriteAll '"opt"'" ex
endProcedure compRedirIO
/*--- compile stmts (stmt or java) -----------------------------------*/
compStmts: procedure expose m.
parse arg m
res = ''
do forever
one = compStmt(m)
if one == '' then
one = compLang(m, 1)
if one == '' then
return res
res = res strip(one)
call compSpNlComment m
end
endProcedure compStmts
/*--- compile a single statement -------------------------------------*/
compStmt: procedure expose m.
parse arg m
s = m.m.scan
if scanLit(s, "$=") then do
nm = compCheckNN(m, compExpr(m, 'w'), "variable name")
if scanLit(s, "=") then
vl = compExpr(m, 's')
else if scanLit(s, "%") then
vl = compCheckNN(m, compLang(m, 0),
, 'java expression after $= .. %')
else
call scanErr s, '= or % expected after $= name'
return 'call envPut' nm',' vl';'
end
else if scanLit(s, '$@{') then do
call compSpNlComment m
one = compShell(m)
if \ scanLit(s, "$}") then
call scanErr s, "closing $} missing for $@{ shell"
return "do;" one "end;"
end
else if scanLit(s, '$@¢') then do
call compSpNlComment m
one = compData(m, 0)
if \ scanLit(s, "$!") then
call scanErr s, "closing $! missing for $@! data"
return "do;" one "end;"
end
else if scanLit(s, '$$') then do
return 'call jOut' compExpr(m, 's')';'
end
else if scanLit(s, '$%') then do
return 'call jOut' compCheckNN(m, compLang(m, 0),
, 'language expression after $%')';'
end
else if scanLit(s, '$@for') then do
v = compCheckNN(m, compExpr(m, 'w') ,
, "variable name after $@for")
call compSpNlComment m
return 'do while envRead('v');',
compCheckNN(m, compStmt(m),
, "statement after $@for variable") 'end;'
end
else if scanLit(s, '$@run') then do
return 'call oRun' compCheckNN(m, compExpr(m, 's'),
, 'expression after $@run') ';'
end
return ''
endProcedure compStmt
/*--- compile a language clause
multi=0 a single line for a rexx expression
multi=1 mulitple lines for rexx statements
(with rexx line contiunation) -----------------------*/
compLang: procedure expose m.
parse arg m, multi
s = m.m.scan
res = ''
do forever
if scanVerify(s, m.m.chDol, 'm') then do
res = res || m.s.tok
end
else do
one = compPrimary(m)
if one \== '' then
res = res || one
else if compComment(m) then
res = res || ' '
else if \multi then
return res
else if \ scanReadNl(s) then do
if res == '' then
return res
else
return strip(res)';'
end
else do
res = strip(res)
if right(res, 1) = ',' then
res = strip(left(res, length(res)-1))
else
res = res';'
end
end
end
endProcedure compLang
/*--- convert stmts to an expression yielding the output ------------*/
compStmts2ExprBuf: procedure expose m.
parse arg stmts
rr = oRunner(stmts)
return "envRun('"rr"')"
endProcedure compStmts2ExprBuf
/*--- convert '' to an empty expression ------------------------------*/
compNull2EE: procedure
parse arg e
if e = '' then
return '""'
return e
endProcedure compNull2EE
/*--- if va == '' then issue an error with msg -----------------------*/
compCheckNN: procedure expose m.
parse arg m, va, msg
if va == '' then
call scanErr m.m.scan, msg 'expected'
return va
endProcedure compCheckNN
/*--- skip a comment. return 0 if there is none ----------------------*/
compComment: procedure expose m.
parse arg m
s = m.m.scan
if scanLit(s, '$**') then
m.s.pos = 1 + length(m.s.src) /* before next nl */
else if scanLit(s, '$*+') then
call scanReadNl s, 1
else if scanLit(s, '$*(') then do
do forever
if scanVerify(s, m.m.chDol, 'm') then iterate
if scanReadNl(s) then iterate
if compComment(m) then iterate
if \ scanLit(s, '$') then
call scanErr s, 'source end in comment'
if scanLit(s, '*)') then
return 1
if scanLit(s, '$') then iterate
if scanString(s) then iterate
end
end
else
return 0
return 1
endProcedure compComment
/*--- skip spaces and comments ---------------------------------------*/
compSpComment: procedure expose m.
parse arg m
found = 0
do forever
if scanVerify(m.m.scan, m.m.chSpa) then
found = 1
else if compComment(m) then
found = 1
else
return found
end
endProcedure compSpComment
/*--- skip spaces, NLs and comments ----------------------------------*/
compSpNlComment: procedure expose m.
parse arg m
found = 0
do forever
if compSpComment(m) then
found = 1
else if scanReadNl(m.m.scan) then
found = 1
else
return found
end
endProcedure compSpComment
/* copy comp end ******************************************************/
/* copy scan begin ****************************************************
Scan: scan an input:
scanLine(m,ln) : begin scanning a single line (string)
scanRead??(m,ln): begin scanning all lines of an opened reader
scanAtEnd(m) : returns whether we reached end of input
scanLit(m,lit) : scan Literal lit if present or return 0
scanChar(m,n) : scan next n characters
scanName(m) : scan a name
ScanNat(m) : scan a natural number (without sign)
scanString(m,q): scan a String with quote q. (with doubble = 1)
scanVerify(m,c,o): verify(...,c,o,...)
scanKeyValue(m): scan a key = value clause (with spaces)
scanWord(m,u) : scan a space delimited word or a string,
if u=1 then uppercase non-strings
scanErr(m, txt): error with current scan location
m is an adress, to store our state
if a scan function succeeds, the scan posititon is moved
returns: true if scanned, false otherwise
m.m.tok ==> last token
m.m.val ==> last value for scanString/Word/KeyValue
m.key ==> key for scanKeyValue
m.m.pos ==> scan position
m.m.src ==> scan source
***********************************************************************/
scanIni: procedure expose m.
if m.scan.ini == 1 then
return
m.scan.ini = 1
m.scan.alfLC = 'abcdefghijklmnopqrstuvwxyz'
m.scan.alfUC = translate(m.scan.alfLC)
m.scan.alfa = m.scan.alfLC || m.scan.alfUC
m.scan.alfNum = m.scan.alfa || '0123456789'
return
endProcedure scanIni
scanReset: procedure expose m.
parse arg m, n1, np, co
m.m.rdr = ''
m.m.jReading = 0 /* if called without jReset */
m.m.jWriting = 0
return scanOpts(m, n1, np, co)
endProcedure scanReset
scanOpts: procedure expose m.
parse arg m, m.m.scanName1, namePlus, m.m.scanComment
if m.m.scanName1 == '' then
m.m.scanName1 = m.scan.alfa
if namePlus == '' then
m.m.scanNameR = m.m.scanName1 || '0123456789'
else
m.m.scanNameR = m.m.scanName1 || namePlus
return m
endProcedure scanOpts
/*--- begin scanning a single line -----------------------------------*/
scanSrc: procedure expose m.
parse arg m, m.m.src
return scanOpen(m)
endProcedure scanSrc
scanOpen: procedure expose m.
parse arg m
m.m.tok = ''
m.m.val = ''
m.m.key = ''
m.m.pos = 1
m.m.atEnd = m.m.rdr == ''
m.m.jReading = 1
return m
endProcedure scanOpen
/*--- return the next len characters ---------------------------------*/
scanLook: procedure expose m.
parse arg m, len
if len == '' then
return substr(m.m.src, m.m.pos)
else
return substr(m.m.src, m.m.pos,
, min(len, 1 + length(m.m.src) - m.m.pos))
endProcedure scanLook
/*--- scan the literal lit ------------------------------------------*/
scanLit: procedure expose m.
parse arg m
do ax=2 to arg()
if abbrev(substr(m.m.src, m.m.pos), arg(ax)) then do
m.m.tok = arg(ax)
m.m.pos = m.m.pos + length(arg(ax))
return 1
end
end
m.m.tok = ''
return 0
endProcedure scanLit
/*--- scan the next len characters -----------------------------------*/
scanChar: procedure expose m.
parse arg m, len
nx = 1 + length(m.m.src)
if len \= '' then
nx = min(m.m.pos + len, nx)
m.m.tok = substr(m.m.src, m.m.pos, nx - m.m.pos)
m.m.pos = nx
return m.m.tok \== ''
endProcedure scanChar
/*--- scan a string with quote char qu -------------------------------*/
scanString: procedure expose m.
parse arg m, prefs
m.m.tok = ''
bx = m.m.pos
if prefs = '' then do
qu = substr(m.m.src, bx, 1)
if pos(qu, "'""") < 1 then
return 0
ax = bx + 1
end
else do
do px=1 until abbrev(substr(m.m.src, bx), p1)
p1 = word(prefs, px)
if p1 = '' then
return 0
end
qu = right(p1, 1)
ax = bx + length(p1)
end
m.m.val = ''
do forever
qx = pos(qu, m.m.src, ax)
if qx < 1 then
return scanErr(m, 'ending Apostroph('qu') missing')
m.m.val = m.m.val || substr(m.m.src, ax, qx-ax)
if qx >= length(m.m.src) then
leave
else if substr(m.m.src, qx+1, 1) <> qu then
leave
ax = qx+2
m.m.val = m.m.val || qu
end
m.m.tok = substr(m.m.src, bx, qx+1-bx)
m.m.pos = qx+1
return 1
endProcedure scanString
/*--- scan a Name, first char in *.scanName1, rest in *.scanNameR ----*/
scanName: procedure expose m.
parse arg m
if pos(substr(m.m.src, m.m.pos, 1),
, m.m.scanName1) <= 0 then do
m.m.tok = ''
return 0
end
return scanVerify(m, m.m.scanNameR)
endProcedure scanName
/*--- scan with verify, vOpt is passed to verify ---------------------*/
scanVerify: procedure expose m.
parse arg m, alpha, vOpt, onlyIfMatch
if vOpt == '' then /* empty string does not take default */
nx = verify(m.m.src, alpha, , m.m.pos)
else
nx = verify(m.m.src, alpha, vOpt, m.m.pos)
if nx = 0 then
if onlyIfMatch == 1 then
nx = m.m.pos
else
nx = length(m.m.src) + 1
m.m.tok = substr(m.m.src, m.m.pos, nx - m.m.pos)
m.m.pos = nx
return m.m.tok \== ''
endProcedure scanVerify
/*--- scan a natural number (no sign, decpoint ...) ------------------*/
scanNat: procedure expose m.
parse arg m, chEn
if \ scanVerify(m, '0123456789') then
return 0
if chEn \== 0 then
if pos(scanLook(m , 1), m.m.scanNameR) > 0 then
call scanErr m, 'illegal number end after' m.m.tok
return 1
endProcedure ScanNat
/*--- scan an integer (optional sign, no decpoint ...) ---------------*/
scanInt: procedure expose m.
parse arg m, chEn
call scanLit m, '+', '-'
si = m.m.tok
if \ scanNat(m, chEn) then do
m.m.pos = m.m.pos - si
return 0
end
m.m.tok = si || m.m.tok
return 1
endProcedure scanInt
/*--- scan a number (optional sign, decpoint, exponent) ------------*/
scanNum: procedure expose m.
parse arg m, chEn
sx = m.m.pos
call scanLit m, '+', '-'
po = scanLit(m, '.')
if \ scanNat(m, 0) then do
m.m.pos = sx
return 0
end
if \ po then
if scanLit(m, '.') then
call scanNat m, 0
if scanLit(m, 'e', 'E') then
if \ scanInt(m, 0) then
call scanErr 'exponent expected after' ,
substr(m.m.src, sx, m.m.pos-sx)
m.m.tok = substr(m.m.src, sx, m.m.pos-sx)
m.m.val = translate(m.m.tok)
if chEn \== 0 then
if pos(scanLook(m , 1), m.m.scanNameR) > 0 then
call scanErr m, 'illegal number end after' m.m.tok
return 1
endProcedure scanNum
/*--- scan a word and put value into *.val
a word is either delimited by space or stopper
or a string (with single or double quotes -------*/
scanWord: procedure expose m.
parse arg m, stopper
if scanString(m) then return 1
if \scanVerify(m, ' 'stopper, 'm') then return 0
m.m.val = m.m.tok
return 1
endProcedure scanWord
scanType: procedure expose m.
parse arg m, opt
m.m.tok = ''
if scanName(m) then
m.m.type = 'n'
else if scanNum(m) then
m.m.type = 0
else if scanString(m) then
m.m.type = left(m.m.tok, 1)
else if scanSpaceNl(m) then
m.m.type = 's'
else do
call scanChar m, 1
m.m.type = m.m.tok
end
return m.m.type
endProcedure scanType
scanBack: procedure expose m.
parse arg m, tok
if m.m.pos <= length(tok) then
call scanErr sc, 'cannot back "'tok'" length'
cx = m.m.pos - length(tok)
if substr(m.m.src, cx, length(tok)) \== tok then
call scanErr sc, 'cannot back "'tok'" value'
m.m.pos = cx
return
endProcedure scanBack
/*--- scan a key = word phrase
put key into m.key and word into m.m.val -------*/
scanKeyValue: procedure expose m.
parse arg m, def
if \ scanName(m) then
return 0
m.m.key = m.m.tok
if \ scanLit(scanSkip(m), '=') then do
m.m.val = def
m.m.tok = ' no='
end
else if \scanWord(scanSkip(m)) then
return scanErr(m, 'word expected after' m.m.key '=')
return 1
endProcedure scanKeyValue
/*--- return true/false whether we are at the end of input ----------*/
scanAtEnd: procedure expose m.
parse arg m
return m.m.atEnd & m.m.pos > length(m.m.src)
endProcedure scanAtEnd
/*--- skip over spaces, nl and comments (if option set) --------------*/
scanSpaceNL: procedure expose m.
parse arg m
lastTok = m.m.tok
if m.m.rdr \== '' then
interpret 'res = ' objMet(m, 'scanSpaceNl')
else
res = scanSpaceCom(m)
m.m.tok = lastTok
return res
endProcedure scanSpaceNL
scanSpaceCom: procedure expose m.
parse arg m
res = scanVerify(m, ' ')
if m.m.scanComment \== '' then
if abbrev(substr(m.m.src, m.m.pos), m.m.scanComment) then do
m.m.pos = 1 + length(m.m.src)
return 1
end
return res
endProcedure scanSpaceCom
/*--- skip over space, nl and comments and return m -----------------*/
scanSkip: procedure expose m.
parse arg m
call scanSpaceNl m
return m
endProcedure scanSkip
/*--- emit an error with current scan pos ----------------------------*/
scanErr: procedure expose m.
parse arg m, txt
m.m.err.0 = 0
call err 'scanErr' txt'\n'scanInfo(m, m'.ERR')
return 0
endProcedure scanErr
scanPos: procedure expose m.
parse arg m
if m.m.rdr \== '' then
interpret 'return' objMet(m, 'scanPos')
else if scanAtEnd(m) then
return E
else
return 1 m.m.pos
endProcedure scanPos
scanInfo: procedure expose m.
parse arg m
msg = 'last token' m.m.tok 'scanPosition' ,
strip(left(substr(m.m.src, m.m.pos), 40), 't')
if m.m.rdr == '' then
return msg'\npos' m.m.Pos 'in string' strip(m.m.src, 't')
else
interpret 'return msg ||' objMet(m, 'scanInfo')
endProcedure scanInfo
/* copy scan end ****************************************************/
/* copy scanRead begin ************************************************/
scanReadIni: procedure expose m.
if m.scanRead.ini = 1 then
return
m.scanRead.ini = 1
call scanIni
call jIni
ts = classNew('n Scan u f TOK v, f VAL v, f KEY v, f TYPE v')
call classNew 'n ScanRead u JRW', 'm',
, 'jReset call scanReadReset m, arg, arg2, arg3',
, 'jOpen call scanReadOpen m',
, 'jClose call jClose m.m.rdr',
, 'jRead call scanType m; call oClaCopy "'ts'", m, var;' ,
'return m.m.type \== ""',
, 'scanReadNl return scanReadNlImpl(m, unCond)',
, 'scanSpaceNl scanReadSpaceNl(m)',
, 'scanInfo scanReadInfo(m)',
, 'scanPos scanReadPos(m)'
return
endProcedure scanReadIni
/*--- begin scanning the lines of a reader ---------------------------*/
scanRead: procedure expose m.
parse arg rdr, n1, np, co
return scanOpts(oNew('ScanRead', rdr), n1, np, co)
scanReadReset: procedure expose m.
parse arg m, r, n1, np, co
call scanReset m, n1, np, co
m.m.rdr = r
return m
endProcedure scanReadReset
scanReadOpen: procedure expose m.
parse arg m, r, n1, np, co
call scanOpen m
m.m.atEnd = 0
m.m.lineX = 0
call jOpen m.m.rdr, m.j.cRead
call scanReadNl m, 1
return m
endProcedure scanReadOpen
/*--- scan over next newLine
if unCond \== 1 only if we are already at endOfLine
return true if we scanned a NL ------------------------------*/
scanReadNl: procedure expose m.
parse arg m, unCond
interpret objMet(m, 'scanReadNl')
endProcedure scanReadNl
/*--- implementation of scanReadNl ----------------------------------*/
scanReadNLimpl: procedure expose m.
parse arg m, unCond
if unCond \== 1 then
if m.m.pos <= length(m.m.src) then
return 0
if m.m.atEnd then
return 0
m.m.atEnd = \ jRead(m.m.rdr, m'.SRC')
if m.m.atEnd then do
m.m.pos = 1 + length(m.m.src)
end
else do
m.m.pos = 1
m.m.lineX = m.m.lineX + 1
end
return \ m.m.atEnd
endProcedure scanReadNLimpl
scanReadSpaceNl: procedure expose m.
parse arg m
fnd = 0
do forever
if scanSpaceCom(m) then
fnd = 1
if \ scanReadNl(m) then
return fnd
fnd = 1
end
endProcedure scanReadSpaceNl
scanReadPos: procedure expose m.
parse arg m, msg
if scanAtEnd(m) then
return E
else
return m.m.lineX m.m.pos
endProcedure scanReadPos
scanReadInfo: procedure expose m.
parse arg m, msg
if scanAtEnd(m) then
msg = msg'\natEnd after'
else
msg = msg'\npos' m.m.pos 'in'
return msg 'line' m.m.lineX':' strip(m.m.src, 't')
endProcedure scanReadInfo
/* copy scanRead end **************************************************/
/* copy scanWin begin *************************************************
scan the the concatenation of the lines of a reader
any token my be split over several line
except the end-of-line-comment-token
***********************************************************************/
scanWinIni: procedure expose m.
if m.scanWin.ini = 1 then
return
m.scanWin.ini = 1
call scanIni
call jIni
call classNew 'n ScanWin u JRW', 'm',
, 'jReset call scanWinReset m, arg, arg2, arg3',
, 'jOpen call scanWinOpen m ',
, 'jClose call scanWinClose m ',
, 'scanReadNl return scanWinNl(m, unCond)',
, 'scanSpaceNl scanWinSpaceNl(m)',
, 'scanInfo scanWinInfo(m)',
, 'scanPos scanWinPos(m)'
return
endProcedure scanReadIni
/*--- instanciate a new window scanner, open rdr ---------------------*/
scanWin: procedure expose m.
parse arg rdr, wiSz, wiBa, cuPo, cuLe
return scanWinOpts(oNew('ScanWin', rdr), wiSz, wiBa, cuPo, cuLe)
/*--- set the reader and attributes of window scanner m -------------*/
scanWinReset: procedure expose m.
parse arg m, r, wiSz, wiGa, cuPo, cuLe
call scanReset m
m.m.rdr = r
m.m.atEnd = 'still closed'
return scanWinOpts(m, wiSz, wiGa, cuPo, cuLe)
endProcedure scanWinReset
/*--- set the attributes of window scanner m ------------------------*/
scanWinOpts: procedure expose m.
parse arg m, wiSz, wiGa, cuPo, cuLe
wiSz = word(wiSz 5, 1)
wiGa = word(wiGa 1, 1)
m.m.cutPos = word(cuPo 1, 1)
m.m.cutLen = word(cuLe 72, 1)
m.m.winTot = (wiSz * 2 + wiGa) * m.m.cutLen
m.m.posLim = (wiSz + wiGa) * m.m.cutLen
m.m.posOff = wiGa * m.m.cutLen
return m
endProcedure scanWinReset
/*--- open reader and start scanning --------------------------------*/
scanWinOpen: procedure expose m.
parse arg m, lx
call scanOpen m
m.m.atEnd = 0
if lx = '' then
m.m.lineX = 1
else
m.m.lineX = lx
m.m.pos = 1
m.m.src = ''
call jOpen m.m.rdr, m.j.cRead
call scanWinRead m
return m
endProcedure scanWinOpen
scanWinClose: procedure expose m.
m.m.atEnd = 'still closed'
call jClose m.m.rdr
return
endProcedure scanWinClose
/*--- move the source window: cut left side and append at right side
return number of characters cut at left ------------------------*/
scanWinRead: procedure expose m.
parse arg m
dlt = 0
if m.m.atEnd then
return 0
if m.m.pos >= m.m.posLim then do /* cut left side */
dlt = m.m.pos - (m.m.pos // m.m.cutLen + m.m.posOff)
m.m.src = substr(m.m.src, dlt+1)
m.m.pos = m.m.pos - dlt
m.m.lineX = m.m.lineX + dlt % m.m.cutLen
end
do while length(m.m.src) < m.m.winTot /* read and fill to len */
if \ jRead(m.m.rdr, m'.'one) then do
m.m.atEnd = 1
return dlt
end
m.m.src = m.m.src || substr(m.m.one, m.m.cutPos, m.m.cutLen)
end
call assert 'length(m.m.src) = m.m.winTot'
return dlt
endProcedure scanWinRead
/*--- return position of next line start -----------------------------*/
scanWinNLPos: procedure expose m.
parse arg m
return m.m.pos + m.m.cutLen - ((m.m.pos - 1) // m.m.cutLen)
/*--- scan over spaces and comments ----------------------------------*/
scanWinSpaceNL: procedure expose m.
parse arg m
res = 0
do forever
r1 = 0
if scanVerify(m, ' ') then do
r1 = 1
end
else if m.m.scanComment \== '' ,
& abbrev(substr(m.m.src, m.m.pos), m.m.scanComment) then do
np = scanWinNlPos(m)
r1 = length(m.m.scanComment) <= np - m.m.pos
if r1 then
m.m.pos = np
end
if r1 then
res = 1
else if scanWinRead(m) = 0 then
return res
end
endProcedure scanWinSpaceNl
/*--- return current position in input ------------------------------*/
scanWinPos: procedure expose m.
parse arg m
if scanAtEnd(m) then
return 'E'
else
ps = m.m.pos - 1
return (m.m.lineX + (ps % m.m.cutLen)) (ps // m.m.cutLen + 1)
endProcedure scanWinPos
/*--- return a description of the current scan position --------------*/
scanWinInfo: procedure expose m.
parse arg m
p = scanWinPos(m)
if p == 'E' then do
res = 'atEnd after'
p = m.m.lineX - 1 + length(m.m.src) % m.m.cutLen
end
else do
res = 'pos' word(p, 2) 'in'
p = word(p, 1)
end
return '\n'res 'line' p':' strip(substr(m.m.src,
, 1 + (p - m.m.lineX) * m.m.cutLen, m.m.cutLen), 't')
endProcedure scanWinInfo
/* copy scanWin end *************************************************/
/* copy scanSql begin *************************************************/
/*--- initialize with reader inRdr ----------------------------------*/
scanSql: procedure expose m.
parse arg inRdr
return scanSqlReset(scanWin(inRdr), inRdr)
scanSqlReset: procedure expose m.
parse arg m, r, scanWin
if scanWin \== 0 then
call scanWinOpts m, 5, 2, 1, 72
else
m.m.rdr = r
return scanOpts(m, , '0123456789_' , '--')
scanSqlSeekId: procedure expose m.
parse arg m, lx, cmd, opts
if opts = '' then
opts = word
if adrEdit("cursor =" max(trunc(lx), 1), 12) = 12 then
return -1
do while adrEdit("seek" cmd opts, 4) = 0 /* find each command*/
call adrEdit "(fx) = cursor"
if m.debug then do
call adrEdit "(LI) = LINE" fx
call debug 'scanSqlSeekId after' lx 'found' cmd 'at' fx li
end
call editReadReset m.m.rdr, fx
call scanWinOpen es, fx
do while word(scanPos(m), 1) <= fx & scanSqlClass(m)
if m.m.sqlClass = 'i' & m.m.val == cmd then
return fx
end
end
return -1
endProcedure scanSqlSeekId
/*--- scan a sql token put class in m.sqlclass:
'i': ordinary identifier e.g. Name
'd': delimited identifier e.g. "Delimited"
'q': qualified identifier e.g. abc."efg"
'u': integer units e.g. 8G
'n': number e.g. -234 or .2e3
's': string e.g. 'abc''ef'
'' : at end
: any other character e.g. ;
----------------------------------------------------------------*/
scanSqlClass: procedure expose m.
parse arg m, retSpace
m.m.val = ''
if scanSpaceNl(m) & retSpace = 1 then do
m.m.sqlClass = 'b'
return 1
end
c2 = scanLook(m ,2)
if scanString(m, "' x' X'") then do
m.m.sqlClass = 's'
if \abbrev(m.m.tok, "'") then
m.m.val = x2c(m.m.val)
end
else if scanSqlQuId(m) then do
if m.m.val.0 > 1 then
m.m.sqlClass = 'q'
else if abbrev(m.m.tok, '"') then
m.m.sqlClass = 'd'
else
m.m.sqlClass = 'i'
end
else if scanSqlNum(m, 0, 1) then
m.m.sqlClass = 'n'
else if scanChar(m, 1) then
m.m.sqlClass = m.m.tok
else if scanAtEnd(m) then do
m.m.sqlClass = ''
return 0
end
else
call scanErr m, 'cannot scan sql'
return 1
endProcedure scanSqlClass
scanSqlSkipBrackets: procedure expose m.
parse arg m, br
if br \== '' then
nop
else if scanLit(m, '(') then
br = 1
else
return 0
do while scanSqlClass(m) & m.m.sqlClass \== ';'
if m.m.sqlClass = '(' then br = br + 1
else if m.m.sqlClass \== ')' then iterate
else if br > 1 then br = br - 1
else return 1
end
call scanErr m, '; or eof, but' br 'closing ) expected'
endProcedure skipBrackets
/*--- scan an ordinary sql identifier e.g. abc, ef_12 ----------------*/
scanSqlId: procedure expose m.
parse arg m
if \ scanName(m) then
return 0
m.m.val = translate(m.m.tok)
return 1
endProcedure scanSqlId
/*--- scan a delimited or ordinay sql identifier ---------------------*/
scanSqlDeId: procedure expose m.
parse arg m
if scanSqlId(m) then
return 1
if \ scanString(m, '"') then
return 0
m.m.val = strip(m.m.val, 't')
return 1
endProcedure scanSqlDeId
/*--- scan a qualified sql identifier --------------------------------*/
scanSqlQuId: procedure expose m.
parse arg m
res = ''
rto = ''
do qx=1
if \ scanSqlDeId(m) then do
if qx <> 1 then
call scanErr m, 'id expected after .'
return 0
end
m.m.val.qx = m.m.val
res = res'.'m.m.val
rto = rto'.'m.m.tok
if \ scanLit(scanSkip(m), '.') then
leave
call scanSpaceNl m
end
m.m.val.0 = qx
m.m.val = substr(res, 2)
m.m.tok = substr(rto, 2)
return 1
endProcedure scanSqlQuId
/*--- scan a sql number ----------------------------------------------*/
scanSqlNum: procedure expose m.
parse arg m, checkEnd, noSp
si = ''
if noSp == 1 then
call err 'deimplement ???? wk'
if noSp \== 1 then do
if scanLit(m, '+', '-') then do
si = m.m.tok
call scanSpaceNl m
ch = scanLook(m, 2)
if left(ch, 1) == '.' then
ch = substr(ch, 2)
if pos(left(ch, 1), '0123456789') < 1 then do
call scanBack m, si
m.m.val = ''
return 0
end
end
end
res = scanNum(m, checkEnd)
m.m.val = si || m.m.val
return res
endProcedure scanSqlNum
/*--- scan a sql number with a unit which may follow without space ---*/
scanSqlNumUnit: procedure expose m.
parse arg m, both, units
if \ scanSqlNum(m, 0) then
return 0
nu = m.m.val
sp = scanSpaceNl(m)
if scanSqlId(m) then do
if units == '' | wordpos(m.m.val, units) > 0 then
nu = nu m.m.val
else if both | \ sp then
call scanErr m, 'scanSqlNumUnit after' nu 'bad unit' m.m.val
else
call scanBack m, m.m.tok
end
else if both then
call scanErr m, 'scanSqlNumUnit no unit after' nu
else if \sp & pos(scanLook(m, 1), m.m.scanNameR) > 0 then
call scanErr m, 'scanSqlNumUnit bad number end after' nu
m.m.val = nu
return 1
endProcedure scanSqlNumUnit
/* copy scanSql end *************************************************/
/* copy scanUtil begin *************************************************
scan db2 utility input statements using scan and a reader
**********************************************************************/
/*--- initialize with reader inRdr ----------------------------------*/
scanUtilReader: procedure expose m.
parse arg m, inRdr
call scanReader m, inRdr
call scanOptions sc, , , '--'
call scanUtilReset m
return m
endProcedure scanUtilReader
scanUtilSql: procedure expose m.
parse arg inRdr
m = scanSql(inRdr)
call scanUtilReset m
return m
endProcedure scanUtilReader
scanUtilReset: procedure expose m.
parse arg m
m.m.utilBrackets = 0
m.scanUtil = 'BACKUP CATENFM CATMAINT CHECK' ,
'COPY COPYTOCOPY DIAGNOSE EXEC LISTDEF LOAD' ,
'MERGECOPY MODIFY OPTIONS QUIESCE REBUILD' ,
'RECOVER REORG REPAIR REPORT RESTORE' ,
'RUNSTATS STOSPACE TEMPLATE UNLOAD'
return
endProcedure scanUtilReset
/*--- scan next token and put its class in m.sc.utilClass:
'u' a utility name
'n' a name
'"' a quoted name
"'" an apostroph'd string
'.' a .
',' a ,
'v' a value
'' at end
---------------------------------------------------------------*/
scanUtil: procedure expose m.
parse arg sc
m.sc.utilSpace = scanSpaceNl(sc)
ty = '?'
if scanLit(sc, '(') then do
m.sc.utilBrackets = m.sc.utilBrackets + 1
end
else if scanLIT(sc, ')') then do
m.sc.utilBrackets = m.sc.utilBrackets - 1
if m.sc.utilBrackets < 0 then
call scanErr sc, 'unmatched closing bracket )'
end
else if scanLit(sc, ',') then do
end
else if scanLit(sc, '.') then do
end
else if scanString(sc, "'") then do
end
else if scanString(sc, '"') then do
end
else if scanName(sc) then do
m.sc.val = translate(m.sc.tok)
if m.sc.utilBrackets > 0 then
ty = 'n'
else if 0 < wordPos(m.sc.val, m.scanUtil) then
ty = 'u'
else
ty = 'n'
end
else if scanVerify(sc, ' (),''"', 'm') then do
ty = 'v'
m.sc.val = translate(m.sc.tok)
end
else if \scanAtEnd(sc) then do
call scanErr sc, 'scanUtil stopped before end'
end
else do
/* say 'scanUtil return atEnd' */
ty = ''
m.sc.val = ''
end
if ty == '?' then
m.sc.utilClass = left(m.sc.tok, 1)
else
m.sc.utilClass = ty
return m.sc.utilClass
endProcedure scanUtil
/*--- scan a value or a bracketed list of values ---------------------*/
scanUtilValue: procedure expose m.
parse arg sc, remApo, nl
if remApo = '' | rempApo = 0 then
remApo = "nv"
else if rempApo = 1 then
remApo = "nv'"
if '(' \== scanUtil(sc) then
return scanUtilValueOne(sc, remApo)
v = ''
brx = m.sc.utilBrackets
oLine = word(scanPos(sc), 1)
do forever
call scanUtil sc
one = scanUtilValueOne(sc, remApo)
if one == '' then
call scanErr sc, 'eof in brackets'
else if brx > m.sc.utilBrackets then
return v
nLine = word(scanPos(sc), 1)
if \ m.sc.utilSpace then
v = v || one
else if nl \== '' & oLine <> nLine then
v = v || nl || one
else
v = v' 'one
oLine = nLine
end
endProcedure scanUtilValue
scanUtilValueOne: procedure expose m.
parse arg sc, valTy
if m.sc.utilClass == '' then
return ''
else if m.sc.utilClass == 'u' then
call scanErr sc, 'util in scanUtilValueOne'
if pos(m.sc.utilClass, valTy) > 0 then
return m.sc.val
else
return m.sc.tok
endProcedure scanUtilValueOne
/* copy scanUtil end **************************************************/
/* copy env begin ******************************************************
***********************************************************************/
env: procedure expose m.
m = oBasicNew("Env")
m.m.toClose = ''
m.m.in = ''
m.m.out = ''
m.m.ios.0 = 0
return m
endProcedure env
envClose: procedure expose m.
parse arg m, finishLazy
isLazy = m.m.out == 'ENV.lazyNoOut'
if finishLazy \== '' then do
if \ isLazy & finishLazy == 1 then
call err 'not lazy'
call oMutate m, 'Env'
m.e.out = 'ENV.wasLazy'
end
else if isLazy then
return m
do wx=1 to words(m.m.toClose)
call jClose word(m.m.toClose, wx)
end
m.m.toClose = ''
return m
endProcedure envClose
envAddIO: procedure expose m.
parse arg m, opt spec
opt = jOpt(opt)
k = left(opt, 1)
if k == m.j.cApp then
k = m.j.cWri
else if pos(k, m.j.cRead || m.j.cWri) < 1 then
call err 'envAddIO bad opt' opt
do kx=1 to m.m.ios.0 while m.m.ios.kx \== k
end
if kx > m.m.ios.0 then
call mCut mAdd(m'.IOS', k), 0
call mAdd m'.IOS.'kx, opt spec
return m
endProcedure envAddIO
envLazy: procedure expose m.
parse arg e
m.e.jReading = 0
m.e.jWriting = 0
m.e.lazyRdr = jClose(m.e.out)
m.e.out = 'ENV.lazyNoOut'
call oMutate e, 'EnvLazy'
return e
endProcedure envLazy
/*--- return openOption and reader for opt rdr or jIn ---------------*/
envOptRdr: procedure expose m.
parse arg opt rdr
if opt = '' then
return m.j.cRead || m.j.cNoOC || m.j.cObj m.j.jIn
else if rdr = '' then
return m.j.cRead catMake(m.j.cRead opt)
else
return opt catMake(opt rdr)
endProcedure envOptRdr
/*--- write all from rdr (rsp jIn) to jOut, possibly lazy -----------*/
envWriteAll: procedure expose m.
if arg() > 1 then call err '?????????'
parse arg optRdr
call jWriteAll m.j.jOut, envOptRdr(optRdr)
return
endProcedure envWriteAll
/*--- write all from rdr (rsp jIn) to jOut, not lazy ----------------*/
envWriteNow: procedure expose m.
if arg() > 1 then call err '?????????'
parse arg optRdr
call jWriteNow m.j.jOut, envOptRdr(optRdr)
return
endProcedure envWriteNow
envRead2Buf:
call err 'use env2Buf' /*???wkTest***/
/*--- write all from rdr (rsp jIn) to a new jBuf --------------------*/
env2Buf: procedure expose m.
parse arg optRdr
b = jOpen(jBuf(), m.j.cWri)
call jWriteNow b, envOptRdr(optRdr)
return jClose(b)
endProcedure env2Buf
envPreSuf: procedure expose m.
parse arg le, ri
do while jIn(v)
call jOut le || m.v || ri
end
return
endProcedure envPreSuf
envCatStr: procedure expose m.
parse arg mi, fo
res = ''
do while jIn(v)
res = res || mi || fmt(m.v)
end
return substr(res, length(mi))
endProcedure envCatStr
envIsDefined: procedure expose m.
parse arg na
return symbol('m.env.vars.na') == 'VAR'
endProcedure envIsDefined
envGet: procedure expose m.
parse arg na
return mapGet(env.vars, na)
envRead: procedure expose m.
parse arg na
return jIn('ENV.VARS.'na)
envHasKey: procedure expose m.
parse arg na
return mapHasKey(env.vars, na)
envVia: procedure expose m.
parse arg na
return mapVia(env.vars, na)
envPut: procedure expose m.
parse arg na, va
return mapPut(env.vars, na, va)
envRemove: procedure expose m.
parse arg na
return mapRemove(env.vars, na)
envIni: procedure expose m.
if m.env.ini == 1 then
return
m.env.ini = 1
call catIni
call classNew "n Env u JRW"
call classNew "n EnvLazy u Cat", "m",
, "jOpen call jOpen m.m.lazyRdr, opt; m.m.jReading = 1",
, "jRead call envPushEnv m;res = jRead(m.m.lazyRdr, var);",
"call envPop; return res",
, "jReset call envClose m, r",
, "jClose call envClose m, 1"
call mapReset env.vars
call jReset oMutate("ENV.lazyNoOut", "JRWErr")
m.env.0 = 0
call envPush /* by default pushes jIn and jOut */
return
endProcedure envIni
envPush: procedure expose m.
e = env()
do ax=1 to arg()
call envAddIo e, arg(ax)
end
do ix=1 to m.e.ios.0
if m.e.ios.ix.0 = 1 then do
rw = catMake(m.e.ios.ix.1)
opt = word(m.e.ios.ix.1, 1)
end
else do
rw = cat()
do fx=1 to m.e.ios.ix.0
call catWriteAll rw, m.e.ios.ix.fx
end
opt = m.e.ios.ix
end
if pos(m.j.cNoOC, opt) < 1 then do
call jOpen rw, opt
m.e.toClose = m.e.toClose rw
end
if m.e.ios.ix = m.j.cRead then
m.e.in = rw
else if m.e.ios.ix = m.j.cWri then
m.e.out = rw
else
call err 'envPush bad io' m.e.ios.ix 'for' m.e.ios.ix.1
end
return envPushEnv(e)
endProcedure envPush
envPushEnv: procedure expose m.
parse arg e
call mAdd env, e
if m.e.in == '' then
m.e.in = m.j.jIn
else
m.j.jIn = m.e.in
if m.e.out == '' then
m.e.out = m.j.jOut
else
m.j.jOut = m.e.out
return e
endProcedure envPushEnv
/*--- activate the last env from stack
and return outputbuffer from current env --------------------*/
envPop: procedure expose m.
ex = m.env.0
if ex <= 1 then
call err 'envPop on empty stack' ex
o = m.env.ex
oo = m.o.out
ex = ex - 1
m.env.0 = ex
e = m.env.ex
m.j.jIn = m.e.in
m.j.jOut = m.e.out
if objClass(oo, '') == class4Name('Cat') & m.oo.RWs.0 > 0 then
return envLazy(o)
call envClose o
return m.o.out
endProcedure envPop
envBarBegin: procedure expose m.
call envPush '>%' Cat()
return
endProcedure envBarBegin
envBar: procedure expose m.
call envPush '<%' envPop(), '>%' Cat()
return
endProcedure envBar
envBarLast: procedure expose m.
call envPush '<%' envPop()
return
endProcedure envBarLast
envBarEnd: procedure expose m.
call envPop
return
endProcedure envBarEnd
/*--- return the output buffer of oRunner m -------------------------*/
envRun: procedure expose m.
parse arg m
call envPush '>%' jBuf()
call oRun m
return envPop()
endProcedure envRun
/* copy env end *******************************************************/
/* copy cat begin ****************************************************
***********************************************************************/
/*--- create a reader or writer --------------------------------------*/
catMake: procedure expose m.
parse arg opt spec
if pos(m.j.cObj, opt) > 0 then
return spec
else if pos(m.j.cVar, opt) > 0 then do
if envhasKey(spec) then
return catMake(translate(opt, m.j.cObj, m.j.cVar) envGet(spec))
else
return envPut(spec, jBuf())
end
else if pos('&', opt) > 0 then
return file('&'spec)
else
return file(spec)
endProcedure catMake
/*--- create a new cat -----------------------------------------------*/
cat: procedure expose m.
m = oNew('Cat') /* calls catReset */
do ax=1 to arg()
call catWriteAll m, arg(ax)
end
return m
endProcedure cat
catReset: procedure expose m.
parse arg m
m.m.RWs.0 = 0
m.m.catWr = ''
m.m.catRd = ''
m.m.catIx = -9
return m
endProcedure catReset
catClose: procedure expose m.
parse arg m
if m.m.catIx == -9 then
return
if m.m.catWr \== '' then do
call jClose m.m.catWr
call mAdd m'.RWS', jOpt(m.j.cObj) m.m.catWr
m.m.catWr = ''
end
if m.m.catRd \== '' then do
ix = m.m.catIx
if pos(m.j.cNoOC, word(m.m.RWs.ix, 1)) < 1 then
call jClose m.m.catRd
m.m.catRd = ''
end
m.m.catIx = -9
return m
endProcedure catClose
catOpen: procedure expose m.
parse arg m, oo
if pos(m.j.cRead, oo) > 0 then do
m.m.catIx = 0
m.m.catRd = catNextRdr(m)
m.m.jReading = 1
end
else if abbrev(oo, m.j.cWri) | abbrev(oo, m.j.cApp) then do
if abbrev(oo, m.j.cWri) then
m.m.RWs.0 = 0
m.m.catIx = -7
m.m.jWriting = 1
end
else do
call err 'catOpen('m',' oo') bad opt'
end
return m
endProcedure catOpen
/*--- return and open next reader ------------------------------------*/
catNextRdr: procedure expose m.
parse arg m
cx = m.m.catIx
if cx > 0 & cx <= m.m.RWs.0 ,
& pos(m.j.cNoOC, word(m.m.RWs.cx, 1)) < 1 then
call jClose m.m.catRd
cx = cx + 1
m.m.catIx = cx
if cx > m.m.RWs.0 then
return ''
return jOpen(catMake(m.m.RWs.cx),
, m.j.cRead||substr(word(m.m.RWs.cx, 1), 2))
endProcedure catNextRdr
catRead: procedure expose m.
parse arg m, var
do while m.m.catRd \== ''
if jRead(m.m.catRd, var) then
return 1
m.m.catRd = catNextRdr(m)
end
return 0
endProcedure catRead
catWrite: procedure expose m.
parse arg m, line
if m.m.catWr == '' then
m.m.catWr = jOpen(jBuf(), m.j.cWri)
call jWrite m.m.catWr, line
return
endProcedure catWrite
catWriteR: procedure expose m.
parse arg m, var
if m.m.catWr == '' then
m.m.catWr = jOpen(jBuf(), m.j.cWri)
call jWriteR m.m.catWr, var
return
endProcedure catWriteR
/*--- write contents of a reader to cat
or keep it for later reading -------------------------------*/
catWriteAll: procedure expose m.
parse arg m
if m.m.catIx >= 0 then
call err 'catWriteAll('m',' arg(2)') but opened,',
'catIx='m.m.catIx
if m.m.catWr \== '' then do
call mAdd m'.RWS', jOpt(m.j.cObj) jClose(m.m.catWr)
m.m.catWr = ''
end
do ax=2 by 1 to arg()
if words(arg(ax)) = 1 then
call mAdd m'.RWS', jOpt() arg(ax)
else
call mAdd m'.RWS', jOpt(word(arg(ax),1)) subword(arg(ax),2)
end
return
endProcedure catWriteAll
/*--- create a reader/writer for an external file --------------------*/
file: procedure expose m.
parse arg sp
return oNew('File', sp)
endProcedure file
fileWriteR: procedure expose m.
parse arg m, var
if symbol('m.class.o2c.var') == 'VAR' then do
ty = m.class.o2c.var
if m.ty \== 'v' then
call err 'fileWriteR with var' var 'class' ty
end
call jWrite m, m.var
return
endProcedure fileWriteR
fileChild: procedure expose m.
parse arg m, name, opt
interpret objMet(m, 'fileChild')
endProcedure fileChild
fileRm: procedure expose m.
parse arg m
interpret objMet(m, 'fileRm')
return
endProcedure fileRm
filePath: procedure expose m.
parse arg m
interpret objMet(m, 'filePath')
endProcedure filePath
fileIsFile: procedure expose m.
parse arg m
interpret objMet(m, 'fileIsFile')
endProcedure fileIsFile
fileIsDir: procedure expose m.
parse arg m
interpret objMet(m, 'fileIsDir')
endProcedure fileIsDir
fileMkDir: procedure expose m.
parse arg m, opt
interpret objMet(m, 'fileMkDir')
return
endProcedure fileRm
fileRmDir: procedure expose m.
parse arg m, opt
interpret objMet(m, 'fileRmDir')
return
endProcedure fileRm
/*--- create a reader/writer for the filelist of a directory----------*/
fileList: procedure expose m.
parse arg m, opt
return oNew('FileList', filePath(m), opt)
endProcedure fileList
catIni: procedure expose m.
if m.cat.ini == 1 then
return
m.cat.ini = 1
call jIni
call classNew "n Cat u JRW", "m",
, "jOpen return catOpen(m, opt)",
, "jReset return catReset(m, arg)",
, "jClose call catClose m",
, "jRead return catRead(m, var)",
, "jWrite call catWrite m, line; return",
, "jWriteR call catWriteR m, var; return",
, "jWriteAll call catWriteAll m, optRdr; return"
os = errOS()
if os == 'TSO' then
call fileTsoIni
else if os == 'LINUX' then
call fileLinuxIni
else
call err 'file not implemented for os' os
return
endProcedure catIni
/* copy cat end ****************************************************/
/* copy fiLinux begin *************************************************/
/*--- send ggShCmd to shell bash,
fail if rc <> 0 or not listed in ggRet -----------------------*/
adrSh: procedure expose m. /* really no need for variables???? */
parse arg ggShCmd, ggRet
address 'bash' ggShCmd
if rc == 0 then return 0
else if ggRet == '*' then return rc
else if wordPos(rc, ggRet) > 0 then return rc
else
call err 'adrSh rc' rc 'for' ggShCmd
endProcedure adrSh
fileLinuxReset: procedure expose m.
parse arg m, nm
m.m.spec = nm
if abbrev(nm, '&') then do
if nm == '&in' then do
m.m.stream = .input
m.m.jReading = 1
end
else if nm == '&out' then do
m.m.stream = .output
m.m.jWriting = 1
end
else do
call err 'bad spec' nm
end
end
else do
m.m.stream = .Stream$mc$new(nm)
m.m.stream$mc$init(m.m.stream$mc$qualify)
end
return m
endProcedure fileLinuxReset
fileLinuxOpen: procedure expose m.
parse arg m, opt
if pos(m.j.cRead, opt) > 0 then do
res = m.m.stream$mc$open(read shareread)
m.m.jReading = 1
end
else do
if pos(opt, m.j.cApp) > 0 then
res = m.m.stream$mc$open(write append)
else if pos(opt, m.j.cWri) > 0 then
res = m.m.stream$mc$open(write replace)
else
call err 'fileLinuxOpen('m',' opt') with bad opt'
m.m.jWriting = 1
end
if res \== 'READY:' then
call err 'fileLinuxOpen fails' res':' opt m.m.stream$mc$qualify
return m
endProcedure fileLinuxOpen
fileLinuxClose:
parse arg m
res = m.m.stream$mc$close
if res \== 'READY:' then
call err 'fileLinuxClose' res':' m.m.stream$mc$qualify
return m
endProcedure fileLinuxClose
fileLinuxRead: procedure expose m.
parse arg m, var
res = m.m.stream$mc$lineIn
if res == '' then
if m.m.stream$mc$state \== 'READY' then
return 0
m.var = res
return 1
endProcedure fileLinuxRead
fileLinuxWrite: procedure expose m.
parse arg m, line
if m.m.stream$mc$lineOut(line) then
call err 'fileLinuxWrite'
return
endProcedure fileLinuxWrite
fileLinuxRmDir: procedure expose m.
parse arg m, opt
if opt == '' then
return adrSh('rmdir' m.m.spec)
else if opt == '-r' then
return adrSh('rm -r' m.m.spec)
else
call err 'bad opt' opt 'in fileLinuxRmDir'
endProcedure fileLInuxRmDir
fileLinuxListReset: procedure expose m.
parse arg m, m.m.spec, o
if o == 'r' then
m.m.opt = 'S'
else if o == '' then
m.m.opt = ''
else
call err 'bad opt' o 'in fileLinuxListReset'
m.m.rx = 'closed'
return m
endProcedure fileLinuxListReset
fileLinuxListOpen: procedure expose m.
parse arg m
if m.m \== value('m.'m) then
call err 'bad m for fileLinuxList:' m
if m.m.opt == '' then
rc = sysFileTree(m.m.spec'/*', 'm.'m'.LIST')
else
rc = sysFileTree(m.m.spec'/*', 'm.'m'.LIST', m.m.opt)
if rc \== 0 then
call err 'rc' rc 'in sysFileTree('m.m.spec', m.'m'.LIST)'
m.m.rx = 0
m.m.jReading = 1
return m
endProcedure fileLinuxListOpen
fileLinuxListRead: procedure expose m.
parse arg m, var
x = m.m.rx + 1
if x > m.m.list.0 then
return 0
m.var = substr(m.m.list.x, 43)
m.m.rx = x
return 1
endProcedure fileLinuxListRead
fileLinuxIni: procedure expose m.
if m.fileLinux.ini == 1 then
return
m.fileLinux.ini = 1
m.file.sep = '/'
call jIni
call classNew "n File u JRW", "m",
, "jReset return fileLinuxReset(m, arg)",
, "jOpen return fileLinuxOpen(m, opt)",
, "jClose call fileLinuxClose m",
, "jRead return fileLinuxRead(m, var)",
, "jWrite call fileLinuxWrite m, line",
, "jWriteR call fileWriteR m, var",
, "filePath return m.m.stream~qualify",
, "fileIsFile return sysIsFile(m.m.stream~qualify)" ,
, "fileIsDir return sysIsFileDirectory(m.m.stream~qualify)" ,
, "fileChild return file(m.m.stream~qualify'/'name)",
, "fileRm return adrSh(m.m.spec)",
, "fileMkDir return adrSh('mkdir' m.m.stream~qualify)" ,
, "fileRmDir return fileLinuxRmDir(m, opt)"
call classNew "n FileList u JRW", "m",
, "jReset return fileLinuxListReset(m, arg, arg2)",
, "jOpen return fileLinuxListOpen(m, opt)",
, "jClose m.m.rx = 'closed'",
, "jRead return fileLinuxListRead(m, var)"
return
endProcedure fileLinuxIni
/* copy fiLinux end *************************************************/
/* copy fileTso begin *************************************************/
fileTsoReset: procedure expose m.
parse arg m, sp
m.m.readIx = 'c'
if symbol('m.m.defDD') \== 'VAR' then do
ix = mInc('FILETSO.BUF')
m.m.defDD = 'CAT'ix
m.m.buf = 'FILETSO.BUF'ix
m.m.spec = sp
end
if sp \== '' then do
m.m.spec = dsnSpec(sp)
rr = translate(subword(m.m.spec, 4))
m.m.stripT = \ (pos(':V', rr) > 0 | pos('RECFM(V', rr) > 0)
end
return m
endProcedure fileTsoReset
fileTsoOpen: procedure expose m.
parse arg m, opt
buf = m.m.buf
if pos(m.j.cRead, opt) > 0 then do
aa = dsnAlloc(m.m.spec, 'SHR', m.m.defDD)
/* ???wkTest fehlermeld funktioniert so nicht, ist sie noetig?
if m.dsnAlloc.dsn <> '' then
if sysDsn("'"m.dsnAlloc.dsn"'") <> 'OK' then
call err 'cannot read' m.dsnAlloc.dsn':',
sysDsn("'"m.dsnAlloc.dsn"'") */
call readDDBegin word(aa, 1)
m.m.jReading = 1
m.buf.0 = -1
m.m.readIx = 0
end
else do
if pos(opt, m.j.cApp) > 0 then
aa = dsnAlloc(m.m.spec, 'MOD', m.m.defDD)
if pos(opt, m.j.cWri) > 0 then
aa = dsnAlloc(m.m.spec, 'OLD', m.m.defDD)
else
call err 'fileTsoOpen('m',' opt') with bad opt'
call writeDDbegin word(aa, 1)
m.m.jWriting = 1
m.buf.0 = 0
m.m.readIx = 'w'
end
m.m.dd = word(aa, 1)
m.m.free = subword(aa, 2)
return m
endProcedure fileTsoOpen
fileTsoClose:
parse arg m
buf = m.m.buf
if m.m.readIx \== 'c' then do
if m.m.readIx == 'w' then do
if m.buf.0 > 0 then
call writeDD m.m.dd, 'M.'BUF'.'
call writeDDend m.m.dd
end
else do
call readDDend m.m.dd
end
interpret m.m.free
end
m.buf.0 = 'closed'
m.m.readIx = 'c'
m.m.free = ''
m.m.dd = ''
return m
endProcedure fileTsoClose
fileTsoRead: procedure expose m.
parse arg m, var
ix = m.m.readIx + 1
buf = m.m.buf
if ix > m.buf.0 then do
res = readDD(m.m.dd, 'M.'buf'.')
if \ res then
return 0
ix = 1
end
m.m.readIx = ix
m.var = m.buf.ix
return 1
endProcedure fileTsoRead
fileTsoWrite: procedure expose m.
parse arg m, var
buf = m.m.buf
ix = m.buf.0 + 1
m.buf.0 = ix
if m.m.stripT then
m.buf.ix = strip(var, 't')
else
m.buf.ix = var
if ix > 99 then do
call writeDD m.m.dd, 'M.'buf'.'
m.buf.0 = 0
end
return
endProcedure fileTsoWrite
fileTsoWriteR: procedure expose m.
parse arg m, var
if objClass(var, m.class.classV) == m.class.classV then do
call fileTsoWrite m, m.var
return
end
call err 'fileTsoWriteR('m',' var') cannot write objects of class',
objClass(var)
endProcedure fileTsoWriteR
fileTsoIni: procedure expose m.
if m.fileTso.ini == 1 then
return
m.fileTso.ini = 1
m.file.sep = '.'
m.fileTso.buf = 0
call jIni
um = "call err 'for tso undefined method'"
call classNew "n File u JRW", "m",
, "jOpen return fileTsoOpen(m, opt)",
, "jReset return fileTsoReset(m, arg)",
, "jClose call fileTsoClose m",
, "jRead return fileTsoRead(m, var)",
, "jWrite call fileTsoWrite m, line",
, "jWriteR call fileTsoWriteR m, var",
, "filePath return word(m.m.spec, 1)" ,
, "fileIsFile" um "'fileIsFile'" ,
, "fileIsDir return 1" ,
, "fileChild return file(word(m.m.spec, 1)'.'name opt)",
, "fileRm" um "'fileRm'" ,
, "fileMkDir" ,
, "fileRmDir" um "'fileRmDir'"
/* , "filePath return m.m.stream~qualify",
, "fileIsFile return sysIsFile(m.m.stream~qualify)" ,
, "fileIsDir return sysIsFileDirectory(m.m.stream~qualify)" ,
, "fileChild return file(m.m.stream~qualify'/'name)",
, "fileRm return adrSh(m.m.spec)",
, "fileMkDir return adrSh('mkdir' m.m.stream~qualify)" ,
, "fileRmDir return fileLinuxRmDir(m, opt)" */
call classNew "n FileList u JRW", "m",
, "jReset if arg2 == 'r' then m.m.dsnMask=arg'.**';",
"else m.m.dsnMask=arg'.*';",
, "jOpen call csiOpen m, m.m.dsnMask; m.m.jReading=1; return",
, "jClose" ,
, "jRead return csiNext(m, var)"
return
endProcedure fileTsoIni
/* copy fileTso end *************************************************/
/* copy sqlO begin ***************************************************
sql interface mit o und j Anbindung
***********************************************************************/
sqlOini: procedure expose m.
if m.sqlO.ini == 1 then
return
m.sqlO.ini = 1
call sqlIni
call envIni
call oDecMethods oNewClass("SqlType", "JRW"),
, "jOpen call sqlOpen substr(m, 8); m.m.jReading = 1",
, "jClose call sqlClose substr(m, 8)",
, "jRead return sqlFetch(substr(m, 8), var)"
call oDecMethods oNewClass("SqlLn", "SqlType"),
, "jRead return sqlFetchLn(substr(m, 8), var)"
return
endProcedure sqlOini
/*--- fetch all rows into stem st
from sql src using type ty and format fmt -----------------*/
sql2St: procedure expose m.
parse arg st, src, ty, fmt
cx = 49
call sql2Cursor cx, src, ty, fmt
call sqlOpen cx
do ix=1 by 1 while sqlFetch(cx, st'.'ix)
end
m.st.0 = ix-1
call sqlClose cx
return ix-1
endProcedure sql2St
/*--- prepare statement 's'cx and declare cursor 'c'cx from sql src
use or generate type ty and format fo ---------------------*/
sql2Cursor: procedure expose m.
parse arg cx, src, ty, fo
call sqlPreDeclare cx, src, 1 /* with describe output */
call sqlGenType cx, ty
m.Sql.cx.FMT.0 = 0
m.Sql.cx.FMT = sqlGenFmt('SQL.'cx'.FMT', cx, fo)
call assert 'm.'m.sql.cx.fmt'.0 >= m.sql.cx.d.sqlD', 'too few fmt'
return
endProcedure sql2Cursor
/*--- return the type for sql cx -------------------------------------*/
sqlType: procedure expose m.
parse arg cx
return oGetTypePara('SQL.TY.'cx)
/*--- fetch cursor 'c'cx into destination dst
each column is formatted and assigned to m.dst.<colName> ---*/
sqlFetch: procedure expose m.
parse arg cx, dst
if ^ sqlFetchInto(cx, 'descriptor :M.SQL.'cx'.D') then
return 0
if dst == '' then
return 1
fi = oFlds(sqlType(cx))
fo = m.sql.cx.fmt
do ix=1 to m.sql.cx.d.SQLD
f = m.fi.ix
if m.sql.cx.d.ix.sqlInd = 0 then
m.dst.f = fmt(m.sql.cx.d.ix.sqlData, m.fo.ix)
else
m.dst.f = fmtS(m.sqlNull, m.fo.ix)
end
return 1
endProcedure sqlFetch
/*--- fetch cursor 'c'cx
put the formatted and concatenated columns into m.var
return 1 if a row fetched, 0 if not ------------------------*/
sqlFetchLn: procedure expose m.
parse arg cx, var
st = 'SQL.'cx'.FET'
if ^ sqlFetch(cx, st) then
return 0
m.var = oFldCat(sqlType(cx), st, m.sql.cx.fmt)
return 1
endProcedure sqlFetchLn
/*--- generate the type sql cx as specified in ty
use the information from the sqlDa -------------------------*/
sqlGenType: procedure expose m.
parse arg cx, ty
if ty == '*' | ty = '' then do
ff = ''
do ix=1 to m.sql.cx.d.sqlD
f1 = word(m.sql.cx.d.ix.sqlName, 1)
if f1 == '' then
f1 = 'COL'ix
ff = ff f1
end
ty = oFldOnly(ff, 'e')
end
call oSetTypePara 'SQL.TY.'cx, ty, 'noCall'
return ty
endProcedure sqlGenType
/*--- generate the format ff for a sql cx as specified in sp
use the information from the sqlDa -------------------------*/
sqlGenFmt: procedure expose m.
parse arg ff, cx, sp
if abbrev(sp, '=') then
return substr(sp, 2)
if sp = '' then
sp = '*st'
m.ff.0 = m.sql.cx.d.sqlD
m.ff.flds = oFlds(sqlType(cx))
if abbrev(sp, '*') then do
do ix=1 to m.ff.0
m.ff.ix = substr(sp, 2)
end
return ff
end
if abbrev(fmts, '=') then
m.Sql.cx.FMT = substr(fmts, 2)
defs = 'ir7 fr9 sl12 Tl26' sp
do wx = 1 to words(defs)
parse value word(defs, wx) with ty 2 fo
select
when ty = 'd' then t.384 = fo
when ty = 'f' then t.480 = fo'/f'
when ty = 'i' then t.496 = fo'/i'
when ty = 'n' then t.484 = fo'/n'
when ty = 's' then t.448 = fo
when ty = 't' then t.388 = fo
when ty = 'T' then t.392 = fo
otherwise call err 'bad type' ty 'for format' fo
end
end
if symbol('t.496') == 'VAR' then
t.500 = t.496
if symbol('t.448') == 'VAR' then do
t.452 = t.448
t.456 = t.448
t.464 = t.448
end
do wx = 1 to m.ff.0
ty = m.sql.cx.d.wx.sqlType
le = m.sql.cx.d.wx.sqlLen
withNulls = ty // 2
ty = ty - withNulls
if symbol('t.ty') <> 'VAR' then
call err 'sqlType' ty 'not supported'
parse var t.ty fo 2 fl '/' op
if op = 'i' then
if le = 2 then le = 6
else le = 12
else if op <> '' then
call err 'length for sqlType' ty 'op' op 'not implemented'
if fl = '=' then
fl = le
else if abbrev(fl, '<') then
fl = min(le, substr(fl, 2))
m.ff.wx = fo || fl
end
return ff
endProcedure sqlGenFmt
/*--- sql o interface ------------------------------------------------*/
/*--- return a reader for the givenn sql or std input ----------------*/
sql2Obj: procedure expose m.
parse arg cx, src, ty, fo
if ty = '' then
ty = '*'
if src == '' then
src = envCatStr(' ', 'sb')
call sql2Cursor cx, src, ty, substr(fo, 1+abbrev(fo, '~'))
call oMutate 'SQL.TY.'cx, 'SqlType'
return 'SQL.TY.'cx
endProcedure sql2obj
/*--- write to std output the result columns of
the sql given in src or std input --------------------------*/
sql: procedure expose m.
parse arg cx, src, ty, fo
call jWriteAll m.j.jOut, "r£", sql2Obj(cx, src, ty, fo)
return
endProcedure sql
/*--- write to std output the result lines of
the sql given in src or std input --------------------------*/
sqlLn: procedure expose m.
parse arg cx, src, ty, fo
if fo = '' then
fo = '~'
squash = abbrev(fo, '~')
if ^ abbrev(fo, '=') then
fo = left(fo, squash) 'sl=' substr(fo, squash+1)
t = sql2Obj(cx, src, ty, fo)
if squash then do
call fmtFldSquashRw t, 'opCl'
return
end
m = 'SQL.LN.'cx
call oMutate m, 'SqlLn'
call jWrite m.j.jOut, fmtFldTitle(m.sql.cx.fmt)
call jWriteAll m.j.jOut, "r£", m
return
endProcedure sqlLn
/* copy sqlO end **************************************************/
/* copy sql begin ***************************************************
sql interface
***********************************************************************/
sqlIni: procedure expose m.
m.sqlNull = '---'
return
endProcedure sqlIni
/*--- prepare statement 's'cx from sql src into descriptor desc ------*/
sqlPrepare: procedure expose m.
parse arg cx, src, descOut, descInp
s = ''
if descOut == 1 then
s = 'into :M.SQL.'cx'.D'
call sqlExec 'prepare s'cx s 'from :src'
if descInp == 1 | (descInp == '' & pos('?', src) > 0) then
call sqlExec 'describe input s'cx 'into :M.SQL.'cx'.I'
else
m.sql.cx.i.sqlD = 0
return
endProcedure
/*--- prepare and declare 'c'cx from sql src -------------------------*/
sqlPreDeclare: procedure expose m.
parse arg cx, src, descOut, descInp
call sqlPrepare cx, src, descOut, descInp
call sqlExec 'declare c'cx 'cursor for s'cx
return
endProcedure sqlPreDeclare
/*--- prepare, declare and open 'c'cx from sql src -------------------*/
sqlPreOpen: procedure expose m.
parse arg cx, src, descOut, descInp
call sqlPreDeclare cx, src, descOut, descInp
call sqlOpen cx
return
endProcedure sqlPreOpen
/*--- open cursor 'c'cx using arguments arg(2), arg(3)... ------------*/
sqlOpen: procedure expose m.
parse arg cx
do ix=1 to arg()-1
call sqlDataSet 'SQL.'cx'.I', ix, arg(ix+1)
end
call sqlExec 'open c'cx 'using descriptor :M.SQL.'cx'.I'
return
endProcedure sqlOpen
/*--- close cursor 'c'cx ---------------------------------------------*/
sqlClose: procedure expose m.
parse arg cx, src
return sqlExec('close c'cx)
endProcedure sqlClose
/*--- fetch cursor 'c'cx into variables ggVars -----------------------*/
sqlFetchInto:
parse arg ggCx, ggVars
if ggVars == '' then
ggVars = 'descriptor :M.SQL.'ggCX'.D'
/* accept sqlCodes > 0 except 100 */
return sqlExec('fetch c'ggCx 'into' ggVars, 0 100) <> 100
endProcedure sqlFetchInto
/*--- return sql variable list for stem st and fields the word in vars
if withInd == 1 then with sqlIndicator variables
sqlVars('S', 'A B') --> ':S.A, :S.B'
sqlVars('S', 'A B', 1) --> ':S.A :S.A.SQLIND, :S.B :S.B.SQLIND'
----------------------------------------------------------------------*/
sqlVars: procedure expose m.
parse arg st, vars, withInd
res = ''
if st ^== '' then
st = st'.'
do ix=1 to words(vars)
res = res', :'st || word(vars, ix)
if withInd == 1 then
res = res ':'st || word(vars, ix)'.SQLIND'
end
return substr(res, 3)
endProcedure sqlVars
sqlVarsNull: procedure expose m.
parse arg st, vars
hasNulls = 0
do ix = 1 to words(vars)
fld = word(vars, ix)
if m.st.fld.sqlInd < 0 then do
m.st.fld = m.sqlNull
hasNulls = 1
end
end
return hasNulls
endProcedure sqlVarsNull
sqlDescNull: procedure expose m.
parse arg cx
desc = 'SQL.'ggCX'.D',
hasNulls = 0
do ix=1 to m.desc.SQLD
if m.desc.ix.sqlInd < 0 then do
m.desc.ix.sqlData = m.sqlNull
hasNulls = 1
end
end
return hasNulls
endProcedure sqlDescNull
/*--- open cursor 'c'cx fetch all into variables vars and close
st = passed stem, sx = row number
return number of rows fetched ----------------------------------*/
sqlOpAllCl:
parse arg ggCx, st, ggVars
do ggAx=4 to arg()
call sqlDataSet 'SQL.'ggCx'.I', ggAx-3, arg(ggAx)
end
call sqlOpen ggCx
do sx = 1 while sqlFetchInto(ggCx, ggVars)
end
m.st.0 = sx - 1
call sqlClose ggCx
return m.st.0
endProcedure sqlOpAllCl
sqlDataSet: procedure expose m.
parse arg da, ix, val
m.da.ix.sqlData = val
m.da.ix.sqlInd = - (arg(ix+2) == m.sqlNull)
return
endProcedure sqlDataSet
/*--- prepare, declare open cursor 'c'cx, fetch all and close
return number of rows fetched ----------------------------------*/
sqlPreAllCl:
parse arg ggCx, ggSrc, st, ggVars
call sqlPreDeclare ggCx, ggSrc
return sqlOpAllCl(ggCx, st, ggVars)
endProcedure sqlPreAllCl
/*--- execute statement 's'cx using arguments arg(2), arg(3)... ------*/
sqlExecute:
parse arg ggCx
do ggAx=2 to arg()
call sqlDataSet 'SQL.'ggCx'.I', ggAx-1, arg(ggAx)
end
call sqlExec 'execute s'ggCx 'using descriptor :M.SQL.'ggCx'.I'
return
endProcedure
/*--- execute immediate the sql src ----------------------------------*/
sqlExImm:
parse arg ggSrc, ggRet
return sqlExec('execute immediate :ggSrc', ggRet)
endProcedure sqlExImm
sqlCommit: procedure expose m.
parse arg src
return sqlExec('commit')
endProcedure sqlCommit
/*--- execute sql thru the dsnRexx interface -------------------------*/
sqlExec: /* no procedure, to keep variables sql... */
parse arg ggSqlStmt, ggRet, ggNo
if ggNo <> '1' then
ggSqlStmt = 'execSql' ggSqlStmt
address dsnRexx ggSqlStmt
/* say 'sqlCode' sqlCode 'rc' rc 'for' ggSqlStmt ggNo */
if rc = 0 then
return 0
else if ggRet = '*' | wordPos(sqlCode, ggRet) > 0 then
return sqlCode
else if rc < 0 then
call err sqlmsg()
else if sqlWarn.0 ^== ' ' | sqlCode <> 0 then
call errSay sqlMsg(), ,'w'
return sqlCode
endSubroutine sqlExec
/*--- connect to the db2 subsystem ggSys -----------------------------*/
sqlConnect: procedure expose m.
parse arg ggSys, ggRetCon
call sqlIni
address tso "SUBCOM DSNREXX"
if rc <> 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
if ggSys = '-' then
return 0
return sqlExec("connect" ggSys, ggRetCon ,1)
endProcedure sqlConnect
/*--- diconnect from db2 ---------------------------------------------*/
sqlDisconnect: procedure expose m.
parse arg ggRet
call sqlExec "disconnect ", ggRet, 1
return
endProcedure sqlDisconnect
/*--- issue an sql error message -------------------------------------*/
sqlMsg: /* no procedure, to keep variables sql... */
signal on syntax name sqlMsgOnSyntax
ggRes = 'sqlCode' sqlCodeT(sqlCode, sqlErrMc, sqlwarn.0':' ,
|| sqlwarn.1||sqlwarn.2||sqlwarn.3||sqlwarn.4||sqlwarn.5',',
|| sqlwarn.6||sqlwarn.7||sqlwarn.8||sqlwarn.9||sqlwarn.10)
if 0 then
sqlMsgOnSyntax: do
ggRes = 'sqlCode' sqlCode translate(sqlErrMc, ',', 'ff'x),
'<<rexx sqlCodeT not found or syntax>>\nwarnings'
do ggX=0 to 10
if sqlWarn.ggx <> '' then
ggRes = ggRes ggx'='sqlWarn.ggx
end
end
signal off syntax
ggRes = ggRes'\nstate' sqlState'\nstmt = ' ggSqlStmt
ggPref = '\nwith'
ggXX = pos(':', ggSqlStmt)+1
do 12 while ggXX > 1
ggYY = verify(ggSqlStmt, ' ,:+-*/&%?|()¢!', 'm', ggXX)
if ggYY < 1 then
ggYY = length(ggSqlStmt) + 1
ggVar = substr(ggSqlStmt, ggXX, ggYY - ggXX)
if ggVar <> '' then do
ggRes = ggRes || ggPref ggVar '=' value(ggVar)
ggPref = '\n '
end
ggXX = pos(':', ggSqlStmt, ggYY+1) + 1
end
return ggRes
endSubroutine sqlMsg
/*--- send a command to db2 through the TSO dsn processor ------------*/
sqlDsn: procedure expose m.
parse arg st, sys, cmd, rcOk
x = outtrap('M.'st'.')
push 'END'
push cmd
call address tso 'DSN SYSTEM('sys')'
rr = rc
x = outtrap(off)
if rr = 0 | rcOk = '*' | wordPos(rr, rcOk) > 0 then
return rr
fl = max(1, m.st.0 - 10)
em = 'rc' rr 'for DSN SYSTEM('sys') cmd' cmd,
'\nOuputlines' fl '-' m.st.0':'
do lx=fl to m.st.0
em = em '\n' strip(m.st.lx, 't')
end
call err em
endProcedure sqlDsn
/* copy sql end **************************************************/
/* copy csi begin ***************************************************
csi interface: see dfs managing catalogs appendix c
returncode/reason see message IDC3009I
**********************************************************************/
/*--- specify dsn mask and fields to start a csi catalog search --------
arguments:
m objectPointer
dsnMask specifies the dsns with wildcards:
% 1 character
* 0 - n character in one level
** 0 - n levels
fields a (space separated) list of field names -------------*/
csiOpen: procedure expose m.
parse arg m, dsnMask, fields
m.m.fld.0 = words(fields)
ffix = d2c(m.m.fld.0, 2)
do x=1 to m.m.fld.0
m.m.fld.x = translate(word(fields, x))
ffix = ffix || left(m.m.fld.x, 8)
end
if dsnMask \== '' & pos('*', dsnMask) < 1 then
dsnMask = dsnMask'.**'
m.m.filt = left(dsnMask, 149) ,
|| left('Y', 3) , /* resume offset 149 */
|| ffix /* csiNumEn offset 152 */
WORKLEN = 1024 * 64
m.m.work = D2C(WORKLEN,4) || COPIES('00'X,WORKLEN-4)
m.m.pos = workLen + 1
return
endProcedure csiOpen
/*--- put the next dsn into m.o and m.o.* (for other fields)
return 1 if next dsn exists 0 otherwise ------------------------*/
csiNext: procedure expose m.
parse arg m, o
usedL = C2D(SUBSTR(m.m.work,9,4)) /* GET AMOUNT OF WORK AREA USED */
px = m.m.pos
do forever
if px > usedL then do
if substr(m.m.filt, 150, 1) \== 'Y' then do
m.m.pos = px
m.o = ''
return 0
end
reason = left('', 4)
ADDRESS LINKPGM 'IGGCSI00 reason m.'m'.filt m.'m'.work'
if rc == 0 & substr(reason, 3, 2) == '0000'x then
nop
else if rc == 4 & substr(reason, 3, 2) == '0464'x then
say 'data set entry with error'
else
call err 'call csi returns' rc,
'rc' c2d(substr(reason, 4,1)),
'reason' c2d(substr(reason, 3,1)),
'module' substr(reason, 1,2)
usedL = C2D(SUBSTR(m.m.work,9,4)) /* GET WORK AREA USED */
numFD = C2D(SUBSTR(m.m.work,13,2)) /* no flds + 1 */
if numFd <> m.m.fld.0 + 1 then
call err 'csiNumFd' numFd 'not' m.m.fld.0 '+' 1
px = 15
iterate
end
eType = substr(m.m.work, px+1, 1)
m.o = strip(substr(m.m.work, px+2, 44), 't')
flag = substr(m.m.work, px, 1)
/* say 'eType' eType m.o 'flag' c2x(flag) */
if eType == '0' then do
if flag \== '00'x & flag ^== '40'x then
call err 'flag' c2x(flag) 'for catalog' m.o
px = px + 50 /* length of catalog entry */
iterate
end
else do
if \ abbrev(x2b(c2x(flag)), '101') then
call err 'call csi entry flag' x2b(c2x(flag)),
'rc' c2d(substr(m.m.work, px+49,1)),
'reason' c2d(substr(m.m.work, px+48,1)),
'module' substr(m.m.work, px+46, 2),
'for entry' m.o,
'see qw IDC3009I'
py = px + 46
tl = c2d(substr(m.m.work, py, 2))
pl = py + 4
pf = py + m.m.fld.0 * 2 + 4
do fx = 1 to m.m.fld.0
fi = m.m.fld.fx
fl = c2d(substr(m.m.work, pl, 2))
m.o.fi = substr(m.m.work, pf, fl)
if fi = 'MGMTCLAS' then
m.o.fi = substr(m.o.fi, 3, c2d(left(m.o.fi ,2)))
else if wordPos(fi, 'COMUDSIZ NOBYTTRK') > 0 then
m.o.fi = c2d(m.o.fi)
pf = pf + fl
pl = pl + 2
end
if py + tl <> pf then
call err 'length mismatch for entry' m.o
m.m.pos = pf
return 1
end
end
endProcedure csiNext
/*--- if dsn is arcived return 'arcive'
if dsn is tape return 'tape'
otherwise return managment class ------------------------------*/
csiArcTape: procedure expose m.
parse arg vo, cl, dt, dsn
if vo = '' then
say err '||| no volume for dsn' dsn
else if vo = 'ARCIVE' then
res = 'arcive'
else if cl <> '' then
res = cl
else if abbrev(vo, 'SHR') then
res = 'SHR'
else
res = 'tape'
if res = 'arcive' then
return res
/*if abbrev(res, 'ar') \= abbrev(dt, '00'x) , */
if abbrev(res, 'ta') \= abbrev(c2x(left(dt, 1)), '7') ,
| (left(res, 1) >= 'A') ^= abbrev(dt, '30'x) then
say '||| mismatch cl' cl 'vo' vo 'dt' c2x(dt) 'dsn' dsn
return res
endProcedure csiArcTape
/* copy csi end ******************************************************/
/* copy adrIsp begin *************************************************/
/**********************************************************************
lmd: catalog read
call sequence: lmdBegin, lmdNext*, lmdEnd
mit lmd service (mit save in file und read,
weil list zu langsam und listcat abstürzt)
1. arg (grp) als group dataset für lmd save
und dd name für file read
***********************************************************************/
lmdBegin: procedure expose m.
parse arg grp, lev
call adrIsp 'lmdinit listid(lmdId) level('lev')'
res = adrIsp('lmdlist listid(&lmdId) option(save) group('grp')', 4)
call adrIsp 'lmdfree listid(&lmdId)'
if res = 0 then do
call trc timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') shr dsn('grp'.datasets)'
end
else do
call trc 'no datasets found' timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') dummy'
end
call readDDBegin grp
return /* end lmdBegin */
lmdNext:
parse arg ggGrp, ggSt, withVolume
if \ readDD(ggGrp, ggSt) then
return 0
if withVolume \== 1 then
do ggIx=1 to value(ggSt'0')
x = value(ggSt || ggIx, word(value(ggSt || ggIx), 1))
end
return 1
endSubroutin lmdNext
lmdEnd: procedure expose m.
parse arg grp
call readDDEnd grp
call adrTso 'free dd('grp')'
return /* end lmdEnd */
lmd: procedure expose m.
parse arg lev, withVol
call lmdBegin gg1, lev
do while lmdNext(gg1, q., withVol)
do x=1 to q.0
call jOut q.x
end
end
call lmdEnd gg1
return
endProcedure lmd
/**********************************************************************
member list of a pds:
call sequence x=lmmBegin(dsn) lmmNext(x) * lmmEnd(x)
***********************************************************************/
lmm: procedure expose m.
parse arg dsn
id = lmmBegin(dsn)
do ix=1 by 1
m = lmmNext(id)
if m = '' then
leave
call jOut m
end
call lmmEnd id
return
endProcedure lmm
lmmBegin: procedure expose m.
parse arg dsn
mbr = dsnGetMbr(dsn)
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET('"pds"') ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(INPUT) "
res = lmmId
if mbr <> '' then
res = res 'pattern('mbr')'
return res
endProcedure lmmBegin
lmmEnd: procedure expose m.
parse arg lmmId opt
call adrIsp "LMMLIST DATAID("lmmId") option(free)", 8
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
return
endProcedure lmmEnd
lmmNext: procedure expose m.
parse arg lmmId opt
if adrIsp("LMMLIST DATAID("lmmid")" ,
"OPTION(LIST) MEMBER(Mbr)" opt, 4 8) = 0 then
return strip(mbr)
else
return ''
endProcedure lmmNext
lmmRm: procedure expose m.
parse arg dsn, mbrs
mbrs = dsnGetMbr(dsn) mbrs
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET("pds") ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(OUTPUT) "
err = ''
do wx=1 to words(mbrs)
m1 = word(mbrs, wx)
rr = adrIsp("lmmDel dataid("lmmId") member("m1")", 0 8 12)
if rc = 0 then
say 'removed' m1 'from' pds
else if rc = 8 then
say 'not found' m1 'in' pds
else do
err = 'error deleting' m1 'in' pds 'rc' rr strip(zerrlm)
say err
leave
end
end
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
if err <> '' then
call err err
return
endProcedure lmmRm
/*--- address ispf with error checking -------------------------------*/
adrIsp:
parse arg ggIspCmd, ggRet
address ispexec ggIspCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr ispExec rc' rc 'in' ggIspCmd':' strip(zerrlm)
endSubroutine adrIsp
/*--- address editor with error checking -----------------------------*/
adrEdit:
parse arg ggEditCmd, ggRet
address isrEdit ggEditCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr isrEdit rc' rc 'for' ggEditCmd
endSubroutine adrEdit
/* copy adrIsp end *************************************************/
/* copy adrTso begin *************************************************/
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet ---*/
adrTso:
parse arg ggTsoCmd, ggRet
address tso ggTsoCmd
if rc == 0 then return 0
else if ggRet == '*' then return rc
else if wordPos(rc, ggRet) > 0 then return rc
else
call err 'adrTso rc' rc 'for' ggTsoCmd
return /* end adrTso */
/*--- format dsn from tso format to jcl format -----------------------*/
dsn2jcl: procedure expose m.
parse upper arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
cx = pos('~', dsn)
if cx < 1 & addPrefix == 1 then
return sp'.'dsn
do while cx ^== 0
le = left(dsn, cx-1)
ri = substr(dsn, cx+1)
if right(le, 1) == '.' | left(ri, 1) == '.' then
dsn = le || sp || ri
else
dsn = le || left('.', le ^== '') || sp ,
|| left('.', ri ^== '') || ri
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
parse arg dsn, mbr
bx = pos('(', dsn)
if bx > 0 then
dsn = strip(left(dsn, bx-1))
if mbr <> '' then
dsn = dsn'('strip(mbr)')'
return dsn
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn
lx = pos('(', dsn)
rx = pos(')', dsn, lx+1)
if lx < 1 then
return ''
else if lx < rx then
return substr(dsn, lx+1, rx-lx-1)
else
return strip(substr(dsn,lx+1))
endProcedure dsnGetMbr
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: readDDBegin, readDD*, readDDEnd
write: writeBegin, writeDD*, writeEnd
readDD returns true if data read, false at eof
***********************************************************************/
/*--- prepare reading from a DD --------------------------------------*/
readDDBegin: procedure expose m.
return /* end readDDBegin */
/*--- read from DD ggDD into ggSt, return false at eof ---------------*/
readDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskr' ggDD '(stem' ggSt')', 2
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- finish reading DD ggDD ----------------------------------------*/
readDDEnd: procedure expose m.
parse arg ggDD
call adrTso 'execio 0 diskr' ggDD '(finis)'
return /* end readDDEnd */
/*--- prepare writing to DD ggDD -------------------------------------*/
writeDDBegin: procedure expose m.
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 expose m.
parse arg ggDD
call adrTso 'execio 0 diskw' ggDD '(finis)'
return /* end writeDDEnd */
/*--- standardise a dsn spec
word1 dsName or -
word2 dd or -
word3 disp or -
word4 to first : attributes in tso format
after first : attributes for new allocation
----------------------------------------------------------------------*/
dsnSpec: procedure expose m.
parse upper arg spec
rr = '' /* put leading - in separate words */
do sx=1 while words(rr) < 3 & wx \= ''
wx = word(spec, sx)
do while abbrev(wx, '-') & words(rr) < 3
wx = substr(wx, 2)
rr = rr '-'
end
rr = rr wx
end
spec = rr subWord(spec, sx)
na = ''
dd = ''
di = ''
if left(spec, 1) = '&' then /* external spec is handled ok */
spec = strip(substr(spec, 2))
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, '.') | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
di = w
else if w = 'CATALOG' then
di = di'+'w
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
na = strip(substr(w, 5, length(w)-5))
else if na == '' then
na = dsn2jcl(w)
else if dd == '' then
dd = w
else if di == '' then
di = w
else
leave
end
if na == '' then na = '-'
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 or a dd
spec '-'<ddName>
datasetName? disposition? '.'? attributes? (':' newAtts)?
disp default disposition
dd default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc -----*/
dsnAlloc: procedure expose m.
parse upper arg spec, pDi, pDD, retRc
parse value dsnSpec(spec) with na dd di rest
if na = '-' then
m.dsnAlloc.dsn = ''
else
m.dsnAlloc.dsn = na
if na == '-' & dd \== '-' & di == '-' & rest = '' then
return dd
if dd == '-' & pDD \== '' then
dd = pDD
if dd == '-' then do
if symbol('m.adrTso.ddNum') = 'VAR' then
dd = m.adrTso.ddNum + 1
else
dd = 1
m.adrTso.ddNum = dd
dd = 'DD' || dd
end
if di = '-' & pDi ^== '' then
di = pDi
if di = '-' then
di = 'SHR'
else if pos('(', na) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if pos('/', ds) > 0 then
return csmAlloc(na dd di rest, retRc)
else
return tsoAlloc(na dd di rest, retRc)
endProcedure dsnAlloc
tsoAlloc: procedure expose m.
parse arg na dd disp rest ':' nn, retRc
c = 'alloc dd('dd')' disp
if na ^== '-' then
c = c "DSN('"na"')"
if retRc <> '' | nn == '' then do
alRc = adrTso(c rest, retRc)
if alRc <> 0 then
return ' ' alRc
return dd 'call adrTso "free dd('dd')";'
end
do retry=0 by 1
alRc = adrTso(c rest, '*')
if alRc = 0 then
return dd 'call adrTso "free dd('dd')";'
if retry > 0 | nn = '' | wordPos(disp, 'OLD SHR') < 1 ,
| sysDsn("'"m.dsnAlloc.dsn"'") ^== 'DATASET NOT FOUND' then
call err 'tsoAlloc rc' alRc 'for' c rest
say 'tsoAlloc rc' alRc 'for' c rest '...trying to create'
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
end
endProcedure tsoAlloc
dsnCreateAtts: procedure expose m.
parse arg dsn, atts, forCsm
bl = 32760
if abbrev(atts, ':') then do
rl = substr(atts, 3)
if abbrev(atts, ':F') then do
if rl = '' then
rl = 80
recfm='f b'
bl = bl - (bl // rl)
end
else do
if rl = '' then
rl = bl-4
recfm = substr(atts, 2, 1) 'B'
end
end
if pos('(', dsn) > 0 then
po = 'dsntype(library) dsorg(po)'
else
po = ''
dsn = dsnSetMbr(dsn)
if forCsm == 1 then
return "dataset('"dsn"')" po,
"recfm("space(recfm, 0)") lrecl("rl") blkSize("bl")" ,
"mgmtclas(COM#A091) space(10, 1000) cylinder"
else
return "dsn('"dsn"')" po,
"recfm("recfm") lrecl("rl") block("bl")" ,
"mgmtclas(COM#A091) space(10, 1000) cyl"
endProcedure dsnCreateAtts
/*--- read the dataset specified in ggDsnSpec to stem ggSt -----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
interpret subword(ggAlloc, 2)
return
endSubroutine readDsn
/*--- write the dataset specified in ggDsnSpec from stem ggSt
write ggCnt records if not empty otherwise ggst0
if ggSay 1 then say ... records written to ... -------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'open finis)'
interpret subword(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
copyDSN: procedure expose m.
parse arg frSpec, toSpec, ggSay
frDD = dsnAlloc(frSpec, 'SHR', 'FRDD')
toDD = dsnAlloc(toSpec, 'OLD', 'TODD')
call readDDBegin word(frDD, 1)
call writeDDBegin word(toDD, 1)
cnt = 0
do while readDD(word(frDD, 1), r.)
call writeDD word(toDD, 1), r.
cnt = cnt + r.0
end
call readDDEnd word(frDD, 1)
call writeDDEnd word(toDD, 1)
interpret ';' subword(frDD, 2) '; ; ;' subword(toDD, 2)
if ggSay == 1 | m.debug == 1 then
say cnt 'records copied from' frSpec 'to' to toSpec
return
endSubroutine writeDsn
/* copy adrTso end ****************************************************/
/* copy j begin *******************************************************
the j framework
jReset
jOpen
jClose
jRead
jWrite
***********************************************************************/
jRead: procedure expose m.
parse arg m, var
call objMetClaM m, 'jRead'
if m.m.jReading then
interpret ggCode
else
return err('jRead('m',' var') but not opened r')
endProcedure jRead
jWrite: procedure expose m.
parse arg m, line
call objMetClaM m, 'jWrite'
if \ m.m.jWriting then
return err('jWrite('m',' line') but not opened w')
interpret ggCode
return
endProcedure jWrite
jWriteR: procedure expose m.
parse arg m, var
call objMetClaM m, 'jWriteR'
if \ m.m.jWriting then
return err('jWriteR('m',' var') but not opened w')
interpret ggCode
return
endProcedure jWriteR
jWriteAll: procedure expose m.
parse arg m, optRdr
if words(optRdr) <= 1 then
optRdr = m.j.cRead optRdr
interpret objMet(m, 'jWriteAll')
return
endProcedure jWriteAll
jWriteNow: procedure expose m.
parse arg m, optRdr
if words(optRdr) <= 1 then
optRdr = m.j.cRead optRdr
interpret objMet(m, 'jWriteNow')
return
endProcedure jWriteNow
jCat: procedure expose m.
parse arg opt m
if m = '' then do
m = opt
opt = m.j.cWri
end
if pos(m.j.cNoOC, opt) < 1 then
call jOpen m, opt
do ax=2 to arg()
call jWriteAll m, arg(ax)
end
if pos(m.j.cNoOC, opt) < 1 then
call jClose m
return m
endProcedure jCat
jWriteNowImpl: procedure expose m.
parse arg m, opt rdr
if pos(m.j.cNoOC, opt) < 1 then
call jOpen rdr, jOpt(opt)
do while jRead(rdr, line)
call jWriteR m, line
end
if pos(m.j.cNoOC, opt) < 1 then
call jClose rdr
return
endProcedure jWriteNow
/*--- reset JRW: fail if open, initialise ---------------------------*/
jReset: procedure expose m.
parse arg m, arg, arg2, arg3
if m.m.jReading == 1 | m.m.jWriting == 1 then
call err 'still open jReset('m',' arg')' / 3
m.m.jReading = 0
m.m.jWriting = 0
interpret objMet(m, 'jReset')
return m
endProcedure jReset
jOpen: procedure expose m.
parse arg m, opt
if pos(m.j.cNoOC, opt) > 0 then
return m
call objMetClaM m, 'jOpen'
if m.m.jReading | m.m.jWriting then
return err('already opened jOpen('m',' opt')')
interpret ggCode
return m
endProcedure jOpen
jClose: procedure expose m.
parse arg m
call objMetClaM m, 'jClose'
if m.m.jReading | m.m.jWriting then
interpret ggCode
m.m.jReading = 0
m.m.jWriting = 0
return m
endProcedure jClose
/*--- analyze an option in oOpt and oVal -----------------------------*/
jOptWkTest: wkTest ??? deimplemented procedure expose m.
parse arg src, alone, val
m.j.oOpt = ''
if left(src, 1) \== '-' then do
m.j.oVal = src
return 0
end
sx = 2
if alone \== '' then do
sx = verify(src, alone, 'n', sx)
if sx = 0 then
sx = length(src)+1
end
if length(src) < sx then
m.j.oVal = ''
else if val == '' then
call err 'bad opt "'src'" should contain only "'alone'"'
else if pos(substr(src, sx, 1), val) < 1 then
call err 'bad opt "'src'" should contain only "'alone'"' ,
'and/or 1 of "'val'" with value'
else do
sx = sx + 1
m.j.oVal = substr(src, sx)
end
m.j.oOpt = substr(src, 2, sx-2)
return 1
endProcedure jOpt
jOpt: procedure expose m.
parse arg src .
if abbrev(src, '>>') then
return m.j.cApp || substr(src, 3)
else if pos(left(src, 1), m.j.cRead||m.j.cWri||m.j.cApp) < 1 then
return m.j.cDum || src
else
return src
endProcedure jOpt
jIni: procedure expose m.
if m.j.ini == 1 then
return
m.j.ini = 1
m.j.cRead = '<'
m.j.cWri = '>'
m.j.cApp = '}'
m.j.cObj = '%'
m.j.cVar = '#'
m.j.cDum = '/'
m.j.cNoOC = '-'
call oIni
am = "call err 'call of abstract method"
call classNew 'n JRW u f JREADING v, f JWRITING v', 'm',
, "new call jReset m, arg, arg2, arg3",
, "jRead" am "jRead('m',' arg')'" ,
, "jWrite" am "jWrite('m',' line')'" ,
, "jWriteR" am "jWriteR('m',' var')'" ,
, "jWriteAll call jWriteNowImpl m, optRdr",
, "jWriteNow call jWriteNowImpl m, optRdr",
, "jReset",
, "jOpen" am" jOpen('m',' opt')'" ,
, "jClose"
am = "call err 'call errObject"
call classNew 'n JRWErr u JRW', 'm',
, "jWriteAll" er "jWriteAll 'm', optRdr'",
, "jWriteNow" er "jWriteNow 'm', 'optRdr'",
, "jClose" er "jClose 'm'"
call classNew 'n JRWSay u JRW', 'm',
, "jWrite say line",
, "jWriteR call classOut , var, 'jOuR: '",
, "jOpen if pos('<', opt) > 0 then",
"call err 'can only write JRWSay.jOpen('m',' opt')';" ,
"else m.m.jWriting = 1"
call classNew 'n JRWEof u JRW', 'm',
, "jRead drop m.var; return 0",
, "jOpen if pos('>', opt) > 0 then",
"call err 'can only read JRWEof.jOpen('m',' opt')';" ,
"else m.m.jReading = 1"
m.j.jIn = oBasicNew('JRWEof')
m.j.jOut = jOpen(oNew('JRWSay'))
call outDest 'i', 'call jOut msg'
call classNew "n JBuf u JRW, f .BUF s r", "m",
, "jOpen return jBufOpen(m, opt)",
, "jReset return jBufReset(m, arg)",
, "jRead return jBufRead(m, var)",
, "jWrite a = mAdd(m'.BUF', line); drop m.class.o2c.a",
, "jWriteR call oCopy var, m'.BUF.'mInc(m'.BUF.0')"
return
endProcedure jIni
jIn: procedure expose m.
parse arg arg
return jRead(m.j.jIn, arg)
endProcedur jIn
jOut: procedure expose m.
parse arg line
call jWrite m.j.jOut, line
return
endProcedure jOut
jOuR: procedure expose m.
parse arg arg
call jWriteR m.j.jOut, arg
return
endProcedure jOut
/*--- jBuf: buffer read or write (supports datataypes) ---------------*/
jBuf: procedure expose m.
m = oNew('JBuf') /* calls jBufReset */
do ax=1 to arg()
m.m.buf.ax = arg(ax)
end
m.m.buf.0 = ax-1
return m
endProcedure jBuf
jBufReset: procedure expose m.
parse arg m
m.m.stem = m'.BUF'
do ax=1 to arg() - 1
m.m.buf.ax = arg(ax+1)
end
m.m.buf.0 = ax-1
return m
endProcedure jBufReset
jBufOpen: procedure expose m.
parse arg m, opt
opt = jOpt(opt)
if abbrev(opt, m.j.cRead) then do
m.m.readIx = 0
m.m.jReading = 1
return m
end
if abbrev(opt, m.j.cWri) then
m.m.buf.0 = 0
else if \ abbrev(opt, m.j.cApp) then
call err 'jBufOpen('m',' opt') with bad opt'
m.m.jWriting = 1
return m
endProcedure jBufOpen
jBufRead: procedure expose m.
parse arg m, var
nx = m.m.readIx + 1
if nx > m.m.buf.0 then
return 0
m.m.readIx = nx
call oCopy m'.BUF.'nx, var
return 1
endProcedure jBufRead
jBufWrite: procedure expose m.
parse arg m, line
call oCopy line, m'.BUF.'mInc(m'.BUF.0')
return 1
endProcedure jBufRead
/* copy j end *********************************************************/
/* copy o begin ******************************************************
an object has a class and may call its methods
***********************************************************************/
oIni: procedure expose m.
if m.o.ini = 1 then
return
m.o.ini = 1
call classIni
call oClassAdded m.class.classV
call mRegister 'Class', 'call oClassAdded arg'
call classNew 'n ORun u',
, 'm oRun call err "call of abstract method oRun"'
return
endProcedure oIni
/*--- when notified about a new class cl, build the redundancies ----*/
oClassAdded: procedure expose m.
parse arg cl
m.class.o2c.cl = m.class.class
m.cl.oAdr = 'O.'substr(cl, 7) /* object adresses */
m.cl.oCnt = 0
new = 'new'
m.cl.oMet.new = ''
call oAddMethod cl'.OMET', cl
call oAddFields mCut(cl'.FLDS', 0), cl
co = '' /* build code for copy */
do fx=1 to m.cl.flds.0
nm = m.cl.flds.fx
if translate(nm) == nm & \ abbrev(nm, 'GG') ,
& pos('.M.', nm'.') < 1 & pos('.T.', nm'.') < 1 then
co = co'm.t'nm '= m.m'nm';'
else
co = co 'f='quote(substr(nm, 2))';m.t.f = m.m.f;'
end
p = cl'.OMET.oCopy'
if symbol('m.p') \== VAR then
m.p = co
return
endProcedure oClassAdded
/*--- add the methods of class cl to the methodtable mt -------------*/
oAddMethod: procedure expose m.
parse arg mt, cl
if pos(m.cl, 'frsv') > 0 then
return
if m.cl = 'm' then do
nm = m.cl.name
m.mt.nm = m.cl.met
return
end
if m.cl.class \== '' then
call oAddMethod mt, m.cl.class
if m.cl.0 \== '' then
do x=1 to m.cl.0
call oAddMethod mt, m.cl.x
end
return
endProcedure oAddMethod
/*--- add the the fields of class cl to stem f ----------------------*/
oAddFields: procedure expose m.
parse arg f, cl, nm
if pos(m.cl, 'rv') > 0 then do
do fx=1 to m.f.0
if m.f.fx == nm then
return 0
end
if nm == '' then do
call mMove f, 1, 2
m.f.1 = ''
end
else do
call mAdd f, nm
end
return 0
end
if m.cl = 'f' then
return oAddFields(f, m.cl.class, nm'.'m.cl.name)
if m.cl.class \== '' then
return oAddFields(f, m.cl.class, nm)
if m.cl.0 = '' then
return 0
do tx=1 to m.cl.0
call oAddFields f, m.cl.tx, nm
end
return 0
endProcedure oAddFields
/*--- create an an object of the class className --------------------*/
oBasicNew: procedure expose m.
parse arg className
cl = class4Name(className)
m.cl.oCnt = m.cl.oCnt + 1
m = m.cl.oAdr'.'m.cl.oCnt
if cl == m.class.classV then
drop m.class.o2c.m
else
m.class.o2c.m = cl
return m
endProcedure oBasicNew
/*--- create an an object of the class className
and call it's new method ------------------------------------*/
oNew: procedure expose m.
parse arg className, arg, arg2, arg3
m = oBasicNew(className)
interpret classMet(className, 'new')
return m
endProcedure oNew
/*--- return the class of object obj --------------------------------*/
objClass: procedure expose m.
parse arg obj
if symbol('m.class.o2c.obj') == 'VAR' then
return m.class.o2c.obj
if abbrev(obj, 'CLASS.CAST.') then
return substr(obj, 12, pos(':', obj, 12)-12)
if arg() >= 2 then
return arg(2)
return err('no class found for object' obj)
endProcedure objClass
/*--- return the code of method me of the class with name na --------*/
classMet: procedure expose m.
parse arg na, me
if symbol('m.class.n2c.na') \== 'VAR' then
call err 'no class' na 'in classMet('na',' me')'
cl = m.class.n2c.na
if symbol('m.cl.oMet.me') \== 'VAR' then
call err 'no method in classMet('na',' me')'
return m.cl.oMet.me
endProcedure classMethod
/*--- set m, ggClass, ggCode to the address, class and code
of method me of object m ------------------------------------*/
objMetClaM: procedure expose m. m ggClass ggCode
parse arg m, me
if symbol('m.class.o2c.m') == 'VAR' then
ggClass = m.class.o2c.m
else if abbrev(m, 'CLASS.CAST.') then
parse var m 'CLASS.CAST.' ggClass ':' m
else
return err('no class found for object' m)
if symbol('m.ggClass.oMet.me') == 'VAR' then
ggCode = m.ggClass.oMet.me
else
call err 'no method' me 'in class' className(ggClass) 'of object' m
return
endProcedure objMetClaM
/*--- return the code of method me of object obj --------------------*/
objMet: procedure expose m.
parse arg obj, me
/* handle the easy and frequent case directly */
if symbol('m.class.o2c.obj') == 'VAR' then do
c = m.class.o2c.obj
if symbol('m.c.oMet.me') == 'VAR' then
return m.c.oMet.me
end
call objMetClaM obj, me
return 'M="'m'";'ggCode
endProcedure objMet
/*--- return the stem of fieldnames of object m ---------------------*/
oFlds: procedure expose m.
parse arg m
return objClass(m)'.FLDS'
endProcedure oFlds
/*--- mutate object m to the class named name -----------------------*/
oMutate: procedure expose m.
parse arg m, name
m.class.o2c.m = class4Name(name)
return m
endProcedure oMutate
/*--- return object obj cast'd to class named cl --------------------*/
oCast: procedure expose m.
parse arg obj, cl
if abbrev(obj, 'CLASS.CAST.') then
obj = substr(obj, 1 + pos(':', obj, 12))
return 'CLASS.CAST.'class4Name(cl)':'obj
endProcedure oCast
/*--- copy object m of class c to t ---------------------------------*/
oClaCopy: procedure expose m.
parse arg ggCla, m, t
ggCode = ggCla'.OMET.oCopy'
interpret m.ggCode
if ggCla == m.class.classV then
drop m.class.o2c.t
else
m.class.o2c.t = ggCla
return t
endProcedure oClaCopy
/*--- copy object m to t --------------------------------------------*/
oCopy: procedure expose m.
parse arg m, t
return oClaCopy(objClass(m, m.class.classV), m, t)
endProcedure oCopy
/*--- copy object to a newly created object -------------------------*/
oCopyNew: procedure expose m.
parse arg m
if symbol('m.o.o2c.m') == 'VAR' then
return oCopy(m, oBasicNew(m.o.o2c.m))
return oCopy(m, oBasicNew(m.class.classV))
endProcedure oCopyNew
/*--- return a new instance of a subclass of Run
with code code in method oRun -------------------------------*/
oRunner: procedure expose m.
parse arg code
t = classNew('n ORun* u', 'm oRun' code)
return oNew(m.t.name)
endProcedure oRunner
/*--- run method oRun of object m -----------------------------------*/
oRun: procedure expose m.
parse arg m, arg, arg2, arg3
interpret objMet(m, 'oRun')
return
endProcedure oRun
/* copy o end *******************************************************/
/* copy class begin *****************************************************
a class has fields and methods,
the class module handles only the metadata,
object handling (instanciation, methodcalls etc.)
is done in O, which, hower, extends the class definitions
meta
c choice name class
f field name class
m method name met
n name name class
r reference class
s stem class
u union stem
v value
class expression (ce) allow the following syntax
ce = name | 'v' | 'r' ce? | ('n' | 'f' | 'c') name ce
| 's' ce | 'm' name code | 'u' (ce (',' ce)*)?
'm' and 'u' extend to the end of whole ce
***********************************************************************/
classIni: procedure expose m.
if m.class.ini == 1 then
return
m.class.ini = 1
call mapIni
/* to notify other modules (e.g. O) on every new named class */
call mRegisterSubject 'Class',
, 'call classAddedListener subject, listener'
m.class.0 = 0
m.class.tmp.0 = 0
call mapReset 'CLASS.N2C' /* name to class */
/* meta meta data: description of the class datatypes */
m.class.classV = classNew('v')
m.class.classR = classNew('r')
m.class.class = classNew('n class u', '\')
call classNew 'class',
, 'c v v' ,
, 'c r f CLASS r class' ,
, 'c s f CLASS r class' ,
, 'c u s r class',
, 'c f' classNew('u f NAME v, f CLASS r class'),
, 'c n' classNew('u f NAME v, f CLASS r class'),
, 'c c' classNew('u f NAME v, f CLASS r class'),
, 'c m' classNew('u f NAME v, f MET v')
return
endProcedure classIni
/*--- to notify a new listener about already defined classes --------*/
classAddedListener: procedure expose m.
parse arg subject, listener
do y = 1 to m.class.0
if m.class.y == 'n' then
call mNotify1 'Class', listener, 'CLASS.'y
end
return
endProcedure classAddedListener
/*--- return the name of a class if it exists otherwise the class ---*/
className: procedure expose m.
parse arg cl
if m.cl = 'n' then
return m.cl.name
else
return cl
endProcedure class4Name
/*--- return class of given name or class ---------------------------*/
class4Name: procedure expose m.
parse arg nm
if symbol('m.class.n2c.nm') == 'VAR' then
return m.class.n2c.nm
if arg() > 1 then
return arg(2)
call err 'no class' nm
endProcedure class4Name
/*--- get or create a class from the given class expression
arg(2) may contain options
'\' do not search for existing class
'+' do not finish class
type (1 char) type of following args
the remaining args are type expressions and will
be added to the first union -----------------------------*/
classNew: procedure expose m.
parse arg clEx
if arg() <= 1 then
if mapHasKey(class.n2c, clEx) then
return mapGet(class.n2c, clEx)
oldTmp = m.class.tmp.0
ox = verify(arg(2), '\+')
if ox < 1 then
ox = length(arg(2)) + 1
opts = left(arg(2), ox-1)
pr = substr(arg(2), ox, (length(arg(2)) = ox) * 2)
t = classNewTmp(clEx)
if arg() > 1 then do
u = t
do while m.u \== 'u'
if m.u.class == '' then
call err 'no union found' clEx
u = m.u.class
end
do ax = 2 + (opts \== '' | pr \== '') to arg()
call mAdd u, classNew(pr || arg(ax))
end
end
p = classPermanent(t, pos('\', opts) < 1)
if arg() <= 1 then
call mapAdd class.n2c, clEx, p
if p == t & pos('+', opts) < 1 then
call mNotify 'Class', p
m.class.tmp.0 = oldTmp
return p
endProcedure classNew
/*--- create a temporary class
with type ty, name nm and class expression ce ---------------*/
classNewTmp: procedure expose m.
parse arg ty nm ce
if length(ty) > 1 then do
if nm \== '' then
call err 'class' ty 'should stand alone:' ty nm ce
return class4Name(ty)
end
t = mAdd(class.tmp, ty)
m.t.name = ''
m.t.class = ''
m.t.met = ''
m.t.0 = ''
if pos(ty, 'v') > 0 then do
if nm \== '' then
call err 'basicClass' ty 'end of Exp expected:' ty nm ce
end
else if ty = 'u' then do
fx = 0
m.t.0 = 0
ce = nm ce
ux = 0
do until fx = 0
tx = pos(',', ce, fx+1)
if tx > fx then
sub = strip(substr(ce, fx+1, tx-fx-1))
else
sub = strip(substr(ce, fx+1))
if sub \== '' then do
ux = ux + 1
m.t.ux = classNewTmp(sub)
end
fx = tx
end
m.t.0 = ux
end
else if nm == '' & ty \== 'r' then do
call err 'basicClass' ty 'name or class Exp expected:' ty nm ce
end
else do
if pos(ty, 'sr') > 0 then do
if nm \== '' then
m.t.class = classNewTmp(nm ce)
end
else do
if pos(ty, 'cfmn') < 1 then
call err 'unsupported basicClass' ty 'in' ty nm ce
m.t.name = nm
if ty = 'm' then
m.t.met = ce
else if ce = '' then
call err 'basicClass' ty 'class Exp expected:' ty nm ce
else
m.t.class = classNewTmp(ce)
end
end
return t
endProcedure classNewTmp
/*--- return the permanent class for the given temporary class
an existing one if possible otherwise a newly created -------*/
classPermanent: procedure expose m.
parse arg t, srch
if \ abbrev(t, 'CLASS.TMP.') then
return t
if m.t.class \== '' then
m.t.class = classPermanent(m.t.class, srch)
if m.t.0 \== '' then do
do tx=1 to m.t.0
m.t.tx = classPermanent(m.t.tx, srch)
end
end
/* search equal permanent class */
do vx=1 to m.class.0 * srch
p = class'.'vx
if m.p.search then
if classEqual(t, p, 1) then
return p
end
p = mAdd(class, m.t)
m.p.name = m.t.name
m.p.class = m.t.class
m.p.met = m.t.met
m.p.search = srch
if m.t.0 > 0 then
call mAddSt mCut(p, 0), t
else
m.p.0 = m.t.0
if mapHasKey(class.n2c, p) then
call err 'class' p 'already defined as className'
else
call mapAdd class.n2c, p, p
if m.p = 'n' then do
if right(m.p.name, 1) == '*' then
m.p.name = left(m.p.name, length(m.p.name)-1) ,
|| substr(p, length('class.x'))
if mapHasKey(class.n2c, m.p.name) then
call err 'class' m.p.name 'already defined'
else
call mapAdd class.n2c, m.p.name, p
if srch then
call mNotify 'Class', p
end
return p
endProcedure classPermanent
/*--- return true iff the two classes are equal
(up to the name pattern if lPat == 1) -----------------------*/
classEqual: procedure expose m.
parse arg l, r, lPat
if m.l \== m.r | m.l.class \== m.r.class | m.l.0 \= m.r.0,
| m.l.met \== m.r.met then
return 0
if m.l.name \== m.r.name then
if lPat \== 1 | right(m.l.name, 1) \== '*' ,
| \ abbrev(m.r.name,
, left(m.l.name, length(m.l.name)-1)) then
return 0
if m.l.0 == '' then
return 1
do sx=1 to m.l.0
if m.l.sx \== m.r.sx then
return 0
end
return 1
endProcedure classEqual
/*--- recursively ouput (with out:) the object a with class t -------*/
classOut: procedure expose m.
parse arg t, a, pr, p1
return classOutDone(t, a, pr, p1)
return x
endProcedure classOut
/*--- ouput object a with class t and stopper done ------------------*/
classOutDone: procedure expose m. done.
parse arg t, a, pr, p1
if p1 == '' then
p1 = pr
if right(p1, 1) \== ' ' then
p1 = p1' '
if done.ini \== 1 then do
done.ini = 1
t = class4Name(t, t)
p1 = p1'@'a' '
end
if done.t.a == 1 then
return out(p1'done :'className(t) '@'a)
done.t.a = 1
if t = '' then do
t = objClass(a, '')
if t = '' then
return out(p1'obj has no class @'m.a)
else
return classOutDone(t, a, pr, p1'isA')
end
if m.t == 'v' then
return out(p1'=' m.a)
if m.t == 'n' then
return classOutDone(m.t.class, a, pr, p1':'m.t.name)
if m.t == 'f' then
return classOutDone(m.t.class, a'.'m.t.name, pr, p1'.'m.t.name)
if m.t == 'r' then do
if m.a == '' then
call out p1'refTo :'className(m.t.class) '@null@'
else
return classOutDone(m.t.class, m.a, pr,
, p1'refTo @'m.a)
end
if m.t = 'u' then do
t1 = m.t.1
vv = m.t.0 > 0 & m.t1 == 'v'
call out p1'union' || copies(' =' m.a, vv)
do ux=1+vv to m.t.0
call classOutDone m.t.ux, a, pr' '
end
return 0
end
if m.t = 's' then do
call out p1'stem' m.a.0
do ux=1 to m.a.0
call classOutDone m.t.class, a'.'ux, pr' ', pr' .'ux
end
return 0
end
if m.t = 'c' then do
if m.t.name = m.a then
call classOutDone m.t.class, a, pr, p1'choice' m.a
return 0
end
if m.t = 'm' then
return 0
return err('bad class type' m.t)
endProcedure classOutDone
/* copy class end ****************************************************/
/* copy mapExp begin **************************************************/
mapVia: procedure expose m.
parse arg a, ky
sx = pos('*', ky)
if sx < 1 then
return mapGet(a, ky)
via = mapGet(a, left(ky, sx-1))
do while sx <= length(ky)
fx = sx+1
sx = pos('*', ky, fx)
if sx < 1 then
sx = length(ky) + 1
if sx = fx then do
if symbol('m.via') \== 'VAR' then
call err 'missing m.'via 'at' sx 'in mapVia('a',' ky')'
via = m.via
end
else do
f = substr(ky, fx, sx - fx)
if symbol('m.via.f') \== 'VAR' then
call err 'missing m.'via'.'f ,
'at' sx 'in mapVia('a',' ky')'
via = m.via.f
end
end
return via
endProcedure mapVia
mapExpAt: procedure expose m.
parse arg a, src, sx
m.map.ExpAt = 0
cx = pos('$', src, sx)
if cx < 1 then
return substr(src, sx)
res = substr(src, sx, cx-sx)
do forever
if substr(src, cx+1, 1) = '{' then do
ex = pos('}', src, cx+2)
if ex < 1 then
call err 'missing } after' substr(src, cx) 'in' src
res = res || mapVia(a, strip(substr(src, cx+2, ex-cx-2)))
ex = ex + 1
end
else do
ex = verify(src, m.mAlfDot, 'n', cx+1)
if ex < 1 then
return res || mapVia(a, substr(src, cx+1))
if ex = cx+1 then do
m.map.ExpAt = cx
return res
end
res = res || mapVia(a, substr(src, cx+1, ex-cx-1))
end
cx = pos('$', src, ex)
if cx < 1 then
return res || substr(src, ex)
res = res || substr(src, ex, cx-ex)
end
endProcedure mapExpAt
mapExp: procedure expose m.
parse arg a, src
res = mapExpAt(a, src, 1)
if m.map.ExpAt \== 0 then
call err 'mapExp stopped at' substr(src, map.ExpAt) 'in' src
return res
endProcedure mapExp
mapExpAllAt: procedure expose m.
parse arg a, dst, src, sx, cx
do while sx <= m.src.0
li = mapExpAt(a, m.src.sx, cx)
dx = m.map.ExpAt
if (cx=1 & dx = 0) | li \= '' then
call mAdd dst, li
if dx = 0 then do
cx = 1
sx = sx+1
end
else do
return sx dx
end
end
return ''
endProcedure mapExpAllAt
mapExpAll: procedure expose m.
parse arg a, dst, src
sto = mapExpAllAt(a, dst, src, 1, 1)
if sto == '' then
return
lx = word(sto, 1)
call err 'mapExpAll stopped at' sto':' m.src.lx
endProcedure mapExpAll
/* copy mapExp end ****************************************************/
/* copy map begin ******************************************************
a map stores values at keys
it may also maintain a list of keys
the basic ideas are similar to the java Interface java.util.Map
contrary to stems we also handle keys longer then 250 bytes
***********************************************************************/
/*--- initialize the module ------------------------------------------*/
mapIni: procedure expose m.
if m.map.ini = 1 then
return
m.map.ini = 1
call mIni
m.map.0 = 0
m.map.inlineSearch = 1
return
endProcedure mapIni
mapInline: procedure expose m.
parse arg pName
if mapHasKey(map.inlineName, pName) then
return mapGet(map.inlineName, pName)
if m.map.inlineSearch == 1 then
call mapReset map.inlineName, map.inline
inData = 0
name = ''
do lx=m.map.inlineSearch to sourceline()
if inData then do
if abbrev(sourceline(lx), stop) then do
inData = 0
if pName = name then
leave
end
else do
call mAdd act, strip(sourceline(lx), 't')
end
end
else if abbrev(sourceline(lx), '/*<<') then do
parse value sourceline(lx) with '/*<<' name '<<' stop
name = strip(name)
stop = strip(stop)
if stop == '' then
stop = name
if words(stop) <> 1 | words(name) <> 1 then
call err 'bad inline data' strip(sourceline(lx))
if mapHasKey(map.inline, name) then
call err 'duplicate inline data name' name ,
'line' lx strip(sourceline(lx), 't')
act = mapAdd(map.inlineName, name,
, mCut('MAP.INLINE.' || (m.map.inline.0 + 1), 0))
inData = 1
end
end
if inData then
call err 'inline Data' name 'at' m.map.inlineSearch,
'has no end before eof'
m.map.inlineSearch = lx + 1
if name = pName then
return act
if arg() > 1 then
return arg(2)
call err 'no inline data named' pName
endProcedure mapInline
/*--- create a new map ----------------------------------------------*/
mapNew: procedure expose m.
parse arg opt
return mapReset('MAP.'mInc('MAP.0') , opt)
endProcedure mapNew
/*--- make an empty map, if opt <> '' maintain stem of keys
('K' in map.keys, '=' in a else in opt) --------------*/
mapReset: procedure expose m.
parse arg a, opt
if symbol('m.map.keys.a') == 'VAR' then
call mapClear a
if opt = '=' then
st = a
else if translate(opt) = 'K' then
st = 'MAP.KEYS.'a
else
st = opt
m.map.keys.a = st
if st \== '' then
m.st.0 = 0
return a
endProcedure
/*--- add a new key value pair to the map ----------------------------*/
mapAdd: procedure expose m.
parse arg a, ky, val
vv = mapValAdr(a, ky, 'a')
m.vv = val
return val
endProcedure mapAdd
/*--- change the value at a key or add key value ---------------------*/
mapPut: procedure expose m.
parse arg a, ky, val
vv = mapValAdr(a, ky, 'p')
m.vv = val
return val
endProcedure mapPut
/*--- return 1 if key ky exists in map a, 0 otherwise ----------------*/
mapHasKey: procedure expose m.
parse arg a, ky
return mapValAdr(a, ky) \== ''
endProcedure mapHasKey
/*--- return the value of key ky in map a if it exists,
else if called with a third argument return third argument
else issue an error ----------------------------------------*/
mapGet: procedure expose m.
parse arg a, ky
vv = mapValAdr(a, ky)
if vv \== '' then
return m.vv
else if arg() > 2 then
return arg(3)
else
call err 'missing key in mapGet('a',' ky')'
endProcedure mapGet
/*--- return a stem of all keys --------------------------------------*/
mapKeys: procedure expose m.
parse arg a
if m.map.keys.a == '' then
call err 'mapKeys('a') with no keys'
return m.map.keys.a
endProcedure mapKeys
/*--- remove a key from the map, do nothing if it is missing ---------*/
mapRemove: procedure expose m.
parse arg a, ky
vv = mapValAdr(a, ky)
if vv == '' then
return ''
if m.map.keys.a \== '' then do
trace ?R /* not tested yet ???wkTest */
k = m.map.keys.a
mx = m.k.0
do i=1 to mx
if m.k.i == ky then do
m.k.i = m.k.mx
m.k.0 = mx - 1
return
end
end
end
val = m.a.vv
drop m.a.ky
return val
endProcedure mapRemove
/*--- remove all entries ---------------------------------------------*/
mapClear: procedure expose m.
parse arg a
st = mapKeys(a)
do kx=1 to m.st.0
k = m.st.kx
if length(k) > 200 then do
k = left(k, 201)
if symbol('m.a.k') == 'VAR' then/* ist noch hier */
call mapClear m.a.k
end
drop m.a.k m.st.kx
end
m.st.0 = 0
return a
endProcedure mapClear
/*--- return the value pointer for a key, '' if non existing
with fun = 'a' add a key, with 'p' put a key ------------*/
mapValAdr: procedure expose m.
parse arg pA, pKy, fun
a = pA
ky = pKy
do forever
if length(ky) <= 200 then do
if symbol('m.a.ky') \== 'VAR' then
leave
if fun == 'a' then
call err 'duplicate key' pKy 'in map' pA
return a'.'ky
end
k1 = left(ky, 201)
if symbol('m.a.k1') \== 'VAR' then
leave
a = m.a.k1
ky = substr(ky, 202)
end
if fun == '' then
return ''
opt = left('K', m.map.keys.pA \== '')
if opt == 'K' then
call mAdd m.map.Keys.pA, pKy
do while length(ky) > 200
k1 = left(ky, 201)
n = mapNew(opt)
m.a.k1 = n
if a \== pA & opt == 'K' then
call mAdd m.map.keys.a, ky
a = n
ky = substr(ky, 202)
end
return a'.'ky
endProcedure mapValAdr
/* copy map end *******************************************************/
/* copy m begin ********************************************************
we use variables as follows
m. stem m: all global data and object data that must survive
a procedure call (m for memory in Memoria of B5000)
m.<mbr>.** to avoid conflicts: every rexx Module (copy) should
only allocate addresses m.<mbr>.** with <mbr> the name of
the rexx module
we pass parameters around (e.g. a=address, m=memory, st=stem)
and the called function may use m.a or m.a.subField etc.
gg*: local variable in subroutines without procedure
everything else: temporary data within procedure
every subroutine is declared as procedure expose m.
(also if no m. variable is used, because e.g. of error handling)
the few subroutines that cannot use procedure, should use only
variables starting with gg
***********************************************************************/
/*--- increase m.a and return it (fail if undefined) -----------------*/
mInc: procedure expose m.
parse arg a
m.a = m.a + 1
return m.a
endProcedure mInc
/*--- cut stem a to length len ---------------------------------------*/
mCut: procedure expose m.
parse arg a, len
m.a.0 = len
return a
endProcedure mCut
/*--- add one or several arguments to stem m.a -----------------------*/
mAdd: procedure expose m.
parse arg a
ix = m.a.0
do ax = 2 to arg()
ix = ix + 1
m.a.ix = arg(ax)
end
m.a.0 = ix
return a'.'ix
endProcedure mAdd
/*--- add to m.dst.* a (sub)sequence of m.src.* ----------------------*/
mAddSt: procedure expose m.
parse arg dst, src
dx = m.dst.0
do sx = 1 to m.src.0
dx = dx + 1
m.dst.dx = m.src.sx
end
m.dst.0 = dx
return
endProcedure mAddSt
/*--- move a part of a stem ------------------------------------------*/
mMove: procedure expose m.
parse arg m, sx, dx
if dx < sx then do
y = dx
do x=sx to m.m.0
m.m.y = m.m.x
y = y + 1
end
end
else if dx > sx then do
y = m.m.0 + dx - sx
do x=m.m.0 by -1 to sx
m.m.y = m.m.x
y = y - 1
end
end
m.m.0 = m.m.0 + dx - sx
return
endProcedure mMove
/*--- strip all elements of a stem -----------------------------------*/
mStrip: procedure expose m.
parse arg st, opt
if opt == '' then
opt = 'b'
do x=1 to m.st.0
m.st.x = strip(m.st.x, opt)
end
return st
endProcedure mStrip
/*--- cat all elements of a stem together ----------------------------*/
mCat: procedure expose m.
parse arg st, mid
if m.st.0 < 1 then
return ''
res = m.st.1
do x=2 to m.st.0
res = res || mid || m.st.x
end
return res
endProcedure mCat
/*--- notify all listeners of subject subj with argument arg --------*/
mNotify: procedure expose m.
parse arg subj, arg
if symbol('m.m.subLis.subj') \== 'VAR' then
call err 'subject' subj 'not registered'
do lx=1 to m.m.subLis.subj.0
call mNotify1 subj, lx, arg
end
return
endProcedure mNotify
/*--- notify the listener listener of subject subj with arg ---------*/
mNotify1: procedure expose m.
parse arg subject, listener, arg
interpret m.m.subLis.subject.listener
return
endProcedure mNotify1
/*--- notify subject subject about a newly registered listener
or a new subject about previously registered listener -------*/
mNotifySubject: procedure expose m.
parse arg subject, listener
interpret m.m.subLis.subject
return
endProcedure mNotifySubject
/*--- register a new subject with the code for mNotifySubject -------*/
mRegisterSubject: procedure expose m.
parse arg subj, addListener
if symbol('m.m.subLis.subj') == 'VAR' then
call err 'subject' subj 'already registered'
m.m.subLis.subj = addListener
if symbol('m.m.subLis.subj.0') \== 'VAR' then do
m.m.subLis.subj.0 = 0
end
else do lx=1 to m.m.subLis.subj.0
call mNotifySubject subj, lx
end
return
endProcedure registerSubject
/*--- register a listener to subject subj with the code for mNotify -*/
mRegister: procedure expose m.
parse arg subj, notify
if symbol('m.m.subLis.subj.0') \== 'VAR' then
m.m.subLis.subj.0 = 0
call mAdd 'M.SUBLIS.'subj, notify
if symbol('m.m.subLis.subj') == 'VAR' then
call mNotifySubject subj, m.m.subLis.subj.0
return
endProcedure mRegister
mIni: procedure expose m.
if m.m.ini = 1 then
return
m.m.ini = 1
m.mAlfLC = 'abcdefghijklmnopqrstuvwxyz'
m.mAlfUC = translate(m.mAlfLC)
m.mAlfa = m.mAlfLC || m.mAlfUC
m.mAlfNum = m.mAlfa || '0123456789'
m.mAlfDot = m.mAlfNum || '.'
return
endProcedure mIni
/* copy m end *********************************************************/
/* copy stringUt begin ***********************************************/
/*--- return the count of occurrences of needle in heyStack ----------*/
posCount: procedure
parse arg needle, hayStack, start, fin
if start = '' then
start = 1
if fin = '' then
fin = length(hayStack) + 1 - length(needle)
do cnt = 0 by 1
start = pos(needle, haystack, start)
if start < 1 | start > fin then
return cnt
start = start + length(needle)
end
endProcedure posCount
repAll: procedure expose m.
parse arg src, w, new
res = ''
cx = 1
do forever
nx = pos(w, src, cx)
if nx < 1 then
return res || substr(src, cx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAll
repAllWords: procedure expose m.
parse arg src, w, new
res = ''
wx = 0
cx = 1
do forever
wx = wordPos(w, src, wx+1)
if wx < 1 then
return res || substr(src, cx)
nx = wordindex(src, wx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAllWords
/* copy stringUt end ***********************************************/
/* copy err begin ******************************************************
messages, errorhandling,help
***********************************************************************/
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
parse arg m.err.opt, ha
if pos('I', translate(m.err.opt)) > 0 then
call adrIsp 'control errors return'
if ha == '' then
drop m.err.handler
else
m.err.handler = ha
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
drop err handler opt
if ggOpt == '' & symbol('m.err.handler') == 'VAR' then
interpret value('m.err.handler')
call outDest
call errSay ggTxt, 'e'
if ggOpt == '' & symbol('m.err.opt') == 'VAR' then
ggOpt = value('m.err.opt')
ggOpt = translate(ggOpt)
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 then do
call errSay 'divide by zero to show stackHistory', 'e'
x = 1 / 0
end
call errSay 'exit(12)', 'e'
exit errSetRc(12)
endSubroutine err
/*--- assert that the passed rexx expression evaluates to true -------*/
assert:
interpret 'assertRes =' arg(1)
if \ assertRes then
call err 'assert failed' arg(1)':' arg(2)
return
endProcedure assert
/*--- output an errorMessage msg with pref pref
split message in lines at '/n' ---------------------------*/
errSay: procedure expose m.
parse arg msg, pref
parse source . . ggS3 . /* current rexx */
if pref == 'e' then
msg = 'fatal error in' ggS3':' msg
else if pref == 'w' then
msg = 'warning in' ggS3':' msg
else if pref \== '' then
msg = pref':' msg
return outLn(msg)
endProcedure errSay
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg, op
call errSay msg, 'e'
call help
call err msg, op
endProcedure errHelp
/*--- return the Operating System we are running on: TSO or LINUX ---*/
errOS: procedure expose m.
parse source os .
return os
endProcedure errOS
/*--- set rc for ispf: -------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared varible 3IspfRc
back as return code
----------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- output a trace message if m.tr is set -----------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
call out 'debug' msg
return
endProcedure debug
/*--- return current time and cpu usage ------------------------------*/
timing: procedure expose m.
return time() time('E') sysvar('syscpu') /* sysvar('syssrv') */
/*--- display the first comment block of the source as help -----------*/
help: procedure expose m.
parse source . . s3 .
call out right(' help for rexx' s3, 79, '*')
do lx=1 by 1
if pos('/*', sourceLine(lx)) > 0 then
leave
else if lx > 10 then do
call out '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
call out li
end
call out right(' end help for rexx' s3, 79, '*')
return 4
endProcedure help
/*--- output a message to the current destination -------------------*/
out: procedure expose m.
parse arg msg
if symbol('m.err.out') \== 'VAR' then
call outDest
interpret m.err.out
return 0
endProcedure out
/*--- output all lines (separated by '\n') of all args --------------*/
outLn: procedure expose m.
do ax=1 to max(1, arg())
msg = arg(ax)
sx = 0
bx = -1
do lx=1 until bx >= length(msg)
ex = pos('\n', msg, bx+2)
if ex < 1 then
ex = length(msg)+1
call out substr(msg, bx+2, ex-bx-2)
bx = ex
end
end
return 0
endProcedure outLn
/*--- set and return some frequent destinations for out -------------*/
outDest: procedure expose m.
parse arg ty, a
if ty == '' | symbol('m.err.out') \== 'VAR' then
m.err.out = 'say msg'
if ty == 's' then
m.err.out = 'st='quote(a)';sx=m.st.0+1;m.st.0=sx;m.st.sx=msg'
else if ty == 'i' then
m.err.out = a
else if \ abbrev('=', ty) then
call err 'bad type in outDes('ty',' a')'
return m.err.out
endProcedure outDest
/*--- 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
/* copy err end *****************************************************/
}¢--- A540769.WK.REXX(REBIEXT) cre=2014-10-27 mod=2014-10-27-14.32.49 A540769 ---
$#: 00010000
* 00010102
* extract rebind statement from ana 00011002
* and put each on one single line (for compare) 00012002
* 00013002
i = DSN.DBXDBOF.ANA(QX010011) 00020002
$#@ 00040000
$>. fEdit('A540769.tmp.text(o11) ::f') 00041002
call readDsn $i, i. 00050000
$do i=1 to i.0 $@¢ 00060000
if space(i.i, 1) \== 'REBIND PACKAGE( -' then 00070000
iterate 00080000
i = i + 1 00090000
p = strip(i.i) 00101000
if right(p, 1) \== '-' then 00110000
call err 'bad pkg' i i.i 00120000
$$- 'REBIND PACKAGE('left(p, length(p)-1)')' 00130000
$! 00150000
$#out 20141027 13:55:43 00150102
$#out 20141027 13:22:50 00150201
}¢--- A540769.WK.REXX(RECLEN) cre=2013-02-13 mod=2013-02-19-10.55.54 A540769 ---
parse arg dsn
if dsn = '' then
dsn = DBTF.VV25A1T.VDPS247.P00000.D130213.REC
call dsnAlloc 'dd(eins)' dsn
call readDDBegin eins
tC = 0
tL = 0
tMi = 9e9
tMa = -1
say timing()
do bx=1 to 1000 while readDD(eins, ii., 1000)
do x=1 to ii.0
tc = tc + 1
tL = tL + length(ii.x)
tMi = min(tMi, length(ii.x))
tMa = max(tMa, length(ii.x))
end
end
say 'count' tC 'totL' tL 'recLen' tMi'-'tMa (tL/tC)
say timing()
call readDDEnd eins
call adrTso 'free dd(eins)'
exit
/* copy adrTso begin *************************************************/
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet ---*/
adrTso:
parse arg ggTsoCmd, ggRet
address tso ggTsoCmd
if rc == 0 then return 0
else if ggRet == '*' then return rc
else if wordPos(rc, ggRet) > 0 then return rc
else
call err 'adrTso rc' rc 'for' ggTsoCmd
return /* end adrTso */
/*--- format dsn from tso format to jcl format -----------------------*/
dsn2jcl: procedure expose m.
parse upper arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
cx = pos('~', dsn)
if cx < 1 & addPrefix == 1 then
return sp'.'dsn
do while cx \== 0
le = left(dsn, cx-1)
ri = substr(dsn, cx+1)
if right(le, 1) == '.' | left(ri, 1) == '.' then
dsn = le || sp || ri
else
dsn = le || left('.', le \== '') || sp ,
|| left('.', ri \== '') || ri
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
parse arg dsn, mbr
bx = pos('(', dsn)
if bx > 0 then
dsn = strip(left(dsn, bx-1))
if mbr <> '' then
dsn = dsn'('strip(mbr)')'
return dsn
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn
lx = pos('(', dsn)
rx = pos(')', dsn, lx+1)
if lx < 1 then
return ''
else if lx < rx then
return substr(dsn, lx+1, rx-lx-1)
else
return strip(substr(dsn,lx+1))
endProcedure dsnGetMbr
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: readDDBegin, readDD*, readDDEnd
write: writeBegin, writeDD*, writeEnd
readDD returns true if data read, false at eof
***********************************************************************/
/*--- prepare reading from a DD --------------------------------------*/
readDDBegin: procedure expose m.
parse upper arg ggDD
call errAddCleanup 'call readDDEnd' ggDD', "*"'
return /* end readDDBegin */
/*--- read from DD ggDD into ggSt, return false at eof ---------------*/
readDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskr' ggDD '(stem' ggSt')', 2
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- finish reading DD ggDD ----------------------------------------*/
readDDEnd: procedure expose m.
parse upper arg ggDD, ggRet
call errRmCleanup 'call readDDEnd' ggDD', "*"'
return adrTso('execio 0 diskr' ggDD '(finis)', ggRet)
endProcedure readDDEnd
/*--- prepare writing to DD ggDD -------------------------------------*/
writeDDBegin: procedure expose m.
parse upper arg ggDD
/* ensure file is erased, if no records are written */
call adrTso 'execio' 0 'diskw' ggDD '(open)'
call errAddCleanup 'call writeDDEnd' ggDD', "*"'
return /* end writeDDBegin */
/*--- write to gg ggDD from stem ggSt, ggCnt records -----------------*/
writeDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt == '' then
ggCnt = value(ggst'0')
call adrTso 'execio' ggCnt 'diskw' ggDD '(stem' ggSt')'
return
endSubroutine writeDD
/*--- end writing to dd ggDD (close) --------------------------------*/
writeDDEnd: procedure expose m.
parse upper arg ggDD, ggRet
call errRmCleanup 'call writeDDEnd' ggDD', "*"'
return adrTso('execio 0 diskw' ggDD '(finis)', ggRet)
endProcedure writeDDEnd
/*--- readNx: read next line, using buffer ---------------------------*/
/*--- begin: allocate dsnSpec and ini ------------------------ -------*/
readNxBegin: procedure expose m.
parse arg m, m.m.dsn, m.m.dd, m.m.Cnt
if m.m.dd = '' then
m.m.dd = 'DDNX'
if m.m.cnt = '' then
m.m.cnt = 1000
m.m.cx = m.m.cnt + 999
m.m.buf0x = 0
m.m.0 = 0
m.m.free = subword(dsnAlloc('dd('m.m.dd')' m.m.dsn), 2)
call readDDBegin m.m.dd
return m
endProcedure readDDNxBegin
/*--- return the stem of the next line, or '' at end -----------------*/
readNx: procedure expose m.
parse arg m
m.m.cx = m.m.cx + 1
if m.m.cx <= m.m.0 then
return m'.'m.m.cx
m.m.buf0x = m.m.buf0x + m.m.0
if \ readDD(m.m.dd, 'M.'m'.', m.m.cnt)then
return ''
m.m.cx = 1
return m'.1'
endProcedure readDDNx
/*--- return the stem of the curr line, '' at end --------------------*/
readNxCur: procedure expose m.
parse arg m
if m.m.cx <= m.m.0 then
return m'.'m.m.cx
else
return ''
endProcedure readNxCur
/*--- return the position (line number) of reader
plus le characters of the current line (default 50) ------*/
readnxPos: procedure expose m.
parse arg m, le
li = m'.'m.m.cx
li = strip(m.li, 't')
if arg() < 2 then
le = 50
if le < 1 then
li = ''
else if length(li) <= le then
li = ':' li
else
li = ':' left(li, le-3)'...'
return 'line' (m.m.buf0x + m.m.cx)li
endProcedure readnxPos
/*--- close and deallocate ------------------------------------------*/
readNxEnd: procedure expose m.
parse arg m
call readDDEnd m.m.dd
interpret m.m.free
return
endProcedure readDDNxEnd
/*--- standardise a dsn spec
word1 dsName or -
word2 dd or -
word3 disp or -
word4 to first : attributes in tso format
after first : attributes for new allocation
----------------------------------------------------------------------*/
dsnSpec: procedure expose m.
parse upper arg spec
rr = '' /* put leading - in separate words */
do sx=1 while words(rr) < 3 & wx \= ''
wx = word(spec, sx)
do while abbrev(wx, '-') & words(rr) < 3
wx = substr(wx, 2)
rr = rr '-'
end
rr = rr wx
end
spec = rr subWord(spec, sx)
na = ''
dd = ''
di = ''
if left(spec, 1) = '&' then /* external spec is handled ok */
spec = strip(substr(spec, 2))
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, '.') | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
di = w
else if w = 'CATALOG' then
di = di w
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
na = strip(substr(w, 5, length(w)-5))
else if na == '' then
na = dsn2jcl(w)
else if dd == '' then
dd = w
else if di == '' then
di = w
else
leave
end
if na == '' then
na = '-'
else if abbrev(na, "'") then
na = substr(na, 2, length(na)-2)
if dd == '' then dd = '-'
if di == '' then di = '-'
re = subword(spec, wx)
if abbrev(re, '.') then
re = substr(re, 2)
return na dd di re
endProcedure dsnSpec
/*--- alloc a dsn with dsnAlloc
if the dsn is inuse wait and retry
until either the allocation is successfull
or the timeout occurs --------------------------------------*/
dsnAllocWait: procedure expose m.
parse upper arg spec, pDi, pDD, timeOut
x = max(1, arg() - 1)
do rt=0
m.adrTsoAl.1 = ''
m.adrTsoAl.2 = ''
m.adrTsoAl.3 = ''
call outtrap m.adrTsoAl.
res = dsnAlloc(spec, pDi, pDD, '*')
call outtrap off
if \ abbrev(res, ' ') then
return res
msg = m.adrTsoAl.1'\n'm.adrTsoAl.2'\n'm.adrTsoAl.3
if rt > timeOut & timeOut \== '' then
return err('timeout allocating' spec time() '\n'msg)
if pos('DATA SET IS ALLOCATED TO ANOTHER', msg) < 1 then
return err('allocating' spec'\n'msg)
say time() 'sleep and retry alloc' spec
call sleep 1, 0
end
endProcedure dsnAllocWait
/*--- alloc a dsn or a dd
spec '-'<ddName>
datasetName? disposition? '.'? attributes? (':' newAtts)?
disp default disposition
dd default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc -----*/
dsnAlloc: procedure expose m.
parse upper arg spec, pDi, pDD, retRc
parse value dsnSpec(spec) with na dd di rest
if na = '-' then
m.dsnAlloc.dsn = ''
else
m.dsnAlloc.dsn = na
if na == '-' & dd \== '-' & di == '-' & rest = '' then
return dd
if dd == '-' & pDD \== '' then
dd = pDD
if dd == '-' then do
if symbol('m.adrTso.ddNum') = 'VAR' then
dd = m.adrTso.ddNum + 1
else
dd = 1
m.adrTso.ddNum = dd
dd = 'DD' || dd
end
if di = '-' & pDi \== '' then
di = pDi
if di = '-' then
di = 'SHR'
else if pos('(', na) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if pos('/', na) > 0 then
return csmAlloc(na dd di rest, retRc)
else
return tsoAlloc(na dd di rest, retRc)
endProcedure dsnAlloc
tsoAlloc: procedure expose m.
parse arg na dd disp rest ':' nn, retRc
c = 'alloc dd('dd')' disp
if na \== '-' then
c = c "DSN('"na"')"
else if disp = 'NEW' and nn \== '' then
c = c dsnCreateAtts(,nn)
call outtrap m.adrTsoAl.
alRc = adrTso(c rest, '*')
call outtrap off
if alRc = 0 then do
call errAddCleanup 'call tsoFree' dd', "*"'
return dd 'call tsoFree' dd';'
end
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& sysDsn("'"m.dsnAlloc.dsn"'") == 'DATASET NOT FOUND' then do
say 'tsoAlloc creating' c rest ':'nn
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na dd disp rest, retRc)
end
do ax=1 to m.adrTsoAl.0
say m.adrTsoal.ax
end
if retRc = '*' | wordPos(alRc, retRc) > 0 then
return ' ' alRc
call err 'tsoAlloc rc' alRc 'for' c rest
endProcedure tsoAlloc
tsoAtts: procedure expose m.
parse arg dsn
rc = listDsi("'"dsn"' SMSINFO")
if rc = 0 then
mv = ''
else if rc = 4 & sysReason = 19 then do
mv = 'UNITCNT(30)'
say 'multi volume' mv
end
else if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
al = 'CAT'
al = ''
if right(sysDsSms, 7) == 'LIBRARY' ,
| abbrev(sysDsSms, 'PDS') then
al = al 'DSNTYPE(LIBRARY)'
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
al = al "DSORG("sysDSorg") MGMTCLAS("sysMgmtClass")",
"DATACLAS("sysDataClass")" ,
"RECFM("translate('1 2 3', ' 'sysREcFM, ' 123')")",
"LRECL("SYSLRECL")",
"blksize("sysBLkSIZE")",
"SPACE("sysPrimary"," sysSeconds")" sysUnits mv
return al
endProcedure tsoAtts
tsoFree: procedure expose m.
parse arg dd, ggRet
call adrTso 'free dd('dd')', ggRet
call errRmCleanup 'call tsoFree' dd', "*"'
return
endProcedure tsoFree
dsnCreateAtts: procedure expose m.
parse arg dsn, atts, forCsm
forCsm = forCsm == 1
aU = ' 'translate(atts)
if abbrev(atts, ':') then do
parse var atts a1 atts
bl = 32760
rl = substr(a1, 3)
if abbrev(a1, ':F') then do
if rl = '' then
rl = 80
recfm='f b'
bl = bl - (bl // rl)
end
else do
if rl = '' then
rl = bl-4
recfm = substr(a1, 2, 1) 'b'
end
if forCsm then
atts = atts "recfm("space(recfm, 0)") lrecl("rl")",
"blkSize("bl")"
else
atts = atts "recfm("recfm") lrecl("rl") block("bl")"
end
if pos('(', dsn) > 0 & pos(' DSNTYPE(', aU) < 1 ,
& pos(' DSORG(', aU) < 1 then
atts = atts 'dsntype(library) dsorg(po)'
if pos(' MGMTCLAS(', aU) < 1 then
atts = atts 'mgmtclas(COM#A091)'
if pos(' SPACE(', aU) < 1 then
if forCsm then
atts = atts 'space(10, 1000) cylinder'
else
atts = atts 'space(10, 1000) cyl'
if dsn == '' then
return atts
return "dataset('"dsnSetMbr(dsn)"')" atts
endProcedure dsnCreateAtts
/*--- check if a dataset is archive ------------------------------------
returns 'ok' if dataset on disk
'not' if dataset is not catalogued
'arc' if dataset archived
listDsi errorMsg otherwise ------------------*/
dsnArc: procedure expose m.
parse upper arg dsn
lc = listDsi("'"strip(dsn)"' noRecall")
if lc = 0 then
return 'ok'
else if lc=4 & sysReason = 19 then /* multiple volumes */
return 'ok'
else if lc=16 & sysReason = 5 then
return 'notCat'
else if lc=16 & sysReason = 9 then
return 'arc'
else
return 'listDsi cc='lc', sysReason='sysReason ,
'm2='sysMsgLvl2', m1='sysMsgLvl1
endProcedure dsnArc
/*--- read the dataset specified in ggDsnSpec to stem ggSt -----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
interpret subword(ggAlloc, 2)
return
endSubroutine readDsn
/*--- write the dataset specified in ggDsnSpec from stem ggSt
write ggCnt records if not empty otherwise ggst0
if ggSay 1 then say ... records written to ... -------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'open finis)'
interpret subword(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
copyDSN: procedure expose m.
parse arg frSpec, toSpec, ggSay
frDD = dsnAlloc(frSpec, 'SHR', 'FRDD')
toDD = dsnAlloc(toSpec, 'OLD', 'TODD')
call readDDBegin word(frDD, 1)
call writeDDBegin word(toDD, 1)
cnt = 0
do while readDD(word(frDD, 1), r.)
call writeDD word(toDD, 1), r.
cnt = cnt + r.0
end
call readDDEnd word(frDD, 1)
call writeDDEnd word(toDD, 1)
interpret ';' subword(frDD, 2) '; ; ;' subword(toDD, 2)
if ggSay == 1 | m.debug == 1 then
say cnt 'records copied from' frSpec 'to' to toSpec
return
endSubroutine writeDsn
/* copy adrTso end ****************************************************/
/* copy err begin *** errorhandling, messages, help ****************/
errIni: procedure expose m.
if m.err.ini == 1 then
return
m.err.ini = 1
m.err.handler = ''
m.err.cleanup = ';'
m.err.opt = ''
return
endProcedure errIni
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err.opt, m.err.handler
if pos('I', translate(m.err.opt)) > 0 then
if errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
call adrIsp 'control errors return'
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
call errIni
drop err handler cleanup opt call return
if ggOpt == '' & m.err.handler \== '' then
interpret m.err.handler
call errSay ggTxt, 'e'
call errCleanup
if ggOpt == '' then
ggOpt = m.err.opt
ggOpt = translate(ggOpt)
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 then do
call errSay 'divide by zero to show stackHistory', 'e'
x = 1 / 0
end
call errSay 'exit(12)', 'e'
exit errSetRc(12)
endSubroutine err
/*--- return the Operating System we are running on: TSO or LINUX ---*/
errOS: procedure expose m.
parse source os .
return os
endProcedure errOS
/*--- set rc for ispf: -------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared variable zIspfRc
back as return code
----------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- error routine: user message cleanup exit -----------------------*/
errAddCleanup: procedure expose m.
parse arg code
call errIni
/* concatenate backwards, then it is executed also backwards */
m.err.cleanup = ';'code || m.err.cleanup
return
endProcedure errAddCleanup
errRmCleanup: procedure expose m.
parse arg code
call errIni
cx = pos(';'code';', m.err.cleanup)
if cx > 0 then
m.err.cleanup = left(m.err.cleanup, cx) ,
|| substr(m.err.cleanup, cx + length(code)+2)
return
endProcedure errRmCleanup
errCleanup: procedure expose m.
call errIni
errCleanup = m.err.cleanup
if errCleanup = ';' then
return
m.err.cleanup = ';'
say 'err cleanup begin' errCleanup
interpret errCleanup
say 'err cleanup end' errCleanup
return
endProcedure errCleanup
/*--- say an errorMessage msg with pref and linesplits --------------*/
errSay: procedure expose m.
parse arg msg, pref
return saySt(errMsg(msg, pref))
/*--- prefix an errormessage with pref,
split it into lines at \n to stem m.err -------------------*/
errMsg: procedure expose m.
parse arg msg, pref
parse source . . ggS3 . /* current rexx */
if pref == 'e' then
msg = 'fatal error in' ggS3':' msg
else if pref == 'w' then
msg = 'warning in' ggS3':' msg
else if pref \== '' then
msg = pref':' msg
return splitNl(err, msg) /* split lines at \n */
endProcedure errMsg
splitNL: procedure expose m.
parse arg st, msg
bx = 1
do lx=1 to 20
ex = pos('\n', msg, bx)
if ex < bx then
leave
m.st.lx = substr(msg, bx, ex-bx)
bx = ex+2
end
m.st.lx = substr(msg, bx)
m.st.0 = lx
return st
endProcedure splitNL
/*--- say (part of) the lines of a stem ----------------------------*/
saySt: procedure expose m.
parse arg st, fx, tx
do lx=word(fx 1, 1) to word(tx m.st.0, 1)
say m.st.lx
end
return st
endProcedure saySt
/*--- out (part of) the lines of a stem ----------------------------*/
outSt: procedure expose m.
parse arg st, fx, tx
do lx=word(fx 1, 1) to word(tx m.st.0, 1)
call out m.st.lx
end
return st
endProcedure outSt
/*--- say a trace message if m.trace is set --------------------------*/
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
say 'debug:' msg
return
endProcedure debug
/*--- output a trace if m.trace is set -------------------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
/*--- assert that the passed rexx expression evaluates to true -------*/
assert:
interpret 'assertRes =' arg(1)
if assertRes \==1 then
call err 'assert failed' arg(1) '==>' assertRes':' arg(2)
return
endProcedure assert
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg, op
call errSay msg, 'e'
call help
call err msg, op
endProcedure errHelp
/*--- display the first comment block of the source as help ----------*/
help: procedure expose m.
parse source . . s3 .
say right(' help for rexx' s3, 79, '*')
do ax=1 to arg()
say ' ' arg(ax)
end
do lx=1 by 1
if pos('/*', sourceLine(lx)) > 0 then
leave
else if lx > 10 then do
say 'initial commentblock not found for help'
return
end
end
do lx=lx+1 by 1
li = strip(sourceLine(lx), 't', ' ')
if pos('*/', li) > 0 then
leave
say li
end
say right(' end help for rexx' s3, 79, '*')
return 4
endProcedure help
/* copy err end *****************************************************/
/* copy ut begin *****************************************************/
/*--- if function warning all3 arguments get evaluated|
e.g if(x=0, 'infinity', 1/0) will fail| -----------*/
if: procedure expose m.
parse arg co, ifTrue, ifFalse
if co then
return ifTrue
else
return ifFalse
endProcedure if
/*--- embedded ASSignement:
assign the second argument to the variable with name in first arg
and return the value assigned ----------------------------------*/
ass:
call value arg(1), arg(2)
return arg(2)
/*--- embedded ASSignement only if NotNull:
assign the second argument to the variable with name in first arg
if the second arg is not null, return new value ---------------*/
assIf:
if arg(2) == '' then
return value(arg(1))
call value arg(1), arg(2)
return arg(2)
/*--- return first nonNull argument ---------------------------------*/
nn:
if arg(1) \== '' then
return arg(1)
if arg(2) \== '' then
return arg(2)
call err 'nn() both args empty'
/*--- embedded ASSignement return NotNull:
assign the second argument to the variable with name in first arg
and return 1 if value not null, 0 if null ----------------------*/
assNN:
call value arg(1), arg(2)
return arg(2) \== ''
/*--- return current time and cpu usage ------------------------------*/
timing: procedure expose m.
return return time() 'ela='time('E') 'cpu='sysvar('syscpu'),
'su='sysvar('syssrv')
timingTest: procedure expose m.
say 'begin' timing() sysvar('sysnode')
do 30000000
end
say 'end ' timing()
return
/*--- sleep several seconds ------------------------------------------*/
sleep: procedure expose m.
parse arg secs, sayIt
if sayit <> 0 then
say 'sleeping' secs 'secs' time()
CALL SYSCALLS 'ON'
ADDRESS SYSCALL "sleep" secs
CALL SYSCALLS 'OFF'
if sayit <> 0 then
say 'slept' secs 'secs' time()
return
endProcedure sleep
/*--- elongate inp with spaces up to given len -----------------------*/
elong: procedure expose m.
parse arg inp, len
if length(inp) >= len then
return inp
return left(inp, len)
endProcedure elong
/*--- quote string txt using quoteChar qu ("""" ==> ") ---------------*/
quote: procedure expose m.
parse arg txt, qu
if qu = '' then
qu = '"'
res = qu
ix = 1
do forever
qx = pos(qu, txt, ix)
if qx = 0 then
return res || substr(txt, ix) || qu
res = res || substr(txt, ix, qx-ix) || qu || qu
ix = qx + length(qu)
end
endProcedure quote
/*--- return the count of occurrences of needle in heyStack ----------*/
posCount: procedure expose m.
parse arg needle, hayStack, start, fin
if start = '' then
start = 1
if fin = '' then
fin = length(hayStack) + 1 - length(needle)
do cnt = 0 by 1
start = pos(needle, haystack, start)
if start < 1 | start > fin then
return cnt
start = start + length(needle)
end
endProcedure posCount
repAll: procedure expose m.
parse arg src, w, new
res = ''
cx = 1
do forever
nx = pos(w, src, cx)
if nx < 1 then
return res || substr(src, cx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAll
repAllWords: procedure expose m.
parse arg src, w, new
res = ''
wx = 0
cx = 1
do forever
wx = wordPos(w, src, wx+1)
if wx < 1 then
return res || substr(src, cx)
nx = wordindex(src, wx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAllWords
/* copy ut end ********************************************************/
}¢--- A540769.WK.REXX(REOCHECK) cre=2010-09-27 mod=2016-06-19-12.31.36 A540769 ---
/* REXX **************************************************************
synopsis: reoCheck db fun
db = db2 subsystem
type = TS oder IX
function: db2 real time statistics für reorg anwenden:
1. preview der listdefs einlesen
2. listdefs einlesen
3. rts abfragen
4. neue listdef erstellen
5. *run* Tabellen mit History Infos fuellen
Tabellen und Views: siehe makeTableNames:
location: tso.rzx.p0.user.exec
docu: http://chw20025641/host/db2wiki/pmwiki.php?n=Main.RtsReo
history ***************************************************************
19.06.2016 v6.5 ranges do not restart with 1 for next list
**********/ /* end of help ********************************************
29.02.2016 v6.4 fix loop: check rts.instance=base.inst,neue views
28.01.2015 v6.3 ohne S100447.vReoTSStatsFix für v11
index ohne parts for imp>9 -> reorP und aReoP
18.09.2013 v6.1 all parts togethere for imp>9 -> reorP und aReoP
index ohne parts for imp>9 -> reorP und aReoP
04.05.2012 v6.0 fix problem with multiple utilities for same type
26.03.2012 v5.9 handle v9/v10 real time stats n
15.02.2012 v5.8 empty listdefs in v10 implementation
21.10.2011 v5.7 parallelism, undon insert tReoRunJob, new sql
7.02.2011 v5.61 fix Dupl. Abend on insert tReoRunJob, new sql
17.01.2011 v5.6 reOrder von v5.5
14.01.2011 v5.5 reFactoring und neue copies
30.11.2010 v5.41 fix tyInp in tReoRunJob
27.09.2010 v5.4 new name reoCheck, use s100447.?Reo* tb
24.09.2010 v5.3 split listdef by unCompressedDataSize limit
27.08.2010 v5.2 fix uncompressDatasize tsStatsFix in insertStats
29.07.2010 v5.1 fix ixSpae, namens Verschreiber
08.07.2010 v5.1 fix rngI0=-99
07.07.2010 v5.1 fix reoTimeLimite, StartAnzeige, checkRef err
06.07.2010 v5.1 jobException Table, Sort Limite, *run* history
09.12.2009 v5.0 weiterarbeiten wenn checkRef abstürzt
03.12.2009 v5.0 TS jetzt mit reoTime, die Grösse der
nicht Partitionierten Indexe berücksi.
23.04.2010 v4.4 reorg by part range für ts
falls partBis > für DB jJOB in Exc
08.09.2008 v4.3 vRtsReoIx.is fuer Indexspace
(nicht null bei fehlenden rts Daten)
21.08.2008 v4.2 vRtsReoIx.cr (statt .Creator) fuer V9
20.05.2008 v4.1 Bereinigung
10.04.2008 v4.0 Umstellung auf neue exception tabl/vws
04.12.2006 v2.3 Optimierung mit Gruppenbruch-Logik
20.11.2006 v2.21 RSU0610 bewirkt Meldung:
'insuff. operands for keyword listdef'
Neu wird leeres Member erstellt falls
keine Objekte die Schwellwerte erreich
10.04.2006 v2.2 pgm läuft auch ohne ispf (A234579)
Diagnose Statement erlaubt (A234579)
10.11.2005 v2.1 schwellwerte erweitert (A234579)
23.09.2005 v2.0 index mit rts-abfrage (A234579)
20.09.2005 v1.2 erweiterte abfrage auf noload repl
16.09.2005 v1.1 inkl.reorg index ohne rts (A234579)
25.10.2004 v1.0 grundversion (m.streit,A234579)
*******************************************************************/
m.debug = 0
parse upper arg ssid type
m.job = strip(MVSVAR('SYMDEF', 'JOBNAME'))
say "reoCheck Programmversion = 6.5/19.6.16 runTime" date('s') time()
say " DB2 Subsystem =" ssid
say " Job Name =" m.job
if ssid = '' | pos('?', ssid type) > 0 then
exit errHelp('fehlende Parameter:' ssid type)
call sqlConnect ssid
call makeTableNames ssid, 's100447'
call selectJobParms
say " Limiten"
say " Reo Zeit TS = " fmtTime(m.job.time.ts)
say " Reo Zeit IX = " fmtTime(m.job.time.ix)
say " unCompSizeI0 =" fmtDec(m.job.uncompI0) 'Bytes'
say " unCompSizeDef =" fmtDec(m.job.unCompDef) 'Bytes'
say " IX nach spaeter =" m.job.ixSpae
say " *Run* Stats =" m.job.stats
if m.runJob.tst = '' then
say " Last Run = nicht gefunden"
else
say " Last Run =" m.runJob.tst m.runJob.ty ,
"status" m.runJob.sta
if type = '' then do
type = 'TS'
say " kein Type gewählt, also TS-Reorg getriggert"
end
m.tyInp = type
if m.runJob.sta = 's' then do
if type = 'IX' & m.job.ixSpae = 't' then do
say " run" m.runJob.tst "mit spaeter typeChange auf TS"
type = "TS"
end
else if type = 'IX' & m.job.ixSpae = 'n' then do
say " run" m.runJob.tst "mit spaeter ==> STOP"
type = ''
end
else do
say " run" m.runJob.tst "mit spaeter"
end
end
m.ty = type
if type \== '' then
say " Type = "type
say ''
call errReset 'h'
call mapIni
call sqlIni
/* use adrTso, so we survive errors in reoRefSt */
call adrTso reoRefSt '-'ssid 'ref' 100 'staLevel' m.job.stats ,
'staJob' m.job, '*'
m.jobSta = 0
m.rngFi = 0
m.rngLa = 0
if type \== '' then do
call doreoCheck type, '-ddIn1', '-ddIn2', dsn4allocated('ddOUt1')
end
else do
o.1 = ' -- reoCheck' date('s') time() 'nicht nach spaeter'
call writeDsn ddOut1, 'O.', 1, 1
end
call sqlDisconnect
exit
/*--- main function
analyse utility preview sysprint
analyse utitlity ctl input
select Rts Infos and decide what to reorg
generate new utility ctrl cards ----------------------------*/
doReoCheck: procedure expose m.
parse arg doType, ddIn1, ddIn2, ddOut
m.lst.0 = 0
call analyzeSysprint lst, ddIn1
call debugLst lst, 'lists in sysprint'
m.ctl.0 = 0
call analyzeCtl ctl, ddIn2
call debugCtl ctl
typ1 = left(doType, 1)
m.iRg = 0
do cx=1 to m.ctl.0
cc = ctl'.'cx
m.cc.list = ''
l1 = mapGet(lst'.N2L', m.cc.listName, '')
if l1 == '' then do
say '*** warning' m.cc.listName 'in ListDef,',
'aber nicht im SysPrint (leer?)'
end
else if word(m.l1.type, 1) ^== typ1 then do
call debug '*** warning list' m.l1.type m.l1.name ,
'nicht type' doType 'wird ignoriert'
end
else if m.l1.done == 1 then do
m.cc.list = l1
end
else do
m.cc.list = l1
m.l1.done = 1
call selectRts l1, doType
miss = ''
do ox = 1 to m.l1.0
if m.l1.ox.nm == '' then
miss = miss m.l1.ox.db'.'m.l1.ox.sp
end
if miss \== '' then
call err 'obj in sysprint fehlen in rts:'miss
rTi = makeRanges(l1, doType)
call reportReo l1, doType, rTi
end
end
call genCtl ddOut, ctl, doType
call insertStats lst, doType
return
endProcedure doReoCheck
/*--- view and tableNames, copy in reoRefSt --------------------------*/
makeTableNames: procedure expose m.
parse arg ssid, q
if q = 'OA1P' wordPos(ssid, 'DBAF DBTF DBZF DBLF') > 0 then
q = overlay(substr(ssid, 3, 1), q, 4)
r = q
m.rrTS = r".vReoTS"
m.rrIx = r".vReoIX"
m.dbSt = q".tDbState"
m.exJob = q".vReoJobParms"
m.ruJob = q".tReoRunJob"
m.ruPart = q".tReoRunPart"
m.ruTsSt = q".tReoRunTSStats"
m.ruIxSt = q".tReoRunIXStats"
m.ixStats= "sysibm.sysIndexSpaceStats"
m.tsStats= "sysibm.sysTableSpaceStats"
return
endProcedure makeTableNames
/*--- select job parameters from job parameter table -----------------*/
selectJobParms: procedure expose m.
if sqlPreAllCl( 9, "select",
"int(substr(max(prC2 || char(tsTime)), 3)),",
"int(substr(max(prC2 || char(ixTime)), 3)),",
"real(substr(max(prC2 || char(uncompDef)), 3)),",
"real(substr(max(prC2 || char(uncompI0 )), 3)),",
" substr(max(prC2 || char(ixSpae)), 3) ,",
" substr(max(prC2 || char(stats )), 3) ",
"from" m.exJob ,
"where left(job,jobLen) = left('"left(m.job,8)"', jobLen)",
, job, ":m.job.time.ts, :m.job.time.ix, :m.job.uncompDef," ,
":m.job.uncompI0, :m.job.ixSpae, :m.job.stats")<> 1 then
call err m.job.0 'rows from' m.exJob '\n'sqlMsg()
m.runJob.tst = ''
m.runJob.sta = ''
if sqlPreAllCl( 9, "select tst, ty, sta, eoj" ,
"from" m.ruJob ,
"where job = '"m.job"'" ,
"order by tst desc",
"fetch first row only",
, runJob, ":m.runJob.tst, :m.runJob.ty," ,
":m.runJob.sta, :m.runJob.eoj :m.runJob.eojInd"),
> 1 then
call err m.job.0 'rows from' m.ruJob'\n'sqlMsg()
return
endProcedure selectJobParms
/*--- analyze sysprint of utility preview
put listelements in m.lst. ------------------------------*/
analyzeSysprint: procedure expose m.
parse arg listen, inp
if m.listen.0 = 0 then
call mapReset listen'.N2L'
call readDsn inp, i1.
dbg = 0
do rx=1 to i1.0
if substr(i1.rx, 2, 10) == 'DSNU1010I ' ,
| substr(i1.rx, 2, 10) == 'DSNU1008I ' then do
sta = substr(i1.rx, 8, 2)
wx =wordPos('LISTDEF', i1.rx)
listName = word(i1.rx, wx+1)
if wx < 5 | listName == '' then
call 'bad sysprint line' rx':' i1.rx
if dbg then say '???nnn' sta listName
oKey = mapGet(listen'.N2L', listName, '')
if oKey \== '' then do
if dbg then say '???nnn list alrExists' oKey m.oKey.0
/* DSNU1008I may appear several times| */
if sta \== 08 | m.oKey.0 \= 0 then
call err 'list' listName 'alreadey exists with' ,
m.oKey.0 'objects sysprint line' rx':' i1.rx
end
else do /* add new list */
m.listen.0 = m.listen.0 + 1
lst = listen'.'m.listen.0
m.lst = lst
m.lst.0 = 0
call mapAdd listen'.N2L', listName, lst
call mapReset lst'.N2O'
m.lst.name = listName
m.lst.type = ''
end
if sta == 08 then
sta = '' /* DSNU1008I has only a single line */
m.lst.prtCnt = 0
end
else if substr(i1.rx, 2, 10) \== ' ' then do
sta = '' /* next message */
end
else if sta == 10 then do /* DSNU1010I line 2 */
wx =wordPos('OBJECTS', i1.rx)
if wx < 4 | \ datatype(word(i1.rx, wx-1), 'n') then
call err 'bad object count in sysprint line' rx':'i1.rx
m.lst.prtCnt = word(i1.rx, wx-1)
if dbg then say '???nnn 10' word(i1.rx,wx-1) 'objects'
sta = 102
end
else if sta == 102 then do /* DSNU1010I line 3... */
parse var i1.rx inc obj db1 '.' ts ' ' . 'LEVEL(' part ')'
if inc \== 'INCLUDE' ,
| wordPos(obj, 'TABLESPACE INDEXSPACE') < 1 then
call err 'bad sysprint include line' rx':' i1.rx
if dbg then say '???nnn 102 inc' obj db1'.'ts':'part'|'
ty = left(obj, 1)
if m.lst.type == '' then
m.lst.type = ty
else if m.lst.type \== ty then
call err 'ListDef' listName ,
'mit verschiedene Types, sysprint' rx':' i1.rx
ky = db1'.'ts
o = mapGet(lst'.N2O', ky, '')
if o \== '' then do /* add part to existing obj */
if part \== '' & m.o.parts \== '' then
/* parts: BitString with 1 at position of part */
m.o.parts = overlay(1, m.o.parts, part)
else if part == '' & m.o.parts \== '0' then
call err 'part 0 mismatch for' m.o.db'.'m.o.sp
end
else do /* new obj */
ox = m.lst.0 + 1
m.lst.0 = ox
o = lst'.'ox
m.o.db = db1
m.o.sp = ts
m.o.dbSp = ky
m.o.nm = ''
if part == '' then
m.o.parts = 0
else /* parts: BitString with 1 at position of part */
m.o.parts = overlay(1, '', part)
call mapAdd lst'.N2O', ky, o
end
end
end
do lx=1 to m.listen.0
lst = listen'.'lx
if (m.lst.0=0) <> (m.lst.prtCnt=0) then
call err 'list' m.lst.name 'has' m.lst.0 'objects' ,
'but' m.prtCnt 'parts'
say 'list' m.lst.name 'has' m.lst.0 'objects with' ,
(m.lst.prtCnt+0) 'parts'
do ox=1 to m.lst.0
o = lst'.'ox
if m.o.parts == 0 then do
m.o.paFr = 0
m.o.paTo = 0
end
else do
m.o.paFr = pos(1, m.o.parts)
if m.o.paFr > 0 then
m.o.paTo = lastPos(1, m.o.parts)
else
m.o.paTo = -1
end
end
end
return
endProcedure analyzeSysprint
/*--- analyse a listdef in dsn spec inp
put the different parts into map ctl -----------------------*/
analyzeCtl: procedure expose m.
parse arg ctl, inp
cx = m.ctl.0
call readDsn inp, i2.
st = ''
do rx=1 to i2.0
w = word(i2.rx, 1)
if w = '' then do
end
else if wordPos(w, 'REORG COPY REBUILD CHECK QUIESCE UNLOAD' ,
'LOAD MERGECOPY MODIFY RECOVER RUNSTATS DIAGNOSE') ,
> 0 then do
lx = wordPos('LIST', i2.rx)
liNa = word(i2.rx, lx+1)
if lx < 1 | lstName = '' then do
say 'warning no list in' i2.rx
/* could be reorg option unload continue,
thus, ignore it | */
end
else do
cx = cx + 1
st = ctl'.'cx
m.st.0 = 0
m.st.listName = liNa
call debug w 'list' liNa '->' st
end
end
if st ^== '' then
call mAdd st, i2.rx
end
m.ctl.0 = cx
return
endProcedure analyzeCtl
/*--- select the rts views for list lst and type type ----------------*/
selectRts: procedure expose m.
parse arg lst, type
if m.debug \== 1 then
m.sqlRetOk = 'w'
if m.lst.rts == 1 then
return
m.lst.rts = 1
if type == 'TS' then do
sql = "select db, ts, part, dbid, psid, reason, importance," ,
"reorgTime, i0Time, i0Parts," ,
"swRangeI0, swParallel, lastBuilt, uncompSz",
"from" m.rrTS ,
"where (base = instance or instance is null",
"or base is null)",
"and (" genWhere(word(m.lst, 1), lst)")" ,
"order by importance desc, lastBuilt asc" ,
"with ur"
feFi = sqlVars('M.R', 'DB SP PART DBID SPID REASON IMP' ,
'RETI I0TI I0PA RAI0 PARA LABU UNCO', 1)
end
else if type == 'IX' then do
sql = "select db, is, part, ts, cr, ix, dbId, isoBid,",
"reason, importance, reorgTime, lastBuilt" ,
"from" m.rrIX ,
"where (base = instance or instance is null",
"or base is null)",
"and (" genWhere(word(m.lst, 1), lst)")" ,
"order by importance desc, lastBuilt asc with ur"
feFi = sqlVars('M.R', 'DB SP PART TS CR IX DBID SPID',
'REASON IMP RETI LABU', 1)
m.r.i0Ti = 0
m.r.raI0 = 0
m.r.para = 0
m.r.unCo = 0
end
call debug 'sql' sql
call sqlPreOpen 1, sql
iLnk = lst
m.iLnk.impLnk = ''
m.iLnk.imp = 9e9
do while sqlFetchInto(1, feFi)
/* say r '???db' m.r.db 'sp' m.r.sp 'pa' m.r.part
say ' imp' m.r.imp left(m.r.reason, 40) m.r.laBu
say 'reTi' m.r.reTi 'ioTi' m.r.i0Ti 'ix' m.r.i0Pa,
' raI0' m.r.raI0 'para' m.r.para */
key = strip(m.r.db)'.'strip(m.r.sp)
if m.iLnk.imp < m.r.imp then
call err 'importance increasing'
o = mapGet(lst'.N2O', key, '')
pa = m.r.part + 0
if o == '' then
call err key 'in rts but not lst'
if (pa == 0) \== (m.o.parts == 0) then
call err key 'part 0 misma rts' m.r.part 'lst' m.lst.parts
if pa \== 0 then
if substr(m.o.parts, pa, 1) \== 1 then do
say 'warning' key 'part' m.r.part 'not in lst'
iterate
end
if m.o.nm == '' then do
if type == 'TS' then do
m.o.nm = key
end
else do
m.o.ts = strip(m.r.ts)
m.o.cr = strip(m.r.cr)
m.o.ix = strip(m.r.ix)
m.o.nm = m.o.cr'.'m.o.ix
end
m.o.dbId = strip(m.r.dbId)
m.o.spId = strip(m.r.spId)
m.o.rngI0 = ''
m.o.i0Ti = m.r.i0Ti
m.o.i0Pa = m.r.i0Pa
m.o.raI0 = m.r.raI0
m.o.para = m.r.para
end
m.o.pa.impLnk = ''
m.iLnk.impLnk = o'.'pa
iLnk = o'.'pa
m.o.pa.part = pa
m.o.pa.obj = o
m.o.pa.reTi = m.r.reTi
m.o.pa.unco = m.r.unco
m.o.pa.imp = m.r.imp
m.o.pa.imRe = m.r.imp m.r.reason
m.o.pa.rng = ''
end
call sqlClose 1
return
endProcedure selectRts
/*--- group partitions into ranges
and make the ranges by thresholds for space, time etc ------*/
makeRanges: procedure expose m.
parse arg lst, type
iLnk = m.lst.impLnk
rLnk = lst
m.rLnk.reoLnk = ''
rTimax = m.job.time.type
rTi = 0
if type = 'IX' then do /* Algorithmus 1: jede partition einzeln
reorganisieren bis zur ZeitLimite */
do while iLnk \== ''
iL = iLnk
iLnk = m.iL.impLnk
o = m.iL.obj
if m.iL.imp <= 0 then
m.iL.rng = 'i'
else if rTi > rTimax & m.iL.imp < 9 then
m.iL.rng = 's'
else do
m.iRg = m.iRg + 1
m.iL.rng = m.iRg
m.o.rngI0 = -99
rTi = rTi + max(.001, m.iL.reTi)
end
m.rLnk.reoLnk = iL
rLnk = iL
end
end
else do /* Algorithmus 2: partition Ranges innerhalb TS reorg.
range Limitiert nach zeit und sortPlatz
Total ZeitLimite */
do while iLnk \== ''
iL = iLnk
iLnk = m.iL.impLnk
if m.iL.rng \== '' then
iterate
if m.iL.imp <= 0 then
m.iL.rng = 'i'
else if rTi > rTimax & m.iL.imp < 9 then
m.iL.rng = 's'
if m.iL.rng \== '' then do
m.rLnk.reoLnk = iL
rLnk = iL
iterate
end
o = m.iL.obj
liUn = if(m.o.I0ti <= 0, m.job.uncompDef, m.job.uncompI0)
liTi = max(120, m.o.I0ti * m.o.raI0/100)
liPa = m.o.para
acTi = max(0, m.o.I0Ti)
acPa = 0
acUn = 0
if m.o.rngI0 == '' then do
if type == 'TS' ,
& m.iL.part > 0 & m.o.i0Pa > 0 then
m.o.rngI0 = ass('m.iRg', m.iRg + 1)
else
m.o.rngI0 = -99
end
m.iRg = m.iRg + 1
pL = iL /* do not reorg imp<0 | */
do while pL \== '' & m.pL.imp >= 0
if m.pL.obj = o then do
if m.pL.rng \== '' then
call err 'rng already set'
m.pL.rng = m.iRg
acPa = acPa + 1
if m.o.i0Ti > 0 then
acTi = acTi + max(0.1, m.pL.reTi - m.o.i0Ti)
else /*???wk tentative formula for paralellism */
acTi = max(acTi, m.pL.reTi),
+ max(0.1, 0.3 * min(acTi, m.pL.reTi))
acUn = acUn + max(m.pL.unco, 1)
m.rLnk.reoLnk = pL
rLnk = pL
/* reorp and aReoP must reorg all parts together */
if acPa >= liPa & acTi >= liTi & m.pL.imp <= 9 then
leave
if acUn >= liUn then
leave
end
pL = m.pL.impLnk
end
rTi = rTi + acTi
end
end
m.rLnk.reoLnk = ''
return rTi
endProcedure makeRanges
/*--- report which paritions to reorg and which not ------------------*/
reportReo: procedure expose m.
parse arg lst, type, rTi
tt = if(type == 'TS', '(table', '(index')'Partitionen)'
if rTi <= 0 then
call reoTitSay 'nichts zu reorganisieren:' type
else
call reoTitSay type 'zu reorganisieren,' fmtTime(rTi),
'geschaetzte Step ReorgZeit', type
rL = m.lst.reoLnk
iRg = 0
do while rL \== '' & m.rL.rng \== 's'& m.rL.rng \== 'i'
if iRg \= m.rL.rng & iRg+1 \= m.rL.rng ,
& iRg <> 0 & iRg+2 \= m.rL.rng then
call err 'bad range' m.rL.rng 'after' iRg
iRg = m.rL.rng
say reoFmt(rL)
rL = m.rL.reoLnk
end
if rL \== '' & m.rL.rng == 's' then
call reoTitSay 'auf spaeter verschobene' type 'Reorgs', type
do while rL \== '' & m.rL.rng == 's'
say reoFmt(rL)
rL = m.rL.reoLnk
end
if rL \== '' then do
if m.rL.rng \== 'i' then
call err 'at end but rL' rL 'rng' m.rL.rng
call reoTitSay type 'Reorganisation nicht noetig fuer'
do lx=1 to m.lst.0
pas = ''
paL = ''
yRe = ''
do p=m.lst.lx.paFr to m.lst.lx.paTo
if m.lst.lx.p.rng == 'i' then do
xRe = space(subword(m.lst.lx.p.imRe, 2), 1)
if pos(xRe, yRe) < 1 then
yRe = yRe';' xRe
if p-1 = paL then do
paL = p
end
else do
if paL = paF then
pas = pas',' paL
else if paL \== '' then
pas = pas',' paF'-'paL
paL = p
paF = p
end
end
end
if paL == '' then
iterate
if paL = paF then
pas = pas',' paL
else if paL \== '' then
pas = pas',' paF'-'paL
say m.lst.lx.nm':' substr(pas, 2)':' substr(yRe, 3)
end
end
say ''
m.sqlRetOk = ''
return 0
endProcedure reportReo
/*--- return the sql where condition
from the partition list in map lst ------------------*/
genWhere: procedure expose m.
parse arg lst
if m.lst.type = 'I' then
spFi = 'is'
else if m.lst.type = 'T' then
spFi = 'ts'
else
call err 'bad type in genWhere('lst')'
wh = ''
do dx=1 to m.lst.0
o = lst'.'dx
d1 = m.o.db
if db.d1 == 1 then
iterate
db.d1 = 1
fo = 0
do kx=dx to m.lst.0
o = lst'.'kx
if m.o.db \== d1 then
iterate
fo = fo + 1
if fo = 1 then
wh = wh "or (db = '"d1"' and" spFi "in("
wh = wh "'"m.o.sp"',"
end
if fo > 0 then
wh = left(wh, length(wh)-1)'))'
end
if wh = '' then
return ''
else
return substr(wh, 4)
endProcedure genWhere
/*--- format outputline for 1 part to reorg --------------------------*/
reoFmt: procedure expose m.
parse arg pa
f = 'e'
o = m.pa.obj
return left(m.o.nm, 21 - length(m.pa.part)) m.pa.part ,
right(if(m.pa.rng < 0, '', m.pa.rng), 5) ,
fmtTime(m.pa.reTi) fmtTime(m.o.i0Ti) strip(m.pa.imRe)
endProcedure reoFmt
/*--- title for reorg part lines -------------------------------------*/
reoTitSay: procedure expose m.
parse arg tit, withHead
say ''
say left(tit' ', 70, '*')
if withHead \== '' then
say left(if(m.ty == 'TS', 'db.tablespace', 'creator.index'),17),
right('part', 4) right('range', 5) ,
right('reoTi', 5) right('i0Ti', 5) 'i reason'
return
endProcedure reoTit
/*--- generate utiltity ctrl cards for run
ddOut: output dd spec to write ctrl to
ctl: input ctl with link to lists
genType: TS or IX ---------------------------------*/
genCtl: procedure expose m.
parse arg ddOut, ctl, genType
if genType = 'TS' then
ldType = 'TABLESPACE'
else if genType = 'IX' then
ldType = 'INDEXSPACE'
else
call err 'bad type' genType
m.out.1 = ' -- reoCheck' date('s') time()
m.out.0 = 1
do cx = 1 to m.ctl.0
c1 = ctl'.'cx
lst = m.c1.list
if lst == '' | m.lst.isGen == 1 then
iterate
m.lst.isGen = 1
liNa = m.lst.name
rL = m.lst.reoLnk
if rL == '' | m.rL.rng == 'i' | m.rL.rng == 's' then do
call debug 'nothing to reorg in' m.lst.name
iterate
end
dx = 0
acRg = ''
do while rL \== '' & m.rL.rng \== 's' & m.rL.rng \== 'i'
o = m.rL.obj
if m.rL.rng \= acRg then do
if dx == 0 | (genType == 'TS' ,
& wordPos(m.o.nm, acNms) > 0) then do
dx = dx + 1
acNms = ''
call mAdd out, 'LISTDEF' liNa'#'dx
end
acRg = m.rL.rng
acNms = acNms m.o.nm
end
pNo = m.rL.part
if genType <> 'IX' | m.rL.imp < 11 then do
call mAdd out, ' INCLUDE' ldType m.o.dbSp,
if(pNo=0,'', 'PARTLEVEL('pNo')')
end
else do
kk = m.o.dbSp /* pending: reo whole index atomically */
if ix11.kk \== 1 then do
ix11.kk = 1
call mAdd out, ' INCLUDE' ldType m.o.dbSp
end
end
rL = m.rL.reoLnk
end
do dy=1 to dx
call genCtlUtil out, ctl, lst, 'LIST' liNa'#'dy
end
end
call writeDsn ddOut, 'M.'out'.', ,1
return
endProcedure genCtl
/*--- generate utility ctl for all utitlity for one list -------------*/
genCtlUtil: procedure expose m.
parse arg o, ctl, lst, what
do ux=1 to m.ctl.0 /* each utility for this list */
c1 = ctl'.'ux
if m.c1.list \== lst then
iterate
call mAdd o, ' -- utility' ux 'of' what
l1 = m.ctl.ux.1
lx = wordPos('LIST', l1)
if lx < 2 | word(l1, lx+1) <> m.lst.Name then
call err 'bad reorg list' lst':' l1
call mAdd o, subWord(l1, 1, lx-1) what subWord(l1, lx+2)
do cx=2 to m.c1.0
call mAdd o, strip(m.c1.cx, 't')
end
end
return
endProcedure genCtlUtil
/*--- insert statistics into tReoRun* tables ------------------------*/
insertStats: procedure expose m.
parse arg all, type
call sqlCommit
staLev = pos(m.job.stats, 'njps')
if staLev < 2 then
return
do try=1
call sqlPushRetOk -803
res = sqlPreAllCl(1, "select tst from final table (",
"insert into" m.ruJob ,
"(tst, job, TY, TYINP, STA)",
"values(current timestamp, '"m.job"',",
"'"type"', '"m.tyInp"', '"m.jobSta"') )",
, st , ':m.tst')
call sqlPopRetOk
if res = 1 then
leave
else if try > 5 then
call err 'to many retries ('try') for insert' m.ruJob
else if res \== -803 then
call err 'bad res' res 'insert' m.ruJob
say 'duplicate for insert' m.ruJob 'retry' try
call sqlExec 'rollback'
call sleep 1
end
call debug 'insertStats' m.tst m..0
if staLev < 3 then
return
do try=1
call sqlPrepare 22, "insert into" m.ruPart "(",
"tst, rng, part, paVon, paBis," ,
"rngI0, dbId, spId, ty, sta, reason, db, sp" ,
")values('"m.tst"', ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?)"
ty = if(type == 'TS', 't', 'i')
r0.0 = 1
pCnt = 0
do kx = 1 to m.all.0
lst = m.all.kx
if m.lst.rts \== 1 then
iterate
laRa = 0
rL = m.lst.reoLnk
do while rL \== '' & m.rL.rng \== 'i'
o = m.rL.obj
r0 = m.o.rngI0
ra = m.rL.rng
raTy = ra
if wordPos(raTy, 'i s') < 1 then
raTy = 'r'
if raTy == 'r' & r0 >= laRa then do
if r0 \= laRa + 1 & laRa <> 0 then
call err 'bad r0' r0 'after' laRa
laRa = r0
call sqlExecute 22, r0, 0, 0, 0,
, -99, m.o.dbid, m.o.spId,
, ty, '0', 'i0 Indexe', m.o.db, m.o.sp
call debug sqlerrd.3 'i0 parts inserted r0' r0
pCnt = pCnt + 1
end
if raTy \== 'r' then do
ra = max(32000001, laRa+1)
laRa = ra
r0 = -99
rFr = m.rL.part
rTo = m.rL.part
end
else if ra \= laRa then do
if laRa + 1 \= ra & laRa <> 0 then
call err 'bad range' ra 'after' laRa
laRa = ra
rFr = m.rL.part
rTo ='bad'
qL = rL
do qx=0 while ra = m.qL.rng
rTo = m.qL.part
qL = m.qL.reoLnk
end
if qx < 1 | (rFr = rTo) <> (qx = 1) then
call err 'bad from to'
end
call debug m.o.nm':'m.rL.part 'in range' ra,
'with' qx 'parts from' rFr 'to' rTo
call sqlExecute 22, ra, m.rL.part, rFr, rTo,
, r0, m.o.dbid, m.o.spId,
, ty, raTy, left(m.rL.imRe, 50), m.o.db, m.o.sp
pCnt = pCnt + 1
rL = m.rL.reoLnk
end
end
say pCnt 'runParts inserted into' m.ruPart
if staLev < 4 then
return
parse var m.tsStats rTC '.' rTT
parse var m.ixStats rIC '.' rIT
if ty == 't' then do
call sqlExec "insert into" m.ruTsSt,
"(tst, rng," tbCols(rTC, rTT)")",
"select tst, rng, r.*",
"from" m.ruPart "p," ,
m.tsStats "r",
"where p.tst = '"m.tst"' and p.ty = 't'",
"and p.dbid = r.dbid and p.spId = r.psId" ,
"and p.part = r.partition", 100
say sqlerrd.3 'tsStats inserted into' m.ruTsSt
call sqlExec "insert into" m.ruIxSt ,
"(tst, rng," tbCols(rIC, rIT)")",
"select tst, rng, r.*",
"from" m.ruPart "p," m.ixStats "r" ,
", sysibm.sysTables t, sysibm.sysIndexes i",
"where p.tst = '"m.tst"' and p.ty = 't'",
"and p.dbid = r.dbid and p.spId = r.psId" ,
"and t.dbName = p.db and t.tsName = p.sp" ,
"and i.tbCreator = t.creator and i.tbName=t.name",
"and r.dbId = i.dbId and r.isoBid = i.isoBid",
"and p.part = r.partition", 100
say sqlerrd.3 'ixStats inserted into' m.ruIxSt
end
else if ty == 'i' then do
call sqlExec "insert into" m.ruIxSt,
"(tst, rng," tbCols(rIC, rIT)")",
"select tst, rng, r.*",
"from" m.ruPart "p," m.ixStats "r",
"where p.tst = '"m.tst"' and p.ty = 'i'",
"and p.dbid = r.dbid and p.spId = r.isoBid" ,
"and p.part = r.partition", 100
say sqlerrd.3 'ixStats inserted into' m.ruIxSt
end
call sqlCommit
return
endProcedure insertStats
tbCols: procedure expose m.
parse upper arg cr, tb
sql = "select name from sysibm.sysColumns",
"where tbCreator = '"cr"' and tbName = '"tb"'" ,
"order by colNo asc"
call sqlPreOpen 1, sql
res = ''
do while sqlFetchInto(1, ':c1')
res = res',' c1
end
call sqlClose 1
return substr(res, 3)
endProcedure tbCols
/*--- debug a listDef ------------------------------------------------*/
debugCtl: procedure expose m.
parse arg ctl, tit
if m.debug ^== 1 then
return
call debug tit
do kx=1 to m.ctl.0
cc = ctl'.'kx
call debug 'ctl' kx cc 'for list' m.cc.listName
do s1=1 to m.cc.0
call debug ' ' strip(m.cc.s1, t)
end
end
return
endProcedure debugCtl
/*--- debug a list ---------------------------------------------------*/
debugLst: procedure expose m.
parse arg lst, tit
if m.debug \== 1 then
return
call debug tit
do lx=1 to m.lst.0
call debug 'list' lst'.'lx m.lst.lx.name m.lst.lx.type ,
'db' m.lst.lx.db
do kx=1 to m.lst.lx.0
k2 = lst'.'lx'.'kx
call debug ' ' k2 '->' ,
'db' m.k2.db 'sp' m.k2.sp 'parts' m.k2.parts
end
end
return
endProcedure debugLst
/*--- debug a map ----------------------------------------------------*/
debugMap: procedure expose m.
parse arg mp, pr
if m.debug ^== 1 then
return
do kx=1 to m.kk.0
k2 = mapGet(mp, m.kk.kx)
call debug pr m.kk.kx '->' k2
call debug pr ' db' m.k2.db 'sp' m.k2.sp 'parts' m.k2.parts
end
return
endProcedure debugMap
/*--- search the ds Name alloctade to dd dd --------------------------*/
dsn4Allocated: procedure expose m.
parse upper arg dd
/* it would be much easier with listDsi,
unfortuneatly listDsi returns pds name without member*/
dd = ' 'dd' '
oldOut = outtrap(l.)
call adrTso "listAlc st"
xx = outtrap(off)
do i=2 to l.0 while ^abbrev(l.i, dd)
end
if i > l.0 then
return '' /* dd not found */
j = i-1
dsn = word(l.j, 1)
if abbrev(l.j, ' ') | dsn = '' then
call err 'bad dd lines line\n'i l.i'\n'j l.j
return dsn
endProcedure dsn4Allocated
/***********************************************************************
ende Programm
ab hier kommen nur noch allgemeine Service Routinen
***********************************************************************/
/* copy sleep begin ***************************************************/
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
/* copy sleep end *****************************************************/
/* copy sql begin ***************************************************
sql interface
***********************************************************************/
sqlIni: procedure expose m.
parse arg opt
if m.sql.ini == 1 & opt \== 1 then
return
m.sqlNull = '---'
m.sqlInd = 'sqlInd'
m.sqlRetOK.0 = 0
m.sqlMsgCa = 0
m.sqlMsgDsntiar = 1
m.sqlMsgCodeT = 0
call sqlPushRetOk
m.sql.ini = 1
m.sql.connected = ''
return
endProcedure sqlIni
/*--- prepare statement 's'cx from sql src into descriptor desc ------*/
sqlPrepare: procedure expose m.
parse arg cx, src, descOut, descInp
s = ''
if descOut == 1 then
s = 'into :M.SQL.'cx'.D'
res = sqlExec('prepare s'cx s 'from :src')
if res < 0 then
return res
if descInp == 1 | (descInp == '' & pos('?', src) > 0) then
res = sqlExec('describe input s'cx 'into :M.SQL.'cx'.I')
else
m.sql.cx.i.sqlD = 0
return res
endProcedure
/*--- prepare and declare 'c'cx from sql src -------------------------*/
sqlPreDeclare: procedure expose m.
parse arg cx, src, descOut, descInp
res = sqlPrepare(cx, src, descOut, descInp)
if res >= 0 then
return sqlExec('declare c'cx 'cursor for s'cx)
return res
endProcedure sqlPreDeclare
/*--- prepare, declare and open 'c'cx from sql src -------------------*/
sqlPreOpen: procedure expose m.
parse arg cx, src, descOut, descInp
res = sqlPreDeclare(cx, src, descOut, descInp)
if res >= 0 then
return sqlOpen(cx)
return res
endProcedure sqlPreOpen
/*--- open cursor 'c'cx using arguments arg(2), arg(3)... ------------*/
sqlOpen: procedure expose m.
parse arg cx
do ix=1 to arg()-1
call sqlDataSet 'SQL.'cx'.I', ix, arg(ix+1)
end
return sqlExec('open c'cx 'using descriptor :M.SQL.'cx'.I')
endProcedure sqlOpen
/*--- close cursor 'c'cx ---------------------------------------------*/
sqlClose: procedure expose m.
parse arg cx, src
return sqlExec('close c'cx)
endProcedure sqlClose
/*--- fetch cursor 'c'cx into variables ggVars -----------------------*/
sqlFetchInto:
parse arg ggCx, ggVars
if ggVars == '' then
ggVars = 'descriptor :M.SQL.'ggCX'.D'
/* accept sqlCodes > 0 except 100 */
ggRes = sqlExec('fetch c'ggCx 'into' ggVars, 100 m.sqlRetOk)
if ggRes == 0 then
return 1
if ggRes == 100 then
return 0
return ggRes
endProcedure sqlFetchInto
/*--- return sql variable list for stem st and fields the word in vars
if withInd == 1 then with sqlIndicator variables
sqlVars('S', 'A B') --> ':S.A, :S.B'
sqlVars('S', 'A B', 1) --> ':S.A :S.A.SQLIND, :S.B :S.B.SQLIND'
----------------------------------------------------------------------*/
sqlVars: procedure expose m.
parse arg st, vars, withInd
res = ''
if st ^== '' then
st = st'.'
do ix=1 to words(vars)
res = res', :'st || word(vars, ix)
if withInd == 1 then
res = res ':'st || word(vars, ix)'.sqlInd'
end
return substr(res, 3)
endProcedure sqlVars
sqlVarsNull: procedure expose m.
parse arg st, vars
hasNulls = 0
do ix = 1 to words(vars)
fld = word(vars, ix)
if m.st.fld.sqlInd < 0 then do
m.st.fld = m.sqlNull
hasNulls = 1
end
end
return hasNulls
endProcedure sqlVarsNull
/*--- open cursor 'c'cx fetch all into variables vars and close
st = passed stem, sx = row number
return number of rows fetched ----------------------------------*/
sqlOpAllCl:
parse arg ggCx, st, ggVars
do ggAx=4 to arg()
call sqlDataSet 'SQL.'ggCx'.I', ggAx-3, arg(ggAx)
end
ggRes = sqlOpen(ggCx)
if ggRes < 0 then
return ggRes
do sx = 1 until ggRes \== 1
ggRes = sqlFetchInto(ggCx, ggVars)
end
m.st.0 = sx - 1
call sqlClose ggCx
if ggRes == 0 then
return m.st.0
return ggRes
endProcedure sqlOpAllCl
sqlDataSet: procedure expose m.
parse arg da, ix, val
m.da.ix.sqlData = val
m.da.ix.sqlInd = - (arg(ix+2) == m.sqlNull)
/* data types schienen einmal nicht zu funktionieren .......
if wordPos(m.da.ix.sqlType, '384 385 388 389 392 393') > 0 then
m.da.ix.sqlType = 448 + (m.da.ix.sqlType // 2) */
return
endProcedure sqlDataSet
/*--- prepare, declare open cursor 'c'cx, fetch all and close
return number of rows fetched ----------------------------------*/
sqlPreAllCl:
parse arg ggCx, ggSrc, st, ggVars
ggRes = sqlPreDeclare(ggCx, ggSrc)
if ggRes >= 0 then
return sqlOpAllCl(ggCx, st, ggVars)
return ggRes
endProcedure sqlPreAllCl
/*--- execute statement 's'cx using arguments arg(2), arg(3)... ------*/
sqlExecute:
parse arg ggCx ggRetOk /* no , for ggRetOk, arg(2) is used already| */
do ggAx=2 to arg()
call sqlDataSet 'SQL.'ggCx'.I', ggAx-1, arg(ggAx)
end
return sqlExec('execute s'ggCx 'using descriptor :M.SQL.'ggCx'.I',
, ggRetOk)
endProcedure
/*--- execute immediate the sql src ----------------------------------*/
sqlExImm:
parse arg ggSrc, ggRetOk
return sqlExec('execute immediate :ggSrc', ggRetOk)
endProcedure sqlExImm
sqlCommit: procedure expose m.
parse arg src
return sqlExec('commit')
endProcedure sqlCommit
/*--- execute sql thru the dsnRexx interface -------------------------*/
sqlExec: /* no procedure, to keep variables sql... */
parse arg ggSqlStmt, ggRetOk, ggNo
if ggNo <> '1' then
ggSqlStmt = 'execSql' ggSqlStmt
address dsnRexx ggSqlStmt
/* say 'sqlCode' sqlCode 'rc' rc 'for' ggSqlStmt ggNo */
if rc = 0 then
return 0
if ggRetOk = '' then
ggRetOk = m.sqlRetOk
if wordPos(rc, '1 -1') < 0 then
call err 'dsnRexx rc' rc sqlmsg()
else if pos('*', ggRetOk) > 0 | wordPos(sqlCode, ggRetOk) > 0 ,
then do
if sqlCode < 0 & pos('say', ggRetOk) > 0 then
say 'sqlError' sqlmsg()
return sqlCode
end
else if rc < 0 then
call err sqlmsg()
else if sqlCode <> 0 | (pos('w',ggRetOk)<1 & sqlWarn.0^==' ') then
call errSay sqlMsg(), ,'w'
return sqlCode
endSubroutine sqlExec
/*--- connect to the db2 subsystem sys -----------------------------*/
sqlConnect: procedure expose m.
parse upper arg sys, retOk
call sqlIni
address tso "SUBCOM DSNREXX"
if rc <> 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
if sys = '-' then
return 0
res = sqlExec("connect" sys, retOk ,1)
if res >= 0 then
m.sql.connected = sys
return res
endProcedure sqlConnect
/*--- diconnect from db2 ---------------------------------------------*/
sqlDisconnect: procedure expose m.
parse arg retOk
m.sql.connected = ''
return sqlExec("disconnect ", retOk, 1)
endProcedure sqlDisconnect
/*--- connect and/or disconnect to DB2 -------------------------------*/
sqlConDis: procedure expose m.
parse upper arg sys, retOk
if sys \== '' then
nop
else if sysvar(sysnode) == 'RZ1' then
sys = 'DBAF'
else
call err 'no default subsys for' sysvar(sysnode)
call sqlIni
if sys == m.sql.connected then
return 0
if m.sql.connected \== '' then
call sqlDisconnect
if sys = '-' then
return 0
return sqlConnect(sys, retOk)
endProcedure sqlConDis
/*--- push and pop currently accepted sqlCodes -----------------------*/
sqlPushRetOk: procedure expose m.
parse arg rr
nx = m.sqlRetOk.0 + 1
m.sqlRetOk.0 = nx
m.sqlRetOk.nx = rr
m.sqlRetOk = rr
return
endProcedure sqlPushRetOk
sqlPopRetOk: procedure expose m.
nx = m.sqlRetOk.0 - 1
if nx < 1 then
call err 'sqlPopRetOk with .0' m.sqlRetOk.0
m.sqlRetOk = m.sqlRetOk.nx
m.sqlRetOk.0 = nx
return
endProcedure sqlPopRetOk
/*--- issue an sql error message -------------------------------------*/
sqlMsg: /* no procedure, to keep variables sql... */
ggRes = ''
if \ dataType(sqlCode, 'n') then do
ggRes = 'sqlCode' sqlCode 'not numeric\n'sqlMsgCa()
end
else do
signal on syntax name sqlMsgOnSyntax
if m.sqlMsgCodeT == 1 then
ggRes = 'sqlCode' sqlCodeT(sqlCode, sqlErrMc, sqlwarn.0':' ,
|| sqlwarn.1||sqlwarn.2||sqlwarn.3||sqlwarn.4||sqlwarn.5',',
|| sqlwarn.6||sqlwarn.7||sqlwarn.8||sqlwarn.9||sqlwarn.10)
if 0 then
sqlMsgOnSyntax: do
ggRes = sqlMsgCa(),
'\n<<rexx sqlCodeT not found or syntax>>'
end
signal off syntax
if m.sqlMsgDsnTiar == 1 then do
ggRes = ggRes || sqlDsntiar()
ggWa = sqlMsgWarn(sqlWarn)
if ggWa \= '' then
ggRes = ggRes'\nwarnings' ggWa
end
if m.sqlMsgCa == 1 then
ggRes = ggRes'\n'sqlMsgCa()
end
ggSqlSp = ' ,:+-*/&%?|()¢!'
ggXX = pos(':', ggSqlStmt)+1
do ggSqlVx=1 to 12 while ggXX > 1
ggYY = verify(ggSqlStmt, ggSqlSp, 'm', ggXX)
if ggYY < 1 then
ggYY = length(ggSqlStmt) + 1
ggSqlVa.ggSqlVx = substr(ggSqlStmt, ggXX, ggYY - ggXX)
do ggQQ = ggXX-2 by -1 to 1 ,
while substr(ggSqlStmt, ggQQ, 1) == ' '
end
do ggRR = ggQQ by -1 to 1 ,
while pos(substr(ggSqlStmt, ggRR, 1), ggSqlSp) < 1
end
if ggRR < ggQQ & ggRR > 0 then
ggSqlVb.ggSqlVx = substr(ggSqlStmt, ggRR+1, ggQQ-ggRR)
else
ggSqlVb.ggSqlVx = ''
ggXX = pos(':', ggSqlStmt, ggYY+1) + 1
end
ggSqlVa.0 = ggSqlVx-1
if datatype(sqlErrd.5, 'n') & sqlErrd.5 > 0 then do
ggW2 = translate(word(ggSqlStmt, 2))
ggW3 = translate(word(ggSqlStmt, 3))
if ggW2 == 'PREPARE' then
ggRes = ggRes || sqlMsgSrF('FROM')
else if ggW2 ggW3 == 'EXECUTE IMMEDIATE' then
ggRes = ggRes || sqlMsgSrF(1)
else
ggRes = ggRes || sqlMsgSrF()
end
ggRes = ggRes'\nstmt = ' ggSqlStmt
ggPref = '\nwith'
do ggXX=1 to ggSqlVa.0
ggRes = ggRes || ggPref ggSqlVb.ggXX ':'ggSqlVa.ggXX ,
'=' value(ggSqlVa.ggXX)
ggPref = '\n '
end
if abbrev(ggRes, '\n') then
return substr(ggRes, 3)
return ggRes
endSubroutine sqlMsg
sqlMsgSrF:
parse arg ggF
if ggF \== '' & \ datatype(ggF, 'n') then do
do ggSqlVx=1 to ggSqlVa.0
if translate(ggSqlVb.ggSqlVx) = ggF then
return sqlMsgSrc(value(ggSqlVa.ggSqlVx), sqlErrd.5)
end
end
if datatype(ggF, 'n') & ggF <= ggSqlVa.0 then
return sqlMsgSrc(value(ggSqlVa.ggF), sqlErrd.5)
return sqlMsgSrc(ggSqlStmt , sqlErrd.5)
endSubroutine sqlMsgSrF
/*--- use dsnTiar to translate sql Info to error text ----------------*/
sqlDsnTiar:
sqlWarn = sqlWarn.0 || sqlWarn.1 || sqlWarn.2 || sqlWarn.3,
|| sqlWarn.4 || sqlWarn.5 || sqlWarn.6 || sqlWarn.7,
|| sqlWarn.8 || sqlWarn.9 || sqlWarn.10
if sqlCode = -438 then
return '\nSQLCODE = -438:',
'APPLICATION RAISED ERROR WITH sqlState' sqlState,
'and DIAGNOSTIC TEXT:' sqlErrMc
if digits() < 10 then
numeric digits 10
sqlCa = d2c(sqlCode, 4) ,
|| d2c(max(70, length(sqlErrMc)), 2)left(sqlErrMc, 70) ,
|| left(sqlErrP, 8) ,
|| d2c(sqlErrD.1, 4)d2c(sqlErrD.2, 4)d2c(sqlErrD.3, 4) ,
|| d2c(sqlErrD.4, 4)d2c(sqlErrD.5, 4)d2c(sqlErrD.6, 4) ,
|| sqlWarn || sqlState
if length(sqlCa) <> 124 then
call err 'sqlDa length' length(sqlCa) 'not 124' ,
'\nsqlCa=' sqlMsgCa()
return sqlDsnTiarCall(sqlCa)
/*--- call dsnTiar o translate sql Info to error text ----------------*/
sqlDsnTiarCall: procedure expose m.
parse arg ca
liLe = 78
msLe = liLe * 10
if length(ca) <> 124 then
call err 'sqlDa length' length(ca) 'not 124:' ca', hex='c2x(ca)
ca = 'SQLCA ' || d2c(136, 4) || ca
msg = d2c(msLe,2) || left('', msLe)
len = d2c(liLe, 4)
ADDRESS LINKPGM "DSNTIAR ca msg LEN"
if rc <> 0 then
call err 'linkPgm dsnTiar rc' rc 'sqlCa' ca
res = ''
do c=3 by liLe to msLe
if c = 3 then do
l1 = strip(substr(msg, c+10, 68))
cx = pos(', ERROR: ', l1)
if cx > 0 then
l1 = left(l1, cx-1)':' strip(substr(l1, cx+9))
res = res'\n'l1
end
else if substr(msg, c, 10) = '' then
res = res'\n 'strip(substr(msg, c+10, 68))
else
leave
end
return res
endProcedure sqlDsnTiarCall
sqlMsgCa:
ggWarn = ''
do ggX=0 to 10
if sqlWarn.ggX \== ' ' then
ggWarn = ggWarn ggx'='sqlWarn.ggx
end
if ggWarn = '' then
ggWarn = 'none'
return 'sqlCode' sqlCode 'sqlState='sqlState,
'\n errMC='translate(sqlErrMc, ',', 'ff'x),
'\n warnings='ggWarn 'erP='sqlErrP,
'\n errD.1='sqlErrD.1 '2='sqlErrD.2 '3='sqlErrD.3,
'\n errD.4='sqlErrD.4 '5='sqlErrD.5 '6='sqlErrD.6
endProcedure sqlMsgCa
/*--- make the text for sqlWarnings
input warn.0..warn.10 as a 11 character string ------------*/
sqlMsgWarn: procedure expose m.
parse arg w0 2 wAll
if w0 = '' & wAll = '' then
return ''
if length(wAll) \= 10 | ((w0 = '') <> (wAll = '')) then
return 'bad warn' w0':'wAll
r = ''
text =' 1=W var truncated, 1=S scrollable, 1=N nonScrollable,' ,
'2=W nulls in aggregate,' ,
'3=W more cols than vars,' ,
'3=Z more result sets than locators,' ,
'4=W no where, 4=D sensitive dynamic, 4=I insensitive,' ,
'4=S sensitive static,' ,
'5=W not valid sql, 5=1 readOnly, 5=2 readDelete,' ,
'5=3 readDeleteUpdate,' ,
'6=W day changed to month range,' ,
'7=W dec digits truncated,' ,
'8=W char substituted,' ,
'9=W arith excep in count, 9=Z multipe result sets,' ,
'10=W char conversion err in ca,'
do wx = 1 to 10
w = substr(wAll, wx, 1)
if w = ' ' then
iterate
t = wx'='w
cx = pos(' 'wx'='w' ', text)
ex = pos(',' , text, cx + 1)
if cx < 1 then
r = r wx'='w '?,'
else
r = r substr(text, cx+1, ex-cx)
end
return strip(r, 't', ',')
endProcedure sqlMsgWarn
sqlMsgSrc: procedure expose m.
parse arg src, pos, opt
if 0 then do /* old version, before and after txt */
tLe = 150
t1 = space(left(src, pos), 1)
if length(t1) > tLe then
t1 = '...'right(t1, tLe-3)
t2 = space(substr(src, pos+1), 1)
if length(t2) > tLe then
t2 = left(t2, tLe-3)'...'
res = '\nsource' t1 '<<<error>>>' t2
end
liLe = 68
liCn = 3
afLe = 25
if translate(word(src, 1)) == 'EXECSQL' then
src = substr(src, wordIndex(src, 2))
t1 = space(left(src, pos), 1)
t2 = left(' ', substr(src, pos, 1) == ' ' ,
| substr(src, pos+1, 1) == ' ') ,
|| space(substr(src, pos+1), 1)
afLe = min(afLe, length(t2))
if length(t1) + afLe > liLe * liCn then
t1 = '...'right(t1, liLe * liCn - afLe -3)
else if length(t1)+length(t2) > liLe then
t1 = left(' ', (liCn * liLe - length(t1) -afLe) // liLe)||t1
pL = length(t1) // liLe
if length(t2) <= liLe-pL then
tx = t1 || t2
else
tx = t1 || left(t2, liLe-pL-3)'...'
res = '\nsrc' strip(substr(tx, 1, liLe), 't')
do cx=1+liLe by liLe to length(tx)
res = res || '\n +' strip(substr(tx, cx, liLe), 't')
end
loc = 'pos' pos 'of' length(src)
if length(loc)+6 < pL then
return res'\n >' right('>>>'loc'>>>', pL)
else
return res'\n >' left('', pL-1)'<<<'loc'<<<'
endProcdedur sqlMsgSrc
/*--- send a command to db2 through the TSO dsn processor ------------*/
sqlDsn: procedure expose m.
parse arg st, sys, cmd, rcOk
x = outtrap('M.'st'.')
push 'END'
push cmd
address tso 'DSN SYSTEM('sys')'
rr = rc
x = outtrap(off)
if rr = 0 | rcOk = '*' | wordPos(rr, rcOk) > 0 then
return rr
fl = max(1, m.st.0 - 10)
em = 'rc' rr 'for DSN SYSTEM('sys') cmd' cmd,
'\nOuputlines' fl '-' m.st.0':'
do lx=fl to m.st.0
em = em '\n' strip(m.st.lx, 't')
end
call err em
endProcedure sqlDsn
/* copy sql end **************************************************/
/* copy fmt begin **************************************************/
/*--- format the first arg by the format in the second ---------------*/
fmt: procedure
parse arg v, f 2 l
if abbrev('-', f) then
return v
else if f == 'l' then
return left(v, l)
else if f == 'r' then
return right(v, l)
else if f == 'f' then do
parse value l'.0.0.' with b '.' a '.' e '.'
return format(v, b, a, e, 0)
end
else if f == 'e' then do
parse var l b '.' a '.' e '.'
if b == '' then b = 2
if a == '' then a = 2
if e == '' then e = 2
res = format(v, b, a, e, 0)
y = length(res)-e-1
if substr(res, y) = '' then
return left(res, y-1)left('E', e+1, 0)
else if substr(res, y+1, 1) == '+' then
return left(res, y)substr(res, y+2)
else if substr(res, y+2, 1) == '0' then
return left(res, y+1)substr(res, y+3)
else
call err 'formatoverflow' f || l 'for' v '-->' res
end
else if f = 's' then
if l == '' then
return strip(v, 't')
else
return strip(v, l)
else if f == 'w' then do
parse var l st ',' le
return substr(v, st, le)
end
else
call err 'bad format' f l 'for' v
endProcedure fmt
/*--- format special (title, null Value also for numbers) ------------*/
fmtS: procedure expose m.
parse arg v, ty 2 l
if ty == 'f' then do
if \ dataType(v, 'n') then do
parse value l'.0.0.' with b '.' a '.' e '.'
return right(v, b + a + (a \== 0) + e + 2 * (e > 0))
end
end
else if ty == 'e' then do
if \ dataType(v, 'n') then do
parse var l b '.' a '.' e '.'
if b == '' then b = 2
if a == '' then a = 2
if e == '' then e = 2
return right(v, b + a + (a \== 0) + e + (e > 0))
end
end
return fmt(v, ty || l)
endProcedure fmtS
fmtTime: procedure expose m.
parse arg s, signed
return fmtUnits(s, 't', signed==1)
endProcedure fmtTime
fmtDec: procedure expose m.
parse arg s, signed
return fmtUnits(s, 'd', signed==1)
endProcedure fmtDec
fmtUnits: procedure expose m.
parse arg s, scale, signed
if s >= 0 then
res = fmtUnitsNN(s, scale, wi)
else
res = '-'fmtUnitsNN(abs(s), scale, wi)
len = m.fmt.units.scale.f.length + signed
if length(res) <= len then
return right(res, len)
if \ abbrev(res, '-') then
return right(right(res, 1), len, '+')
if length(res) = len+1 & datatype(right(res, 1), 'n') then
return left(res, len)
return right(right(res, 1), len, '-')
endProcedure fmtUnits
fmtUnitsNN: procedure expose m.
parse arg s, scale
sf = 'FMT.UNITS.'scale'.F'
sp = 'FMT.UNITS.'scale'.P'
if m.sf \== 1 then do
call fmtIni
if m.sf \== 1 then
call err 'fmtUnitsNN bad scale' scale
end
do q=3 to m.sp.0 while s >= m.sp.q
end
do forever
qb = q-2
qu = q-1
r = format(s / m.sp.qb, ,0)
if q > m.sf.0 then
return r || substr(m.sf.units, qb, 1)
if r < m.sf.q * m.sf.qu then
return (r % m.sf.qu) || substr(m.sf.units, qu, 1) ,
|| right(r //m.sf.qu, m.sf.width, 0)
/* overflow because of rounding, thus 1u000: loop back */
q = q + 1
end
endProcedure fmtUnitsNN
fmtIni: procedure expose m.
if m.fmt.ini == 1 then
return
m.fmt.ini = 1
call fmtIniUnits 't', '?smhd', 0 100 60 60 24 100, 0.01, 2
call fmtIniUnits 'd', '?.kMGTPE', 0 copies('1000 ',8), 0.001, 3
return
endProcedure fmtIni
fmtIniUnits: procedure expose m.
parse arg sc, us, fact, prod, wi
sf = 'FMT.UNITS.'sc'.F'
sp = 'FMT.UNITS.'sc'.P'
m.sf.0 = words(fact)
if length(us) + 1 <> m.sf.0 then
call err 'fmtIniUnits mismatch' us '<==>' fact
m.sf.1 = word(fact, 1)
m.sp.1 = prod
do wx=2 to m.sf.0
wx1 = wx-1
m.sf.wx = word(fact, wx)
m.sp.wx = m.sp.wx1 * m.sf.wx
end
m.sp.0 = m.sf.0
m.sf.units = us
m.sf.width = wi
m.sf.length= 2 * wi + 1
m.sf = 1
return
endProcedure fmtIniUnits
/* copy fmt end **************************************************/
/* copy map begin ******************************************************
a map stores values at keys
it may also maintain a list of keys
the basic ideas are similar to the java Interface java.util.Map
contrary to stems we also handle keys longer then 250 bytes
***********************************************************************/
/*--- initialize the module ------------------------------------------*/
mapIni: procedure expose m.
if m.map.ini = 1 then
return
m.map.ini = 1
call mIni
m.map.0 = 0
m.map.inlineSearch = 1
call mapReset map.inlineName, map.inline
return
endProcedure mapIni
mapInline: procedure expose m.
parse arg pName, opt
if mapHasKey(map.inlineName, pName) then do
im = mapGet(map.inlineName, pName)
if pos('l', opt) < 1 & symbol('m.im.0') \== 'VAR' then do
m.im.0 = m.im.lEnd - m.im.lBegin - 1
do ix=1 to m.im.0
m.im.ix = strip(sourceline(ix+m.im.lBegin), 't')
end
end
return im
end
name = '/'
do lx = m.map.inlineSearch to sourceline()
if \ abbrev(sourceline(lx), '$') then
iterate
li = sourceline(lx)
s1 = pos('/', li)+ 1
if s1 < 3 | s1 > 4 then
iterate
s2 = pos('/', li, s1)
if s2 <= s1 then
iterate
if s1 == 3 then do
if name \== substr(li, s1, s2-s1) then
iterate
im = 'MAP.INLINE.' || (m.map.inline.0+1)
call mapAdd map.inlineName, name, im
m.im.lBegin = lBeg
m.im.lEnd = lx
m.im.mark = mrk
if name == pName then do
m.map.inlineSearch = lx+1
return mapInline(pName)
end
name = '/'
end
else if \ mapHasKey(map.inlineName,
, substr(li, s1, s2-s1)) then do
lBeg = lx
mrk = substr(li, 2, s1-3)
name = substr(li, s1, s2-s1)
end
else do
name = '/'
end
end
if pos('r', opt) > 0 then
return ''
return err('no inline data /'pName'/ found')
endProcedure mapInline
/*--- create a new map ----------------------------------------------*/
mapNew: procedure expose m.
parse arg opt
m.map.0 = m.map.0 + 1
return mapReset('MAP.'m.map.0 , opt)
endProcedure mapNew
/*--- make an empty map, if opt <> '' maintain stem of keys
('K' in map.keys, '=' in a else in opt) --------------*/
mapReset: procedure expose m.
parse arg a, opt
if symbol('m.map.keys.a') == 'VAR' then
call mapClear a
if opt = '=' then
st = a
else if translate(opt) = 'K' then
st = 'MAP.KEYS.'a
else
st = opt
m.map.keys.a = st
if st \== '' then
m.st.0 = 0
return a
endProcedure
/*--- add a new key value pair to the map ----------------------------*/
mapAdd: procedure expose m.
parse arg a, ky, val
vv = mapValAdr(a, ky, 'a')
m.vv = val
return val
endProcedure mapAdd
/*--- change the value at a key or add key value ---------------------*/
mapPut: procedure expose m.
parse arg a, ky, val
vv = mapValAdr(a, ky, 'p')
m.vv = val
return val
endProcedure mapPut
/*--- return 1 if key ky exists in map a, 0 otherwise ----------------*/
mapHasKey: procedure expose m.
parse arg a, ky
return mapValAdr(a, ky) \== ''
endProcedure mapHasKey
/*--- return the value of key ky in map a if it exists,
else if called with a third argument return third argument
else issue an error ----------------------------------------*/
mapGet: procedure expose m.
parse arg a, ky
vv = mapValAdr(a, ky)
if vv \== '' then
return m.vv
else if arg() > 2 then
return arg(3)
else
return err('missing key in mapGet('a',' ky')')
endProcedure mapGet
/*--- return a stem of all keys --------------------------------------*/
mapKeys: procedure expose m.
parse arg a
if m.map.keys.a == '' then
call err 'mapKeys('a') with no keys'
return m.map.keys.a
endProcedure mapKeys
/*--- remove a key from the map, do nothing if it is missing ---------*/
mapRemove: procedure expose m.
parse arg a, ky
vv = mapValAdr(a, ky)
if vv == '' then
return ''
if m.map.keys.a \== '' then do
trace ?R /* not tested yet ???wkTest */
k = m.map.keys.a
mx = m.k.0
do i=1 to mx
if m.k.i == ky then do
m.k.i = m.k.mx
m.k.0 = mx - 1
return
end
end
end
val = m.vv
drop m.a.ky
return val
endProcedure mapRemove
/*--- remove all entries ---------------------------------------------*/
mapClear: procedure expose m.
parse arg a
st = mapKeys(a)
liLe = 243 - length(a)
do kx=1 to m.st.0
ky = m.st.kx
drop m.st.kx
if length(ky) <= liLe then do
drop m.a.ky
end
else do
adr = mapValAdr(a, ky)
if adr \== '' then do
ha = left(adr, lastPos('.', adr) - 3)
do i = 1 to m.ha.k.0
drop m.ha.k.i m.ha.v.i
end
drop m.ha.k.0
end
end
end
m.st.0 = 0
return a
endProcedure mapClear
/*--- return the value pointer for a key, '' if non existing
with fun = 'a' add a key, with 'p' put a key ------------*/
mapValAdr: procedure expose m.
parse arg a, ky, fun
if length(ky) + length(a) <= 243 then do
res = a'.'ky
if symbol('m.res') == 'VAR' then do
if fun == 'a' then
call err 'duplicate key' ky 'in map' a
return res
end
else if fun == '' then
return ''
end
else do
len = 243 - length(a)
q = len % 4
ha = a'.'left(ky, len - 2 * q) || substr(ky,
, (length(ky)-len) % 2 + 2 * q, q) || right(ky, q)
if symbol('M.ha.k.0') == 'VAR' then do
do i=1 to m.ha.k.0
if m.ha.k.i == ky then do
if fun == 'a' then
call err 'duplicate key' ky ,
'map' a 'hash' ha'.K.'i
return ha'.V.'i
end
end
end
else do
i = 1
end
if fun == '' then
return ''
if i > 9 then
call err 'overflow long key' y 'in map' a 'hash' ha'.K.'i
m.ha.k.0 = i
m.ha.k.i = ky
res = ha'.V.'i
end
if m.map.keys.a \== '' then
call mAdd m.map.Keys.a, ky
m.res = ''
return res
endProcedure mapValAdr
/* copy map end *******************************************************/
/* copy m begin ********************************************************
we use variables as follows
m. stem m: all global data and object data that must survive
a procedure call (m for memory in Memoria of B5000)
m.<mbr>.** to avoid conflicts: every rexx Module (copy) should
only allocate addresses m.<mbr>.** with <mbr> the name of
the rexx module
we pass parameters around (e.g. a=address, m=memory, st=stem)
and the called function may use m.a or m.a.subField etc.
gg*: local variable in subroutines without procedure
everything else: temporary data within procedure
every subroutine is declared as procedure expose m.
(also if no m. variable is used, because e.g. of error handling)
the few subroutines that cannot use procedure, should use only
variables starting with gg
***********************************************************************/
/*---make an area -----*/
mNewArea: procedure expose m.
parse arg nm, adr, newCd, freeCd
m.m.area.0 = m.m.area.0 + 1
a = 'M.AREA.'m.m.area.0
if adr == '=' then
adr = nm
else if adr == '' then
adr = 'M.'m.m.area.0
if symbol('m.m.n2a.adr') == 'VAR' then
call err 'adr' adr 'for area' nm 'already used'
m.m.n2a.adr = a
call mAlias adr, nm
m.m.p2a.adr = a
m.a.0 = 0
m.a.free.0 = 0
m.a.address = adr
m.a.newCode = newCd
m.a.freeCode = freeCd
return nm
endProcedure mNewArea
mAlias: procedure expose m.
parse arg oldNa, newNa
if symbol('m.m.n2a.oldNa') \== 'VAR' then
call err 'area' oldNa 'does not exist'
if oldNa == newNa then
return
if symbol('m.m.n2a.newNa') == 'VAR' then
call err 'newName' newNa 'for old' oldNa 'already used'
m.m.n2a.newNa = m.m.n2a.oldNa
return
endProcedure mAlias
mBasicNew: procedure expose m. ggArea
parse arg name
if symbol('m.m.n2a.name') \== 'VAR' then
call err 'area' name 'does not exists'
ggArea = m.m.n2a.name
if m.ggArea.free.0 > 0 then do
fx = m.ggArea.free.0
m.ggArea.free.0 = fx-1
m = m.ggArea.free.fx
end
else do
m.ggArea.0 = m.ggArea.0 + 1
m = m.ggArea.address'.'m.ggArea.0
end
return m
endProcedure mBasicNew
mNew: procedure expose m.
labelMNew:
parse arg name, arg, arg2, arg3
m = mBasicNew(name)
interpret m.ggArea.newCode
return m
endProcedure mNew
mReset: procedure expose m.
parse arg a, name
ggArea = m.m.n2a.name
m = a
interpret m.ggArea.newCode
return m
endProcedure mReset
mFree: procedure expose m.
parse arg m
p = 'M.P2A.'left(m, lastPos('.', m)-1)
area = m.p
if m.area.freeCode \== '' then
interpret m.area.freeCode
fx = m.area.free.0 + 1
m.area.free.0 = fx
m.area.free.fx = m
return
endProcedure mFree
/*--- iterate over all allocate elements of an area ------------------*/
mIterBegin: procedure expose m.
parse arg nm
a = m.m.n2a.nm
return m.a.address'.0'
endProcedure mIterBegin
mIter: procedure expose m.
parse arg cur
if cur == '' then
return ''
lx = lastPos('.', cur)
p = 'M.P2A.'left(cur, lx-1)
a = m.p
ix = substr(cur, lx+1)
do ix=ix+1 to m.a.0
n = m.a.address'.'ix
do fx=1 to m.a.free.0 while m.a.free \== n
end
if fx > m.a.free.0 then
return n
end
return ''
endProcedure mIter
/*--- cut stem a to length len ---------------------------------------*/
mCut: procedure expose m.
parse arg a, len
m.a.0 = len
return a
endProcedure mCut
/*--- add one or several arguments to stem m.a -----------------------*/
mAdd: procedure expose m.
parse arg a
ix = m.a.0
do ax = 2 to arg()
ix = ix + 1
m.a.ix = arg(ax)
end
m.a.0 = ix
return a'.'ix
endProcedure mAdd
/*--- pop last element from stem m.a ---------------------------------*/
mPop: procedure expose m.
parse arg a
ix = m.a.0
if ix < 1 then
call err 'pop from empty stem' a
m.a.0 = ix-1
return m.a.ix
endProcedure mPop
/*--- add to m.dst.* a (sub)sequence of m.src.* ----------------------*/
mAddSt: procedure expose m.
parse arg dst, src
dx = m.dst.0
do sx = 1 to m.src.0
dx = dx + 1
m.dst.dx = m.src.sx
end
m.dst.0 = dx
return
endProcedure mAddSt
/*--- find position of first occurrence of ele in stem m,
return 0 if nonemove a part of a stem -----------------------*/
mPos: procedure expose m.
parse arg m, ele, sx
if sx == '' then
sx = 1
do x=sx to m.m.0
if m.m.x = ele then
return x
end
return 0
endProcedure mPos
/*--- move a part of a stem ------------------------------------------*/
mMove: procedure expose m.
parse arg m, sx, dx
if dx < sx then do
y = dx
do x=sx to m.m.0
m.m.y = m.m.x
y = y + 1
end
end
else if dx > sx then do
y = m.m.0 + dx - sx
do x=m.m.0 by -1 to sx
m.m.y = m.m.x
y = y - 1
end
end
m.m.0 = m.m.0 + dx - sx
return
endProcedure mMove
/*--- insert a stem into another ------------------------------------*/
mInsert: procedure expose m.
parse arg m, tx, st
call mMove m, tx, tx+m.st.0
do sx=1 to m.st.0
dx = tx-1+sx
m.m.dx = m.st.sx
end
return
endProcedure mInsert
/*--- strip all elements of a stem -----------------------------------*/
mStrip: procedure expose m.
parse arg st, opt
if opt == '' then
opt = 'b'
do x=1 to m.st.0
m.st.x = strip(m.st.x, opt)
end
return st
endProcedure mStrip
/*--- cat all elements of a stem together ----------------------------*/
mCat: procedure expose m.
parse arg st, mid
if m.st.0 < 1 then
return ''
res = m.st.1
do x=2 to m.st.0
res = res || mid || m.st.x
end
return res
endProcedure mCat
mIni: procedure expose m.
if m.m.ini = 1 then
return
m.m.ini = 1
m.mAlfLC = 'abcdefghijklmnopqrstuvwxyz'
m.mAlfUC = translate(m.mAlfLC)
m.mAlfa = m.mAlfLC || m.mAlfUC
m.mAlfNum = m.mAlfa || '0123456789'
m.mAlfDot = m.mAlfNum || '.'
m.m.area.0 = 0
call mNewArea
return
endProcedure mIni
/* copy m end *********************************************************/
/* copy adrTso begin *************************************************/
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet ---*/
adrTso:
parse arg ggTsoCmd, ggRet
address tso ggTsoCmd
if rc == 0 then return 0
else if ggRet == '*' then return rc
else if wordPos(rc, ggRet) > 0 then return rc
else
call err 'adrTso rc' rc 'for' ggTsoCmd
return /* end adrTso */
/*--- format dsn from tso format to jcl format -----------------------*/
dsn2jcl: procedure expose m.
parse upper arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
cx = pos('~', dsn)
if cx < 1 & addPrefix == 1 then
return sp'.'dsn
do while cx \== 0
le = left(dsn, cx-1)
ri = substr(dsn, cx+1)
if right(le, 1) == '.' | left(ri, 1) == '.' then
dsn = le || sp || ri
else
dsn = le || left('.', le \== '') || sp ,
|| left('.', ri \== '') || ri
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
parse arg dsn, mbr
bx = pos('(', dsn)
if bx > 0 then
dsn = strip(left(dsn, bx-1))
if mbr <> '' then
dsn = dsn'('strip(mbr)')'
return dsn
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn
lx = pos('(', dsn)
rx = pos(')', dsn, lx+1)
if lx < 1 then
return ''
else if lx < rx then
return substr(dsn, lx+1, rx-lx-1)
else
return strip(substr(dsn,lx+1))
endProcedure dsnGetMbr
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: readDDBegin, readDD*, readDDEnd
write: writeBegin, writeDD*, writeEnd
readDD returns true if data read, false at eof
***********************************************************************/
/*--- prepare reading from a DD --------------------------------------*/
readDDBegin: procedure expose m.
parse upper arg ggDD
call errAddCleanup 'call readDDEnd' ggDD', "*"'
return /* end readDDBegin */
/*--- read from DD ggDD into ggSt, return false at eof ---------------*/
readDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskr' ggDD '(stem' ggSt')', 2
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- finish reading DD ggDD ----------------------------------------*/
readDDEnd: procedure expose m.
parse upper arg ggDD, ggRet
call errRmCleanup 'call readDDEnd' ggDD', "*"'
return adrTso('execio 0 diskr' ggDD '(finis)', ggRet)
endProcedure readDDEnd
/*--- prepare writing to DD ggDD -------------------------------------*/
writeDDBegin: procedure expose m.
parse upper arg ggDD
/* ensure file is erased, if no records are written */
call adrTso 'execio' 0 'diskw' ggDD '(open)'
call errAddCleanup 'call writeDDEnd' ggDD', "*"'
return /* end writeDDBegin */
/*--- write to gg ggDD from stem ggSt, ggCnt records -----------------*/
writeDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt == '' then
ggCnt = value(ggst'0')
call adrTso 'execio' ggCnt 'diskw' ggDD '(stem' ggSt')'
return
endSubroutine writeDD
/*--- end writing to dd ggDD (close) --------------------------------*/
writeDDEnd: procedure expose m.
parse upper arg ggDD, ggRet
call errRmCleanup 'call writeDDEnd' ggDD', "*"'
return adrTso('execio 0 diskw' ggDD '(finis)', ggRet)
endProcedure writeDDEnd
/*--- readNx: read next line, using buffer ---------------------------*/
/*--- begin: allocate dsnSpec and ini ------------------------ -------*/
readNxBegin: procedure expose m.
parse arg m, m.m.dsn, m.m.dd, m.m.Cnt
if m.m.dd = '' then
m.m.dd = 'DDNX'
if m.m.cnt = '' then
m.m.cnt = 1000
m.m.cx = m.m.cnt + 999
m.m.buf0x = 0
m.m.0 = 0
call dsnAlloc 'dd('m.m.dd')' m.m.dsn
call readDDBegin m.m.dd
return m
endProcedure readDDNxBegin
/*--- return the stem of the next line, or '' at end -----------------*/
readNx: procedure expose m.
parse arg m
ix = m.m.cx + 1
m.m.cx = ix
if m.m.cx <= m.m.0 then
return m'.'ix
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 position (line number) of reader
plus le characters of the current line (default 50) ------*/
readnxPos: procedure expose m.
parse arg m, le
li = m'.'m.m.cx
li = strip(m.li, 't')
if arg() < 2 then
le = 50
if le < 1 then
li = ''
else if length(li) <= le then
li = ':' li
else
li = ':' left(li, le-3)'...'
return 'line' (m.m.buf0x + m.m.cx)li
endProcedure readnxPos
/*--- close and deallocate ------------------------------------------*/
readNxEnd: procedure expose m.
parse arg m
call readDDEnd m.m.dd
call tsoFree m.m.dd
return
endProcedure readDDNxEnd
/*--- standardise a dsn spec
word1 dsName or -
word2 dd or -
word3 disp or -
word4 to first : attributes in tso format
after first : attributes for new allocation
----------------------------------------------------------------------*/
dsnSpec: procedure expose m.
parse upper arg spec
rr = '' /* put leading - in separate words */
do sx=1 while words(rr) < 3 & wx \= ''
wx = word(spec, sx)
do while abbrev(wx, '-') & words(rr) < 3
wx = substr(wx, 2)
rr = rr '-'
end
rr = rr wx
end
spec = rr subWord(spec, sx)
na = ''
dd = ''
di = ''
if left(spec, 1) = '&' then /* external spec is handled ok */
spec = strip(substr(spec, 2))
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, '.') | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
di = w
else if w = 'CATALOG' then
di = di w
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
na = strip(substr(w, 5, length(w)-5))
else if na == '' then
na = dsn2jcl(w)
else if dd == '' then
dd = w
else if di == '' then
di = w
else
leave
end
if na == '' then
na = '-'
else if abbrev(na, "'") then
na = substr(na, 2, length(na)-2)
if dd == '' then dd = '-'
if di == '' then di = '-'
re = subword(spec, wx)
if abbrev(re, '.') then
re = substr(re, 2)
return na dd di re
endProcedure dsnSpec
/*--- alloc a dsn with dsnAlloc
if the dsn is inuse wait and retry
until either the allocation is successfull
or the timeout occurs --------------------------------------*/
dsnAllocWait: procedure expose m.
parse upper arg spec, pDi, pDD, timeOut
x = max(1, arg() - 1)
do rt=0
m.adrTsoAl.1 = ''
m.adrTsoAl.2 = ''
m.adrTsoAl.3 = ''
call outtrap m.adrTsoAl.
res = dsnAlloc(spec, pDi, pDD, '*')
call outtrap off
if \ abbrev(res, ' ') then
return res
msg = m.adrTsoAl.1'\n'm.adrTsoAl.2'\n'm.adrTsoAl.3
if rt > timeOut & timeOut \== '' then
return err('timeout allocating' spec time() '\n'msg)
if pos('DATA SET IS ALLOCATED TO ANOTHER', msg) < 1 then
return err('allocating' spec'\n'msg)
say time() 'sleep and retry alloc' spec
call sleep 1, 0
end
endProcedure dsnAllocWait
/*--- alloc a dsn or a dd
spec '-'<ddName>
datasetName? disposition? '.'? attributes? (':' newAtts)?
disp default disposition
dd default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc -----*/
dsnAlloc: procedure expose m.
parse upper arg spec, pDi, pDD, retRc
parse value dsnSpec(spec) with na dd di rest
if na = '-' then
m.dsnAlloc.dsn = ''
else
m.dsnAlloc.dsn = na
if na == '-' & dd \== '-' & di == '-' & rest = '' then
return dd
if dd == '-' & pDD \== '' then
dd = pDD
if dd == '-' then do
if symbol('m.adrTso.ddNum') = 'VAR' then
dd = m.adrTso.ddNum + 1
else
dd = 1
m.adrTso.ddNum = dd
dd = 'DD' || dd
end
if di = '-' & pDi \== '' then
di = pDi
if di = '-' then
di = 'SHR'
else if pos('(', na) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if pos('/', na) > 0 then
return csmAlloc(na dd di rest, retRc)
else
return tsoAlloc(na dd di rest, retRc)
endProcedure dsnAlloc
tsoAlloc: procedure expose m.
parse arg na dd disp rest ':' nn, retRc
c = 'alloc dd('dd')' disp
if na \== '-' then
c = c "DSN('"na"')"
else if disp = 'NEW' and nn \== '' then
c = c dsnCreateAtts(,nn)
call outtrap m.adrTsoAl.
alRc = adrTso(c rest, '*')
call outtrap off
if alRc = 0 then do
call errAddCleanup 'call tsoFree' dd', "*"'
return dd 'call tsoFree' dd';'
end
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& sysDsn("'"m.dsnAlloc.dsn"'") == 'DATASET NOT FOUND' then do
say 'tsoAlloc creating' c rest ':'nn
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na dd disp rest, retRc)
end
do ax=1 to m.adrTsoAl.0
say m.adrTsoal.ax
end
if retRc = '*' | wordPos(alRc, retRc) > 0 then
return ' ' alRc
call err 'tsoAlloc rc' alRc 'for' c rest
endProcedure tsoAlloc
tsoAtts: procedure expose m.
parse arg dsn
rc = listDsi("'"dsn"' SMSINFO")
if rc = 0 then
mv = ''
else if rc = 4 & sysReason = 19 then do
mv = 'UNITCNT(30)'
say 'multi volume' mv
end
else if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
al = 'CAT'
al = ''
if right(sysDsSms, 7) == 'LIBRARY' ,
| abbrev(sysDsSms, 'PDS') then
al = al 'DSNTYPE(LIBRARY)'
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
al = al "DSORG("sysDSorg") MGMTCLAS("sysMgmtClass")",
"DATACLAS("sysDataClass")" ,
"RECFM("translate('1 2 3', ' 'sysREcFM, ' 123')")",
"LRECL("SYSLRECL")",
"blksize("sysBLkSIZE")",
"SPACE("sysPrimary"," sysSeconds")" sysUnits mv
return al
endProcedure tsoAtts
tsoFree: procedure expose m.
parse arg dd, ggRet
call adrTso 'free dd('dd')', ggRet
call errRmCleanup 'call tsoFree' dd', "*"'
return
endProcedure tsoFree
dsnCreateAtts: procedure expose m.
parse arg dsn, atts, forCsm
forCsm = forCsm == 1
aU = ' 'translate(atts)
if abbrev(atts, ':') then do
parse var atts a1 atts
bl = 32760
rl = substr(a1, 3)
if abbrev(a1, ':F') then do
if rl = '' then
rl = 80
recfm='f b'
bl = bl - (bl // rl)
end
else do
if rl = '' then
rl = bl-4
recfm = substr(a1, 2, 1) 'b'
end
if forCsm then
atts = atts "recfm("space(recfm, 0)") lrecl("rl")",
"blkSize("bl")"
else
atts = atts "recfm("recfm") lrecl("rl") block("bl")"
end
if pos('(', dsn) > 0 & pos(' DSNTYPE(', aU) < 1 ,
& pos(' DSORG(', aU) < 1 then
atts = atts 'dsntype(library) dsorg(po)'
if pos(' MGMTCLAS(', aU) < 1 then
atts = atts 'mgmtclas(COM#A091)'
if pos(' SPACE(', aU) < 1 then
if forCsm then
atts = atts 'space(10, 1000) cylinder'
else
atts = atts 'space(10, 1000) cyl'
if dsn == '' then
return atts
return "dataset('"dsnSetMbr(dsn)"')" atts
endProcedure dsnCreateAtts
/*--- read the dataset specified in ggDsnSpec to stem ggSt -----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
interpret subword(ggAlloc, 2)
return
endSubroutine readDsn
/*--- write the dataset specified in ggDsnSpec from stem ggSt
write ggCnt records if not empty otherwise ggst0
if ggSay 1 then say ... records written to ... -------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'open finis)'
interpret subword(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
copyDSN: procedure expose m.
parse arg frSpec, toSpec, ggSay
frDD = dsnAlloc(frSpec, 'SHR', 'FRDD')
toDD = dsnAlloc(toSpec, 'OLD', 'TODD')
call readDDBegin word(frDD, 1)
call writeDDBegin word(toDD, 1)
cnt = 0
do while readDD(word(frDD, 1), r.)
call writeDD word(toDD, 1), r.
cnt = cnt + r.0
end
call readDDEnd word(frDD, 1)
call writeDDEnd word(toDD, 1)
interpret ';' subword(frDD, 2) '; ; ;' subword(toDD, 2)
if ggSay == 1 | m.debug == 1 then
say cnt 'records copied from' frSpec 'to' to toSpec
return
endSubroutine writeDsn
/* copy adrTso end ****************************************************/
/* copy err begin ******************************************************
messages, errorhandling,help
***********************************************************************/
errIni: procedure expose m.
if m.err.ini == 1 then
return
call outIni
m.err.ini = 1
m.err.handler = ''
m.err.cleanup = ';'
m.err.opt = ''
return
endProcedure errIni
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err.opt, m.err.handler
if pos('I', translate(m.err.opt)) > 0 then
if errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
call adrIsp 'control errors return'
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
call errIni
drop err handler cleanup opt call return
if ggOpt == '' & m.err.handler \== '' then do
if 1 then do /* no detection of recursive err call loop
--> will anyway fail by stack overflow */
interpret m.err.handler
end
else do
/* avoid recursive err call loop */
drop call return
if symbol('m.err.call') \== 'VAR' then
m.err.call = 1
else
m.err.call = m.err.call + 1
if m.err.call > 10 then do
say 'errHandler loop:' m.err.handler
end
else do
m.err.return = 1
call errInterpret m.err.handler
m.err.call = m.err.call - 1
if m.err.return then
return result
end
end
end
call outPush
call errSay ggTxt, 'e'
call errCleanup
if ggOpt == '' then
ggOpt = m.err.opt
ggOpt = translate(ggOpt)
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 then do
call errSay 'divide by zero to show stackHistory', 'e'
x = 1 / 0
end
call errSay 'exit(12)', 'e'
exit errSetRc(12)
endSubroutine err
/*--- error routine: user message cleanup exit -----------------------*/
errEx:
parse arg ggTxt
call errIni
call outPush
call errSay ggTxt
call errCleanup
exit 8
endProcedure errEx
errAddCleanup: procedure expose m.
parse arg code
if m.err.ini \== 1 then
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
if m.err.ini \== 1 then
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
cl = m.err.cleanup
if cl = ';' then
return
m.err.cleanup = ';'
call out 'err cleanup begin' cl
call errInterpret cl
call out 'err cleanup end' cl
return
endProcedure errCleanup
errInterpret: procedure expose m.
parse arg code
interpret code
m.err.return = 0
return
endProcedure errInterpret
/*--- assert that the passed rexx expression evaluates to true -------*/
assert:
interpret 'assertRes =' arg(1)
if \ assertRes then
call err 'assert failed' arg(1)':' arg(2)
return
endProcedure assert
/*--- output an errorMessage msg with pref pref
split message in lines at '/n' ---------------------------*/
errSay: procedure expose m.
parse arg msg, pref
parse source . . ggS3 . /* current rexx */
if pref == 'e' then
msg = 'fatal error in' ggS3':' msg
else if pref == 'w' then
msg = 'warning in' ggS3':' msg
else if pref \== '' then
msg = pref':' msg
return outNl(msg)
endProcedure errSay
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg, op
call errSay msg, 'e'
call help
call err msg, op
endProcedure errHelp
/*--- return the Operating System we are running on: TSO or LINUX ---*/
errOS: procedure expose m.
parse source os .
return os
endProcedure errOS
/*--- set rc for ispf: -------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared varible 3IspfRc
back as return code
----------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- output a trace message if m.tr is set -----------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
call out 'debug' msg
return
endProcedure debug
/*--- display the first comment block of the source as help ----------*/
help: procedure expose m.
parse source . . s3 .
call out right(' help for rexx' s3, 79, '*')
do ax=1 to arg()
say ' ' arg(ax)
end
do lx=1 by 1
if pos('/*', sourceLine(lx)) > 0 then
leave
else if lx > 10 then do
call out '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
call out li
end
call out right(' end help for rexx' s3, 79, '*')
return 4
endProcedure help
/*--- output all lines (separated by '\n') of all args --------------*/
outNl: procedure expose m.
do ax=1 to max(1, arg())
msg = arg(ax)
sx = 0
bx = -1
do lx=1 until bx >= length(msg)
ex = pos('\n', msg, bx+2)
if ex < 1 then
ex = length(msg)+1
call out substr(msg, bx+2, ex-bx-2)
bx = ex
end
end
return 0
endProcedure outNl
/* copy err end *****************************************************/
/* copy out begin ******************************************************
out interface with simplistic implementation
***********************************************************************/
outIni: procedure expose m.
parse arg msg
if m.out.ini == 1 then
return
m.out.ini = 1
m.out.dst = ''
return
endProcedure outIni
/*--- output a message to the current destination -------------------*/
out: procedure expose m.
parse arg msg
if m.out.ini \== 1 then
call outIni
if m.out.dst == '' then do
say msg
end
else do
st = m.out.dst
sx = m.st.0 + 1
m.st.0 = sx
m.st.sx = msg
end
return 0
endProcedure out
/*--- push an out destination ---------------------------------------*/
outPush: procedure expose m.
parse arg m.out.dst
return
endProcedure outPush
/* copy out end *****************************************************/
/* copy ut begin *****************************************************/
/*--- if function warning all3 arguments get evaluated|
e.g if(x=0, 'infinity', 1/0) will fail| -----------*/
if: procedure expose m.
parse arg co, ifTrue, ifFalse
if co then
return ifTrue
else
return ifFalse
endProcedure if
/*--- embedded ASSignement:
assign the second argument to the variable with name in first arg
and return the value assigned ----------------------------------*/
ass:
call value arg(1), arg(2)
return arg(2)
/*--- embedded ASSignement only if NotNull:
assign the second argument to the variable with name in first arg
if the second arg is not null, return new value ---------------*/
assIf:
if arg(2) == '' then
return value(arg(1))
call value arg(1), arg(2)
return arg(2)
/*--- return first nonNull argument ---------------------------------*/
nn:
if arg(1) \== '' then
return arg(1)
if arg(2) \== '' then
return arg(2)
call err 'nn() both args empty'
/*--- embedded ASSignement return NotNull:
assign the second argument to the variable with name in first arg
and return 1 if value not null, 0 if null ----------------------*/
assNN:
call value arg(1), arg(2)
return arg(2) \== ''
/*--- return current time and cpu usage ------------------------------*/
timing: procedure expose m.
return return time() 'ela='time('E') 'cpu='sysvar('syscpu'),
'su='sysvar('syssrv')
timingTest: procedure expose m.
say 'begin' timing() sysvar('sysnode')
do 30000000
end
say 'end ' timing()
return
/*--- sleep several seconds ------------------------------------------*/
sleep: procedure expose m.
parse arg secs, sayIt
if sayit <> 0 then
say 'sleeping' secs 'secs' time()
CALL SYSCALLS 'ON'
ADDRESS SYSCALL "sleep" secs
CALL SYSCALLS 'OFF'
if sayit <> 0 then
say 'slept' secs 'secs' time()
return
endProcedure sleep
/*--- elongate inp with spaces up to given len -----------------------*/
elong: procedure expose m.
parse arg inp, len
if length(inp) >= len then
return inp
return left(inp, len)
endProcedure elong
/*--- quote string txt using quoteChar qu ("""" ==> ") ---------------*/
quote: procedure expose m.
parse arg txt, qu
if qu = '' then
qu = '"'
res = qu
ix = 1
do forever
qx = pos(qu, txt, ix)
if qx = 0 then
return res || substr(txt, ix) || qu
res = res || substr(txt, ix, qx-ix) || qu || qu
ix = qx + length(qu)
end
endProcedure quote
/*--- return the count of occurrences of needle in heyStack ----------*/
posCount: procedure expose m.
parse arg needle, hayStack, start, fin
if start = '' then
start = 1
if fin = '' then
fin = length(hayStack) + 1 - length(needle)
do cnt = 0 by 1
start = pos(needle, haystack, start)
if start < 1 | start > fin then
return cnt
start = start + length(needle)
end
endProcedure posCount
repAll: procedure expose m.
parse arg src, w, new
res = ''
cx = 1
do forever
nx = pos(w, src, cx)
if nx < 1 then
return res || substr(src, cx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAll
repAllWords: procedure expose m.
parse arg src, w, new
res = ''
wx = 0
cx = 1
do forever
wx = wordPos(w, src, wx+1)
if wx < 1 then
return res || substr(src, cx)
nx = wordindex(src, wx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAllWords
/* copy ut end ********************************************************/
}¢--- A540769.WK.REXX(REOCHEC0) cre=2013-09-16 mod=2013-09-16-16.54.37 A540769 ---
/* REXX **************************************************************
synopsis: reoCheck db fun
db = db2 subsystem
type = TS oder IX
function: db2 real time statistics für reorg anwenden:
1. preview der listdefs einlesen
2. listdefs einlesen
3. rts abfragen
4. neue listdef erstellen
5. *run* Tabellen mit History Infos fuellen
Tabellen und Views: siehe makeTableNames:
location: tso.rzx.p0.user.exec
docu: http://chsa4212/host/db2wiki/pmwiki.php?n=Main.RtsReo
history ***************************************************************
04.05.2012 v6.0 fix problem with multiple utilities for same type
**********/ /* end of help ********************************************
26.03.2012 v5.9 handle v9/v10 real time stats n
15.02.2012 v5.8 empty listdefs in v10 implementation
21.10.2011 v5.7 parallelism, undon insert tReoRunJob, new sql
7.02.2011 v5.61 fix Dupl. Abend on insert tReoRunJob, new sql
17.01.2011 v5.6 reOrder von v5.5
14.01.2011 v5.5 reFactoring und neue copies
30.11.2010 v5.41 fix tyInp in tReoRunJob
27.09.2010 v5.4 new name reoCheck, use s100447.?Reo* tb
24.09.2010 v5.3 split listdef by unCompressedDataSize limit
27.08.2010 v5.2 fix uncompressDatasize tsStatsFix in insertStats
29.07.2010 v5.1 fix ixSpae, namens Verschreiber
08.07.2010 v5.1 fix rngI0=-99
07.07.2010 v5.1 fix reoTimeLimite, StartAnzeige, checkRef err
06.07.2010 v5.1 jobException Table, Sort Limite, *run* history
09.12.2009 v5.0 weiterarbeiten wenn checkRef abstürzt
03.12.2009 v5.0 TS jetzt mit reoTime, die Grösse der
nicht Partitionierten Indexe berücksi.
23.04.2010 v4.4 reorg by part range für ts
falls partBis > für DB jJOB in Exc
08.09.2008 v4.3 vRtsReoIx.is fuer Indexspace
(nicht null bei fehlenden rts Daten)
21.08.2008 v4.2 vRtsReoIx.cr (statt .Creator) fuer V9
20.05.2008 v4.1 Bereinigung
10.04.2008 v4.0 Umstellung auf neue exception tabl/vws
04.12.2006 v2.3 Optimierung mit Gruppenbruch-Logik
20.11.2006 v2.21 RSU0610 bewirkt Meldung:
'insuff. operands for keyword listdef'
Neu wird leeres Member erstellt falls
keine Objekte die Schwellwerte erreich
10.04.2006 v2.2 pgm läuft auch ohne ispf (A234579)
Diagnose Statement erlaubt (A234579)
10.11.2005 v2.1 schwellwerte erweitert (A234579)
23.09.2005 v2.0 index mit rts-abfrage (A234579)
20.09.2005 v1.2 erweiterte abfrage auf noload repl
16.09.2005 v1.1 inkl.reorg index ohne rts (A234579)
25.10.2004 v1.0 grundversion (m.streit,A234579)
*******************************************************************/
m.debug = 0
parse upper arg ssid type
m.job = strip(MVSVAR('SYMDEF', 'JOBNAME'))
say "reoCheck Programmversion = 6.0 4.5.12 runTime" date('s') time()
say " DB2 Subsystem =" ssid
say " Job Name =" m.job
if ssid = '' | pos('?', ssid type) > 0 then
exit errHelp('fehlende Parameter:' ssid type)
call sqlConnect ssid
call makeTableNames ssid, 's100447'
call selectJobParms
say " Limiten"
say " Reo Zeit TS = " fmtTime(m.job.time.ts)
say " Reo Zeit IX = " fmtTime(m.job.time.ix)
say " unCompSizeI0 =" fmtDec(m.job.uncompI0) 'Bytes'
say " unCompSizeDef =" fmtDec(m.job.unCompDef) 'Bytes'
say " IX nach spaeter =" m.job.ixSpae
say " *Run* Stats =" m.job.stats
if m.runJob.tst = '' then
say " Last Run = nicht gefunden"
else
say " Last Run =" m.runJob.tst m.runJob.ty ,
"status" m.runJob.sta
if type = '' then do
type = 'TS'
say " kein Type gewählt, also TS-Reorg getriggert"
end
m.tyInp = type
if m.runJob.sta = 's' then do
if type = 'IX' & m.job.ixSpae = 't' then do
say " run" m.runJob.tst "mit spaeter typeChange auf TS"
type = "TS"
end
else if type = 'IX' & m.job.ixSpae = 'n' then do
say " run" m.runJob.tst "mit spaeter ==> STOP"
type = ''
end
else do
say " run" m.runJob.tst "mit spaeter"
end
end
m.ty = type
if type \== '' then
say " Type = "type
say ''
call errReset 'h'
call mapIni
call sqlIni
/* use adrTso, so we survive errors in reoRefSt */
call adrTso reoRefSt '-'ssid 'ref' 100 'staLevel' m.job.stats ,
'staJob' m.job, '*'
m.jobSta = 0
m.rngFi = 0
m.rngLa = 0
if type \== '' then do
call doreoCheck type, '-ddIn1', '-ddIn2', dsn4allocated('ddOUt1')
end
else do
o.1 = ' -- reoCheck' date('s') time() 'nicht nach spaeter'
call writeDsn ddOut1, 'O.', 1, 1
end
call sqlDisconnect
exit
/*--- main function
analyse utility preview sysprint
analyse utitlity ctl input
select Rts Infos and decide what to reorg
generate new utility ctrl cards ----------------------------*/
doReoCheck: procedure expose m.
parse arg doType, ddIn1, ddIn2, ddOut
m.lst.0 = 0
call analyzeSysprint lst, ddIn1
call debugLst lst, 'lists in sysprint'
m.ctl.0 = 0
call analyzeCtl ctl, ddIn2
call debugCtl ctl
typ1 = left(doType, 1)
do cx=1 to m.ctl.0
cc = ctl'.'cx
m.cc.list = ''
l1 = mapGet(lst'.N2L', m.cc.listName, '')
if l1 == '' then do
say '*** warning' m.cc.listName 'in ListDef,',
'aber nicht im SysPrint (leer?)'
end
else if word(m.l1.type, 1) ^== typ1 then do
call debug '*** warning list' m.l1.type m.l1.name ,
'nicht type' doType 'wird ignoriert'
end
else if m.l1.done == 1 then do
m.cc.list = l1
end
else do
m.cc.list = l1
m.l1.done = 1
call selectRts l1, doType
miss = ''
do ox = 1 to m.l1.0
if m.l1.ox.nm == '' then
miss = miss m.l1.ox.db'.'m.l1.ox.sp
end
if miss \== '' then
call err 'obj in sysprint fehlen in rts:'miss
rTi = makeRanges(l1, doType)
call reportReo l1, doType, rTi
end
end
call genCtl ddOut, ctl, doType
call insertStats lst, doType
return
endProcedure doReoCheck
/*--- view and tableNames, copy in reoRefSt --------------------------*/
makeTableNames: procedure expose m.
parse arg ssid, q
if q = 'OA1P' wordPos(ssid, 'DBAF DBTF DBZF DBLF') > 0 then
q = overlay(substr(ssid, 3, 1), q, 4)
r = q
m.rrTS = r".vReoTS"
m.rrIx = r".vReoIX"
m.dbSt = q".tDbState"
m.exJob = q".vReoJobParms"
m.ruJob = q".tReoRunJob"
m.ruPart = q".tReoRunPart"
m.ruTsSt = q".tReoRunTSStats"
m.ruIxSt = q".tReoRunIXStats"
m.ixStats= "sysibm.sysIndexSpaceStats"
m.tsStats= q".vReoTSStatsFix"
return
endProcedure makeTableNames
/*--- select job parameters from job parameter table -----------------*/
selectJobParms: procedure expose m.
if sqlPreAllCl( 9, "select",
"int(substr(max(prC2 || char(tsTime)), 3)),",
"int(substr(max(prC2 || char(ixTime)), 3)),",
"real(substr(max(prC2 || char(uncompDef)), 3)),",
"real(substr(max(prC2 || char(uncompI0 )), 3)),",
" substr(max(prC2 || char(ixSpae)), 3) ,",
" substr(max(prC2 || char(stats )), 3) ",
"from" m.exJob ,
"where left(job,jobLen) = left('"left(m.job,8)"', jobLen)",
, job, ":m.job.time.ts, :m.job.time.ix, :m.job.uncompDef," ,
":m.job.uncompI0, :m.job.ixSpae, :m.job.stats")<> 1 then
call err m.job.0 'rows from' m.exJob '\n'sqlMsg()
m.runJob.tst = ''
m.runJob.sta = ''
if sqlPreAllCl( 9, "select tst, ty, sta, eoj" ,
"from" m.ruJob ,
"where job = '"m.job"'" ,
"order by tst desc",
"fetch first row only",
, runJob, ":m.runJob.tst, :m.runJob.ty," ,
":m.runJob.sta, :m.runJob.eoj :m.runJob.eojInd"),
> 1 then
call err m.job.0 'rows from' m.ruJob'\n'sqlMsg()
return
endProcedure selectJobParms
/*--- analyze sysprint of utility preview
put listelements in m.lst. ------------------------------*/
analyzeSysprint: procedure expose m.
parse arg listen, inp
if m.listen.0 = 0 then
call mapReset listen'.N2L'
call readDsn inp, i1.
dbg = 0
do rx=1 to i1.0
if substr(i1.rx, 2, 10) == 'DSNU1010I ' ,
| substr(i1.rx, 2, 10) == 'DSNU1008I ' then do
sta = substr(i1.rx, 8, 2)
wx =wordPos('LISTDEF', i1.rx)
listName = word(i1.rx, wx+1)
if wx < 5 | listName == '' then
call 'bad sysprint line' rx':' i1.rx
if dbg then say '???nnn' sta listName
oKey = mapGet(listen'.N2L', listName, '')
if oKey \== '' then do
if dbg then say '???nnn list alrExists' oKey m.oKey.0
/* DSNU1008I may appear several times| */
if sta \== 08 | m.oKey.0 \= 0 then
call err 'list' listName 'alreadey exists with' ,
m.oKey.0 'objects sysprint line' rx':' i1.rx
end
else do /* add new list */
m.listen.0 = m.listen.0 + 1
lst = listen'.'m.listen.0
m.lst = lst
m.lst.0 = 0
call mapAdd listen'.N2L', listName, lst
call mapReset lst'.N2O'
m.lst.name = listName
m.lst.type = ''
end
if sta == 08 then
sta = '' /* DSNU1008I has only a single line */
m.lst.prtCnt = 0
end
else if substr(i1.rx, 2, 10) \== ' ' then do
sta = '' /* next message */
end
else if sta == 10 then do /* DSNU1010I line 2 */
wx =wordPos('OBJECTS', i1.rx)
if wx < 4 | \ datatype(word(i1.rx, wx-1), 'n') then
call err 'bad object count in sysprint line' rx':'i1.rx
m.lst.prtCnt = word(i1.rx, wx-1)
if dbg then say '???nnn 10' word(i1.rx,wx-1) 'objects'
sta = 102
end
else if sta == 102 then do /* DSNU1010I line 3... */
parse var i1.rx inc obj db1 '.' ts ' ' . 'LEVEL(' part ')'
if inc \== 'INCLUDE' ,
| wordPos(obj, 'TABLESPACE INDEXSPACE') < 1 then
call err 'bad sysprint include line' rx':' i1.rx
if dbg then say '???nnn 102 inc' obj db1'.'ts':'part'|'
ty = left(obj, 1)
if m.lst.type == '' then
m.lst.type = ty
else if m.lst.type \== ty then
call err 'ListDef' listName ,
'mit verschiedene Types, sysprint' rx':' i1.rx
ky = db1'.'ts
o = mapGet(lst'.N2O', ky, '')
if o \== '' then do /* add part to existing obj */
if part \== '' & m.o.parts \== '' then
/* parts: BitString with 1 at position of part */
m.o.parts = overlay(1, m.o.parts, part)
else if part == '' & m.o.parts \== '0' then
call err 'part 0 mismatch for' m.o.db'.'m.o.sp
end
else do /* new obj */
ox = m.lst.0 + 1
m.lst.0 = ox
o = lst'.'ox
m.o.db = db1
m.o.sp = ts
m.o.dbSp = ky
m.o.nm = ''
if part == '' then
m.o.parts = 0
else /* parts: BitString with 1 at position of part */
m.o.parts = overlay(1, '', part)
call mapAdd lst'.N2O', ky, o
end
end
end
do lx=1 to m.listen.0
lst = listen'.'lx
if (m.lst.0=0) <> (m.lst.prtCnt=0) then
call err 'list' m.lst.name 'has' m.lst.0 'objects' ,
'but' m.prtCnt 'parts'
say 'list' m.lst.name 'has' m.lst.0 'objects with' ,
(m.lst.prtCnt+0) 'parts'
do ox=1 to m.lst.0
o = lst'.'ox
if m.o.parts == 0 then do
m.o.paFr = 0
m.o.paTo = 0
end
else do
m.o.paFr = pos(1, m.o.parts)
if m.o.paFr > 0 then
m.o.paTo = lastPos(1, m.o.parts)
else
m.o.paTo = -1
end
end
end
return
endProcedure analyzeSysprint
/*--- analyse a listdef in dsn spec inp
put the different parts into map ctl -----------------------*/
analyzeCtl: procedure expose m.
parse arg ctl, inp
cx = m.ctl.0
call readDsn inp, i2.
st = ''
do rx=1 to i2.0
w = word(i2.rx, 1)
if w = '' then do
end
else if wordPos(w, 'REORG COPY REBUILD CHECK QUIESCE UNLOAD' ,
'LOAD MERGECOPY MODIFY RECOVER RUNSTATS DIAGNOSE') ,
> 0 then do
lx = wordPos('LIST', i2.rx)
liNa = word(i2.rx, lx+1)
if lx < 1 | lstName = '' then do
say 'warning no list in' i2.rx
/* could be reorg option unload continue,
thus, ignore it | */
end
else do
cx = cx + 1
st = ctl'.'cx
m.st.0 = 0
m.st.listName = liNa
call debug w 'list' liNa '->' st
end
end
if st ^== '' then
call mAdd st, i2.rx
end
m.ctl.0 = cx
return
endProcedure analyzeCtl
/*--- select the rts views for list lst and type type ----------------*/
selectRts: procedure expose m.
parse arg lst, type
if m.debug \== 1 then
m.sqlRetOk = 'w'
if m.lst.rts == 1 then
return
m.lst.rts = 1
if type == 'TS' then do
sql = "select db, ts, part, dbid, psid, reason, importance," ,
"reorgTime, i0Time, i0Parts," ,
"swRangeI0, swParallel, lastBuilt, uncompSz",
"from" m.rrTS ,
"where" genWhere(word(m.lst, 1), lst) ,
"order by importance desc, lastBuilt asc" ,
"with ur"
feFi = sqlVars('M.R', 'DB SP PART DBID SPID REASON IMP' ,
'RETI I0TI I0PA RAI0 PARA LABU UNCO', 1)
end
else if type == 'IX' then do
sql = "select db, is, part, ts, cr, ix, dbId, isoBid,",
"reason, importance, reorgTime, lastBuilt" ,
"from" m.rrIX ,
"where" genWhere(word(m.lst, 1), lst) ,
"order by importance desc, lastBuilt asc with ur"
feFi = sqlVars('M.R', 'DB SP PART TS CR IX DBID SPID',
'REASON IMP RETI LABU', 1)
m.r.i0Ti = 0
m.r.raI0 = 0
m.r.para = 0
m.r.unCo = 0
end
call debug 'sql' sql
call sqlPreOpen 1, sql
iLnk = lst
m.iLnk.impLnk = ''
m.iLnk.imp = 9e9
do while sqlFetchInto(1, feFi)
/* say 'db' m.r.db 'sp' m.r.sp 'pa' m.r.part
say ' imp' m.r.imp left(m.r.reason, 40) m.r.laBu
say 'reTi' m.r.reTi 'ioTi' m.r.i0Ti 'ix' m.r.i0Pa,
' raI0' m.r.raI0 'para' m.r.para */
key = strip(m.r.db)'.'strip(m.r.sp)
if m.iLnk.imp < m.r.imp then
call err 'importance increasing'
o = mapGet(lst'.N2O', key, '')
pa = m.r.part + 0
if o == '' then
call err key 'in rts but not lst'
if (pa == 0) \== (m.o.parts == 0) then
call err key 'part 0 misma rts' m.r.part 'lst' m.lst.parts
if pa \== 0 then
if substr(m.o.parts, pa, 1) \== 1 then do
say 'warning' key 'part' m.r.part 'not in lst'
iterate
end
if m.o.nm == '' then do
if type == 'TS' then do
m.o.nm = key
end
else do
m.o.ts = strip(m.r.ts)
m.o.cr = strip(m.r.cr)
m.o.ix = strip(m.r.ix)
m.o.nm = m.o.cr'.'m.o.ix
end
m.o.dbId = strip(m.r.dbId)
m.o.spId = strip(m.r.spId)
m.o.rngI0 = ''
m.o.i0Ti = m.r.i0Ti
m.o.i0Pa = m.r.i0Pa
m.o.raI0 = m.r.raI0
m.o.para = m.r.para
end
m.o.pa.impLnk = ''
m.iLnk.impLnk = o'.'pa
iLnk = o'.'pa
m.o.pa.part = pa
m.o.pa.obj = o
m.o.pa.reTi = m.r.reTi
m.o.pa.unco = m.r.unco
m.o.pa.imp = m.r.imp
m.o.pa.imRe = m.r.imp m.r.reason
m.o.pa.rng = ''
end
call sqlClose 1
return
endProcedure selectRts
/*--- group partitions into ranges
and make the ranges by thresholds for space, time etc ------*/
makeRanges: procedure expose m.
parse arg lst, type
iLnk = m.lst.impLnk
rLnk = lst
m.rLnk.reoLnk = ''
rTimax = m.job.time.type
rTi = 0
iRg = 0
if type = 'IX' then do /* Algorithmus 1: jede partition einzeln
reorganisieren bis zur ZeitLimite */
do while iLnk \== ''
iL = iLnk
iLnk = m.iL.impLnk
o = m.iL.obj
if m.iL.imp <= 0 then
m.iL.rng = 'i'
else if rTi > rTimax & m.iL.imp < 9 then
m.iL.rng = 's'
else do
iRg = iRg + 1
m.iL.rng = iRg
m.o.rngI0 = -99
rTi = rTi + max(.001, m.iL.reTi)
end
m.rLnk.reoLnk = iL
rLnk = iL
end
end
else do /* Algorithmus 2: partition Ranges innerhalb TS reorg.
range Limitiert nach zeit und sortPlatz
Total ZeitLimite */
do while iLnk \== ''
iL = iLnk
iLnk = m.iL.impLnk
if m.iL.rng \== '' then
iterate
if m.iL.imp <= 0 then
m.iL.rng = 'i'
else if rTi > rTimax & m.iL.imp < 9 then
m.iL.rng = 's'
if m.iL.rng \== '' then do
m.rLnk.reoLnk = iL
rLnk = iL
iterate
end
o = m.iL.obj
liUn = if(m.o.I0ti <= 0, m.job.uncompDef, m.job.uncompI0)
liT0 = max(120, m.o.I0ti * m.o.raI0/100)
liTi = max(10, m.o.I0ti * m.o.raI0/100)
say '????liTi' liTi ', liT0' liT0
liPa = m.o.para
acTi = max(0, m.o.I0Ti)
acPa = 0
acUn = 0
if m.o.rngI0 == '' then do
if type == 'TS' ,
& m.iL.part > 0 & m.o.i0Pa > 0 then
m.o.rngI0 = ass('iRg', iRg + 1)
else
m.o.rngI0 = -99
end
iRg = iRg + 1
pL = iL /* do not reorg imp<0 | */
do while pL \== '' & m.pL.imp >= 0
if m.pL.obj = o then do
if m.pL.rng \== '' then
call err 'rng already set'
m.pL.rng = iRg
acPa = acPa + 1
if m.o.i0Ti > 0 then
acTi = acTi + max(0.1, m.pL.reTi - m.o.i0Ti)
else /*???wk tentative formula for paralellism */
acTi = max(acTi, m.pL.reTi),
+ max(0.1, 0.3 * min(acTi, m.pL.reTi))
acUn = acUn + max(m.pL.unco, 1)
m.rLnk.reoLnk = pL
rLnk = pL
if acPa >= liPa & acTi >= liTi then
leave
if acUn >= liUn then
leave
end
pL = m.pL.impLnk
end
rTi = rTi + acTi
end
end
m.rLnk.reoLnk = ''
return rTi
endProcedure makeRanges
/*--- report which paritions to reorg and which not ------------------*/
reportReo: procedure expose m.
parse arg lst, type, rTi
tt = if(type == 'TS', '(table', '(index')'Partitionen)'
if rTi <= 0 then
call reoTitSay 'nichts zu reorganisieren:' type
else
call reoTitSay type 'zu reorganisieren,' fmtTime(rTi),
'geschaetzte Step ReorgZeit', type
rL = m.lst.reoLnk
iRg = 0
do while rL \== '' & m.rL.rng \== 's'& m.rL.rng \== 'i'
if iRg \= m.rL.rng & iRg+1 \= m.rL.rng ,
& iRg+2 \= m.rL.rng then
call err 'bad range' m.rL.rng 'after' iRg
iRg = m.rL.rng
say reoFmt(rL)
rL = m.rL.reoLnk
end
if rL \== '' & m.rL.rng == 's' then
call reoTitSay 'auf spaeter verschobene' type 'Reorgs', type
do while rL \== '' & m.rL.rng == 's'
say reoFmt(rL)
rL = m.rL.reoLnk
end
if rL \== '' then do
if m.rL.rng \== 'i' then
call err 'at end but rL' rL 'rng' m.rL.rng
call reoTitSay type 'Reorganisation nicht noetig fuer'
do lx=1 to m.lst.0
pas = ''
paL = ''
do p=m.lst.lx.paFr to m.lst.lx.paTo
if m.lst.lx.p.rng == 'i' then do
if p-1 = paL then
paL = p
else do
if paL = paF then
pas = pas',' paL
else if paL \== '' then
pas = pas',' paF'-'paL
paL = p
paF = p
end
end
end
if paL == '' then
iterate
if paL = paF then
pas = pas',' paL
else if paL \== '' then
pas = pas',' paF'-'paL
say m.lst.lx.nm':' substr(pas, 2)
end
end
say ''
m.sqlRetOk = ''
return 0
endProcedure reportReo
/*--- return the sql where condition
from the partition list in map lst ------------------*/
genWhere: procedure expose m.
parse arg lst
if m.lst.type = 'I' then
spFi = 'is'
else if m.lst.type = 'T' then
spFi = 'ts'
else
call err 'bad type in genWhere('lst')'
wh = ''
do dx=1 to m.lst.0
o = lst'.'dx
d1 = m.o.db
if db.d1 == 1 then
iterate
db.d1 = 1
fo = 0
do kx=dx to m.lst.0
o = lst'.'kx
if m.o.db \== d1 then
iterate
fo = fo + 1
if fo = 1 then
wh = wh "or (db = '"d1"' and" spFi "in("
wh = wh "'"m.o.sp"',"
end
if fo > 0 then
wh = left(wh, length(wh)-1)'))'
end
if wh = '' then
return ''
else
return substr(wh, 4)
endProcedure genWhere
/*--- format outputline for 1 part to reorg --------------------------*/
reoFmt: procedure expose m.
parse arg pa
f = 'e'
o = m.pa.obj
return left(m.o.nm, 21 - length(m.pa.part)) m.pa.part ,
right(if(m.pa.rng < 0, '', m.pa.rng), 5) ,
fmtTime(m.pa.reTi) fmtTime(m.o.i0Ti) strip(m.pa.imRe)
endProcedure reoFmt
/*--- title for reorg part lines -------------------------------------*/
reoTitSay: procedure expose m.
parse arg tit, withHead
say ''
say left(tit' ', 70, '*')
if withHead \== '' then
say left(if(m.ty == 'TS', 'db.tablespace', 'creator.index'),17),
right('part', 4) right('range', 5) ,
right('reoTi', 5) right('i0Ti', 5) 'i reason'
return
endProcedure reoTit
/*--- generate utiltity ctrl cards for run
ddOut: output dd spec to write ctrl to
ctl: input ctl with link to lists
genType: TS or IX ---------------------------------*/
genCtl: procedure expose m.
parse arg ddOut, ctl, genType
if genType = 'TS' then
ldType = 'TABLESPACE'
else if genType = 'IX' then
ldType = 'INDEXSPACE'
else
call err 'bad type' genType
m.out.1 = ' -- reoCheck' date('s') time()
m.out.0 = 1
do cx = 1 to m.ctl.0
c1 = ctl'.'cx
lst = m.c1.list
if lst == '' | m.lst.isGen == 1 then
iterate
m.lst.isGen = 1
liNa = m.lst.name
rL = m.lst.reoLnk
if rL == '' | m.rL.rng == 'i' | m.rL.rng == 's' then do
call debug 'nothing to reorg in' m.lst.name
iterate
end
dx = 0
acRg = ''
do while rL \== '' & m.rL.rng \== 's' & m.rL.rng \== 'i'
o = m.rL.obj
if m.rL.rng \= acRg then do
if dx == 0 | (genType == 'TS' ,
& wordPos(m.o.nm, acNms) > 0) then do
dx = dx + 1
acNms = ''
call mAdd out, 'LISTDEF' liNa'#'dx
end
acRg = m.rL.rng
acNms = acNms m.o.nm
end
pNo = m.rL.part
call mAdd out, ' INCLUDE' ldType m.o.dbSp,
if(pNo=0,'', 'PARTLEVEL('pNo')')
rL = m.rL.reoLnk
end
do dy=1 to dx
call genCtlUtil out, ctl, lst, 'LIST' liNa'#'dy
end
end
call writeDsn ddOut, 'M.'out'.', ,1
return
endProcedure genCtl
/*--- generate utility ctl for all utitlity for one list -------------*/
genCtlUtil: procedure expose m.
parse arg o, ctl, lst, what
do ux=1 to m.ctl.0 /* each utility for this list */
c1 = ctl'.'ux
if m.c1.list \== lst then
iterate
call mAdd o, ' -- utility' ux 'of' what
l1 = m.ctl.ux.1
lx = wordPos('LIST', l1)
if lx < 2 | word(l1, lx+1) <> m.lst.Name then
call err 'bad reorg list' lst':' l1
call mAdd o, subWord(l1, 1, lx-1) what subWord(l1, lx+2)
do cx=2 to m.c1.0
call mAdd o, strip(m.c1.cx, 't')
end
end
return
endProcedure genCtlUtil
/*--- insert statistics into tReoRun* tables ------------------------*/
insertStats: procedure expose m.
parse arg all, type
call sqlCommit
staLev = pos(m.job.stats, 'njps')
if staLev < 2 then
return
do try=1
call sqlPushRetOk -803
res = sqlPreAllCl(1, "select tst from final table (",
"insert into" m.ruJob ,
"(tst, job, TY, TYINP, STA)",
"values(current timestamp, '"m.job"',",
"'"type"', '"m.tyInp"', '"m.jobSta"') )",
, st , ':m.tst')
call sqlPopRetOk
if res = 1 then
leave
else if try > 5 then
call err 'to many retries ('try') for insert' m.ruJob
else if res \== -803 then
call err 'bad res' res 'insert' m.ruJob
say 'duplicate for insert' m.ruJob 'retry' try
call sqlExec 'rollback'
call sleep 1
end
call debug 'insertStats' m.tst m..0
if staLev < 3 then
return
do try=1
call sqlPrepare 22, "insert into" m.ruPart "(",
"tst, rng, part, paVon, paBis," ,
"rngI0, dbId, spId, ty, sta, reason, db, sp" ,
")values('"m.tst"', ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?)"
ty = if(type == 'TS', 't', 'i')
r0.0 = 1
pCnt = 0
do kx = 1 to m.all.0
lst = m.all.kx
if m.lst.rts \== 1 then
iterate
laRa = 0
rL = m.lst.reoLnk
do while rL \== '' & m.rL.rng \== 'i'
o = m.rL.obj
r0 = m.o.rngI0
ra = m.rL.rng
raTy = ra
if wordPos(raTy, 'i s') < 1 then
raTy = 'r'
if raTy == 'r' & r0 >= laRa then do
if r0 \= laRa + 1 then
call err 'bad r0' r0 'after' laRa
laRa = r0
call sqlExecute 22, r0, 0, 0, 0,
, -99, m.o.dbid, m.o.spId,
, ty, '0', 'i0 Indexe', m.o.db, m.o.sp
call debug sqlerrd.3 'i0 parts inserted r0' r0
pCnt = pCnt + 1
end
if raTy \== 'r' then do
ra = max(32000001, laRa+1)
laRa = ra
r0 = -99
rFr = m.rL.part
rTo = m.rL.part
end
else if ra \= laRa then do
if laRa + 1 \= ra then
call err 'bad range' ra 'after' laRa
laRa = ra
rFr = m.rL.part
rTo ='bad'
qL = rL
do qx=0 while ra = m.qL.rng
rTo = m.qL.part
qL = m.qL.reoLnk
end
if qx < 1 | (rFr = rTo) <> (qx = 1) then
call err 'bad from to'
end
call debug m.o.nm':'m.rL.part 'in range' ra,
'with' qx 'parts from' rFr 'to' rTo
call sqlExecute 22, ra, m.rL.part, rFr, rTo,
, r0, m.o.dbid, m.o.spId,
, ty, raTy, left(m.rL.imRe, 50), m.o.db, m.o.sp
pCnt = pCnt + 1
rL = m.rL.reoLnk
end
end
say pCnt 'runParts inserted into' m.ruPart
if staLev < 4 then
return
parse var m.tsStats rTC '.' rTT
parse var m.ixStats rIC '.' rIT
if ty == 't' then do
call sqlExec "insert into" m.ruTsSt,
"(tst, rng," tbCols(rTC, rTT)")",
"select tst, rng, r.*",
"from" m.ruPart "p," ,
m.tsStats "r",
"where p.tst = '"m.tst"' and p.ty = 't'",
"and p.dbid = r.dbid and p.spId = r.psId" ,
"and p.part = r.partition", 100
say sqlerrd.3 'tsStats inserted into' m.ruTsSt
call sqlExec "insert into" m.ruIxSt ,
"(tst, rng," tbCols(rIC, rIT)")",
"select tst, rng, r.*",
"from" m.ruPart "p," m.ixStats "r" ,
", sysibm.sysTables t, sysibm.sysIndexes i",
"where p.tst = '"m.tst"' and p.ty = 't'",
"and p.dbid = r.dbid and p.spId = r.psId" ,
"and t.dbName = p.db and t.tsName = p.sp" ,
"and i.tbCreator = t.creator and i.tbName=t.name",
"and r.dbId = i.dbId and r.isoBid = i.isoBid",
"and p.part = r.partition", 100
say sqlerrd.3 'ixStats inserted into' m.ruIxSt
end
else if ty == 'i' then do
call sqlExec "insert into" m.ruIxSt,
"(tst, rng," tbCols(rIC, rIT)")",
"select tst, rng, r.*",
"from" m.ruPart "p," m.ixStats "r",
"where p.tst = '"m.tst"' and p.ty = 'i'",
"and p.dbid = r.dbid and p.spId = r.isoBid" ,
"and p.part = r.partition", 100
say sqlerrd.3 'ixStats inserted into' m.ruIxSt
end
call sqlCommit
return
endProcedure insertStats
tbCols: procedure expose m.
parse upper arg cr, tb
sql = "select name from sysibm.sysColumns",
"where tbCreator = '"cr"' and tbName = '"tb"'" ,
"order by colNo asc"
call sqlPreOpen 1, sql
res = ''
do while sqlFetchInto(1, ':c1')
res = res',' c1
end
call sqlClose 1
return substr(res, 3)
endProcedure tbCols
/*--- debug a listDef ------------------------------------------------*/
debugCtl: procedure expose m.
parse arg ctl, tit
if m.debug ^== 1 then
return
call debug tit
do kx=1 to m.ctl.0
cc = ctl'.'kx
call debug 'ctl' kx cc 'for list' m.cc.listName
do s1=1 to m.cc.0
call debug ' ' strip(m.cc.s1, t)
end
end
return
endProcedure debugCtl
/*--- debug a list ---------------------------------------------------*/
debugLst: procedure expose m.
parse arg lst, tit
if m.debug \== 1 then
return
call debug tit
do lx=1 to m.lst.0
call debug 'list' lst'.'lx m.lst.lx.name m.lst.lx.type ,
'db' m.lst.lx.db
do kx=1 to m.lst.lx.0
k2 = lst'.'lx'.'kx
call debug ' ' k2 '->' ,
'db' m.k2.db 'sp' m.k2.sp 'parts' m.k2.parts
end
end
return
endProcedure debugLst
/*--- debug a map ----------------------------------------------------*/
debugMap: procedure expose m.
parse arg mp, pr
if m.debug ^== 1 then
return
do kx=1 to m.kk.0
k2 = mapGet(mp, m.kk.kx)
call debug pr m.kk.kx '->' k2
call debug pr ' db' m.k2.db 'sp' m.k2.sp 'parts' m.k2.parts
end
return
endProcedure debugMap
/*--- search the ds Name alloctade to dd dd --------------------------*/
dsn4Allocated: procedure expose m.
parse upper arg dd
/* it would be much easier with listDsi,
unfortuneatly listDsi returns pds name without member*/
dd = ' 'dd' '
oldOut = outtrap(l.)
call adrTso "listAlc st"
xx = outtrap(off)
do i=2 to l.0 while ^abbrev(l.i, dd)
end
if i > l.0 then
return '' /* dd not found */
j = i-1
dsn = word(l.j, 1)
if abbrev(l.j, ' ') | dsn = '' then
call err 'bad dd lines line\n'i l.i'\n'j l.j
return dsn
endProcedure dsn4Allocated
/***********************************************************************
ende Programm
ab hier kommen nur noch allgemeine Service Routinen
***********************************************************************/
/* copy sleep begin ***************************************************/
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
/* copy sleep end *****************************************************/
/* copy sql begin ***************************************************
sql interface
***********************************************************************/
sqlIni: procedure expose m.
parse arg opt
if m.sql.ini == 1 & opt \== 1 then
return
m.sqlNull = '---'
m.sqlInd = 'sqlInd'
m.sqlRetOK.0 = 0
m.sqlMsgCa = 0
m.sqlMsgDsntiar = 1
m.sqlMsgCodeT = 0
call sqlPushRetOk
m.sql.ini = 1
m.sql.connected = ''
return
endProcedure sqlIni
/*--- prepare statement 's'cx from sql src into descriptor desc ------*/
sqlPrepare: procedure expose m.
parse arg cx, src, descOut, descInp
s = ''
if descOut == 1 then
s = 'into :M.SQL.'cx'.D'
res = sqlExec('prepare s'cx s 'from :src')
if res < 0 then
return res
if descInp == 1 | (descInp == '' & pos('?', src) > 0) then
res = sqlExec('describe input s'cx 'into :M.SQL.'cx'.I')
else
m.sql.cx.i.sqlD = 0
return res
endProcedure
/*--- prepare and declare 'c'cx from sql src -------------------------*/
sqlPreDeclare: procedure expose m.
parse arg cx, src, descOut, descInp
res = sqlPrepare(cx, src, descOut, descInp)
if res >= 0 then
return sqlExec('declare c'cx 'cursor for s'cx)
return res
endProcedure sqlPreDeclare
/*--- prepare, declare and open 'c'cx from sql src -------------------*/
sqlPreOpen: procedure expose m.
parse arg cx, src, descOut, descInp
res = sqlPreDeclare(cx, src, descOut, descInp)
if res >= 0 then
return sqlOpen(cx)
return res
endProcedure sqlPreOpen
/*--- open cursor 'c'cx using arguments arg(2), arg(3)... ------------*/
sqlOpen: procedure expose m.
parse arg cx
do ix=1 to arg()-1
call sqlDataSet 'SQL.'cx'.I', ix, arg(ix+1)
end
return sqlExec('open c'cx 'using descriptor :M.SQL.'cx'.I')
endProcedure sqlOpen
/*--- close cursor 'c'cx ---------------------------------------------*/
sqlClose: procedure expose m.
parse arg cx, src
return sqlExec('close c'cx)
endProcedure sqlClose
/*--- fetch cursor 'c'cx into variables ggVars -----------------------*/
sqlFetchInto:
parse arg ggCx, ggVars
if ggVars == '' then
ggVars = 'descriptor :M.SQL.'ggCX'.D'
/* accept sqlCodes > 0 except 100 */
ggRes = sqlExec('fetch c'ggCx 'into' ggVars, 100 m.sqlRetOk)
if ggRes == 0 then
return 1
if ggRes == 100 then
return 0
return ggRes
endProcedure sqlFetchInto
/*--- return sql variable list for stem st and fields the word in vars
if withInd == 1 then with sqlIndicator variables
sqlVars('S', 'A B') --> ':S.A, :S.B'
sqlVars('S', 'A B', 1) --> ':S.A :S.A.SQLIND, :S.B :S.B.SQLIND'
----------------------------------------------------------------------*/
sqlVars: procedure expose m.
parse arg st, vars, withInd
res = ''
if st ^== '' then
st = st'.'
do ix=1 to words(vars)
res = res', :'st || word(vars, ix)
if withInd == 1 then
res = res ':'st || word(vars, ix)'.sqlInd'
end
return substr(res, 3)
endProcedure sqlVars
sqlVarsNull: procedure expose m.
parse arg st, vars
hasNulls = 0
do ix = 1 to words(vars)
fld = word(vars, ix)
if m.st.fld.sqlInd < 0 then do
m.st.fld = m.sqlNull
hasNulls = 1
end
end
return hasNulls
endProcedure sqlVarsNull
/*--- open cursor 'c'cx fetch all into variables vars and close
st = passed stem, sx = row number
return number of rows fetched ----------------------------------*/
sqlOpAllCl:
parse arg ggCx, st, ggVars
do ggAx=4 to arg()
call sqlDataSet 'SQL.'ggCx'.I', ggAx-3, arg(ggAx)
end
ggRes = sqlOpen(ggCx)
if ggRes < 0 then
return ggRes
do sx = 1 until ggRes \== 1
ggRes = sqlFetchInto(ggCx, ggVars)
end
m.st.0 = sx - 1
call sqlClose ggCx
if ggRes == 0 then
return m.st.0
return ggRes
endProcedure sqlOpAllCl
sqlDataSet: procedure expose m.
parse arg da, ix, val
m.da.ix.sqlData = val
m.da.ix.sqlInd = - (arg(ix+2) == m.sqlNull)
/* data types schienen einmal nicht zu funktionieren .......
if wordPos(m.da.ix.sqlType, '384 385 388 389 392 393') > 0 then
m.da.ix.sqlType = 448 + (m.da.ix.sqlType // 2) */
return
endProcedure sqlDataSet
/*--- prepare, declare open cursor 'c'cx, fetch all and close
return number of rows fetched ----------------------------------*/
sqlPreAllCl:
parse arg ggCx, ggSrc, st, ggVars
ggRes = sqlPreDeclare(ggCx, ggSrc)
if ggRes >= 0 then
return sqlOpAllCl(ggCx, st, ggVars)
return ggRes
endProcedure sqlPreAllCl
/*--- execute statement 's'cx using arguments arg(2), arg(3)... ------*/
sqlExecute:
parse arg ggCx ggRetOk /* no , for ggRetOk, arg(2) is used already| */
do ggAx=2 to arg()
call sqlDataSet 'SQL.'ggCx'.I', ggAx-1, arg(ggAx)
end
return sqlExec('execute s'ggCx 'using descriptor :M.SQL.'ggCx'.I',
, ggRetOk)
endProcedure
/*--- execute immediate the sql src ----------------------------------*/
sqlExImm:
parse arg ggSrc, ggRetOk
return sqlExec('execute immediate :ggSrc', ggRetOk)
endProcedure sqlExImm
sqlCommit: procedure expose m.
parse arg src
return sqlExec('commit')
endProcedure sqlCommit
/*--- execute sql thru the dsnRexx interface -------------------------*/
sqlExec: /* no procedure, to keep variables sql... */
parse arg ggSqlStmt, ggRetOk, ggNo
if ggNo <> '1' then
ggSqlStmt = 'execSql' ggSqlStmt
address dsnRexx ggSqlStmt
/* say 'sqlCode' sqlCode 'rc' rc 'for' ggSqlStmt ggNo */
if rc = 0 then
return 0
if ggRetOk = '' then
ggRetOk = m.sqlRetOk
if wordPos(rc, '1 -1') < 0 then
call err 'dsnRexx rc' rc sqlmsg()
else if pos('*', ggRetOk) > 0 | wordPos(sqlCode, ggRetOk) > 0 ,
then do
if sqlCode < 0 & pos('say', ggRetOk) > 0 then
say 'sqlError' sqlmsg()
return sqlCode
end
else if rc < 0 then
call err sqlmsg()
else if sqlCode <> 0 | (pos('w',ggRetOk)<1 & sqlWarn.0^==' ') then
call errSay sqlMsg(), ,'w'
return sqlCode
endSubroutine sqlExec
/*--- connect to the db2 subsystem sys -----------------------------*/
sqlConnect: procedure expose m.
parse upper arg sys, retOk
call sqlIni
address tso "SUBCOM DSNREXX"
if rc <> 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
if sys = '-' then
return 0
res = sqlExec("connect" sys, retOk ,1)
if res >= 0 then
m.sql.connected = sys
return res
endProcedure sqlConnect
/*--- diconnect from db2 ---------------------------------------------*/
sqlDisconnect: procedure expose m.
parse arg retOk
m.sql.connected = ''
return sqlExec("disconnect ", retOk, 1)
endProcedure sqlDisconnect
/*--- connect and/or disconnect to DB2 -------------------------------*/
sqlConDis: procedure expose m.
parse upper arg sys, retOk
if sys \== '' then
nop
else if sysvar(sysnode) == 'RZ1' then
sys = 'DBAF'
else
call err 'no default subsys for' sysvar(sysnode)
call sqlIni
if sys == m.sql.connected then
return 0
if m.sql.connected \== '' then
call sqlDisconnect
if sys = '-' then
return 0
return sqlConnect(sys, retOk)
endProcedure sqlConDis
/*--- push and pop currently accepted sqlCodes -----------------------*/
sqlPushRetOk: procedure expose m.
parse arg rr
nx = m.sqlRetOk.0 + 1
m.sqlRetOk.0 = nx
m.sqlRetOk.nx = rr
m.sqlRetOk = rr
return
endProcedure sqlPushRetOk
sqlPopRetOk: procedure expose m.
nx = m.sqlRetOk.0 - 1
if nx < 1 then
call err 'sqlPopRetOk with .0' m.sqlRetOk.0
m.sqlRetOk = m.sqlRetOk.nx
m.sqlRetOk.0 = nx
return
endProcedure sqlPopRetOk
/*--- issue an sql error message -------------------------------------*/
sqlMsg: /* no procedure, to keep variables sql... */
ggRes = ''
if \ dataType(sqlCode, 'n') then do
ggRes = 'sqlCode' sqlCode 'not numeric\n'sqlMsgCa()
end
else do
signal on syntax name sqlMsgOnSyntax
if m.sqlMsgCodeT == 1 then
ggRes = 'sqlCode' sqlCodeT(sqlCode, sqlErrMc, sqlwarn.0':' ,
|| sqlwarn.1||sqlwarn.2||sqlwarn.3||sqlwarn.4||sqlwarn.5',',
|| sqlwarn.6||sqlwarn.7||sqlwarn.8||sqlwarn.9||sqlwarn.10)
if 0 then
sqlMsgOnSyntax: do
ggRes = sqlMsgCa(),
'\n<<rexx sqlCodeT not found or syntax>>'
end
signal off syntax
if m.sqlMsgDsnTiar == 1 then do
ggRes = ggRes || sqlDsntiar()
ggWa = sqlMsgWarn(sqlWarn)
if ggWa \= '' then
ggRes = ggRes'\nwarnings' ggWa
end
if m.sqlMsgCa == 1 then
ggRes = ggRes'\n'sqlMsgCa()
end
ggSqlSp = ' ,:+-*/&%?|()¢!'
ggXX = pos(':', ggSqlStmt)+1
do ggSqlVx=1 to 12 while ggXX > 1
ggYY = verify(ggSqlStmt, ggSqlSp, 'm', ggXX)
if ggYY < 1 then
ggYY = length(ggSqlStmt) + 1
ggSqlVa.ggSqlVx = substr(ggSqlStmt, ggXX, ggYY - ggXX)
do ggQQ = ggXX-2 by -1 to 1 ,
while substr(ggSqlStmt, ggQQ, 1) == ' '
end
do ggRR = ggQQ by -1 to 1 ,
while pos(substr(ggSqlStmt, ggRR, 1), ggSqlSp) < 1
end
if ggRR < ggQQ & ggRR > 0 then
ggSqlVb.ggSqlVx = substr(ggSqlStmt, ggRR+1, ggQQ-ggRR)
else
ggSqlVb.ggSqlVx = ''
ggXX = pos(':', ggSqlStmt, ggYY+1) + 1
end
ggSqlVa.0 = ggSqlVx-1
if datatype(sqlErrd.5, 'n') & sqlErrd.5 > 0 then do
ggW2 = translate(word(ggSqlStmt, 2))
ggW3 = translate(word(ggSqlStmt, 3))
if ggW2 == 'PREPARE' then
ggRes = ggRes || sqlMsgSrF('FROM')
else if ggW2 ggW3 == 'EXECUTE IMMEDIATE' then
ggRes = ggRes || sqlMsgSrF(1)
else
ggRes = ggRes || sqlMsgSrF()
end
ggRes = ggRes'\nstmt = ' ggSqlStmt
ggPref = '\nwith'
do ggXX=1 to ggSqlVa.0
ggRes = ggRes || ggPref ggSqlVb.ggXX ':'ggSqlVa.ggXX ,
'=' value(ggSqlVa.ggXX)
ggPref = '\n '
end
if abbrev(ggRes, '\n') then
return substr(ggRes, 3)
return ggRes
endSubroutine sqlMsg
sqlMsgSrF:
parse arg ggF
if ggF \== '' & \ datatype(ggF, 'n') then do
do ggSqlVx=1 to ggSqlVa.0
if translate(ggSqlVb.ggSqlVx) = ggF then
return sqlMsgSrc(value(ggSqlVa.ggSqlVx), sqlErrd.5)
end
end
if datatype(ggF, 'n') & ggF <= ggSqlVa.0 then
return sqlMsgSrc(value(ggSqlVa.ggF), sqlErrd.5)
return sqlMsgSrc(ggSqlStmt , sqlErrd.5)
endSubroutine sqlMsgSrF
/*--- use dsnTiar to translate sql Info to error text ----------------*/
sqlDsnTiar:
sqlWarn = sqlWarn.0 || sqlWarn.1 || sqlWarn.2 || sqlWarn.3,
|| sqlWarn.4 || sqlWarn.5 || sqlWarn.6 || sqlWarn.7,
|| sqlWarn.8 || sqlWarn.9 || sqlWarn.10
if sqlCode = -438 then
return '\nSQLCODE = -438:',
'APPLICATION RAISED ERROR WITH sqlState' sqlState,
'and DIAGNOSTIC TEXT:' sqlErrMc
if digits() < 10 then
numeric digits 10
sqlCa = d2c(sqlCode, 4) ,
|| d2c(max(70, length(sqlErrMc)), 2)left(sqlErrMc, 70) ,
|| left(sqlErrP, 8) ,
|| d2c(sqlErrD.1, 4)d2c(sqlErrD.2, 4)d2c(sqlErrD.3, 4) ,
|| d2c(sqlErrD.4, 4)d2c(sqlErrD.5, 4)d2c(sqlErrD.6, 4) ,
|| sqlWarn || sqlState
if length(sqlCa) <> 124 then
call err 'sqlDa length' length(sqlCa) 'not 124' ,
'\nsqlCa=' sqlMsgCa()
return sqlDsnTiarCall(sqlCa)
/*--- call dsnTiar o translate sql Info to error text ----------------*/
sqlDsnTiarCall: procedure expose m.
parse arg ca
liLe = 78
msLe = liLe * 10
if length(ca) <> 124 then
call err 'sqlDa length' length(ca) 'not 124:' ca', hex='c2x(ca)
ca = 'SQLCA ' || d2c(136, 4) || ca
msg = d2c(msLe,2) || left('', msLe)
len = d2c(liLe, 4)
ADDRESS LINKPGM "DSNTIAR ca msg LEN"
if rc <> 0 then
call err 'linkPgm dsnTiar rc' rc 'sqlCa' ca
res = ''
do c=3 by liLe to msLe
if c = 3 then do
l1 = strip(substr(msg, c+10, 68))
cx = pos(', ERROR: ', l1)
if cx > 0 then
l1 = left(l1, cx-1)':' strip(substr(l1, cx+9))
res = res'\n'l1
end
else if substr(msg, c, 10) = '' then
res = res'\n 'strip(substr(msg, c+10, 68))
else
leave
end
return res
endProcedure sqlDsnTiarCall
sqlMsgCa:
ggWarn = ''
do ggX=0 to 10
if sqlWarn.ggX \== ' ' then
ggWarn = ggWarn ggx'='sqlWarn.ggx
end
if ggWarn = '' then
ggWarn = 'none'
return 'sqlCode' sqlCode 'sqlState='sqlState,
'\n errMC='translate(sqlErrMc, ',', 'ff'x),
'\n warnings='ggWarn 'erP='sqlErrP,
'\n errD.1='sqlErrD.1 '2='sqlErrD.2 '3='sqlErrD.3,
'\n errD.4='sqlErrD.4 '5='sqlErrD.5 '6='sqlErrD.6
endProcedure sqlMsgCa
/*--- make the text for sqlWarnings
input warn.0..warn.10 as a 11 character string ------------*/
sqlMsgWarn: procedure expose m.
parse arg w0 2 wAll
if w0 = '' & wAll = '' then
return ''
if length(wAll) \= 10 | ((w0 = '') <> (wAll = '')) then
return 'bad warn' w0':'wAll
r = ''
text =' 1=W var truncated, 1=S scrollable, 1=N nonScrollable,' ,
'2=W nulls in aggregate,' ,
'3=W more cols than vars,' ,
'3=Z more result sets than locators,' ,
'4=W no where, 4=D sensitive dynamic, 4=I insensitive,' ,
'4=S sensitive static,' ,
'5=W not valid sql, 5=1 readOnly, 5=2 readDelete,' ,
'5=3 readDeleteUpdate,' ,
'6=W day changed to month range,' ,
'7=W dec digits truncated,' ,
'8=W char substituted,' ,
'9=W arith excep in count, 9=Z multipe result sets,' ,
'10=W char conversion err in ca,'
do wx = 1 to 10
w = substr(wAll, wx, 1)
if w = ' ' then
iterate
t = wx'='w
cx = pos(' 'wx'='w' ', text)
ex = pos(',' , text, cx + 1)
if cx < 1 then
r = r wx'='w '?,'
else
r = r substr(text, cx+1, ex-cx)
end
return strip(r, 't', ',')
endProcedure sqlMsgWarn
sqlMsgSrc: procedure expose m.
parse arg src, pos, opt
if 0 then do /* old version, before and after txt */
tLe = 150
t1 = space(left(src, pos), 1)
if length(t1) > tLe then
t1 = '...'right(t1, tLe-3)
t2 = space(substr(src, pos+1), 1)
if length(t2) > tLe then
t2 = left(t2, tLe-3)'...'
res = '\nsource' t1 '<<<error>>>' t2
end
liLe = 68
liCn = 3
afLe = 25
if translate(word(src, 1)) == 'EXECSQL' then
src = substr(src, wordIndex(src, 2))
t1 = space(left(src, pos), 1)
t2 = left(' ', substr(src, pos, 1) == ' ' ,
| substr(src, pos+1, 1) == ' ') ,
|| space(substr(src, pos+1), 1)
afLe = min(afLe, length(t2))
if length(t1) + afLe > liLe * liCn then
t1 = '...'right(t1, liLe * liCn - afLe -3)
else if length(t1)+length(t2) > liLe then
t1 = left(' ', (liCn * liLe - length(t1) -afLe) // liLe)||t1
pL = length(t1) // liLe
if length(t2) <= liLe-pL then
tx = t1 || t2
else
tx = t1 || left(t2, liLe-pL-3)'...'
res = '\nsrc' strip(substr(tx, 1, liLe), 't')
do cx=1+liLe by liLe to length(tx)
res = res || '\n +' strip(substr(tx, cx, liLe), 't')
end
loc = 'pos' pos 'of' length(src)
if length(loc)+6 < pL then
return res'\n >' right('>>>'loc'>>>', pL)
else
return res'\n >' left('', pL-1)'<<<'loc'<<<'
endProcdedur sqlMsgSrc
/*--- send a command to db2 through the TSO dsn processor ------------*/
sqlDsn: procedure expose m.
parse arg st, sys, cmd, rcOk
x = outtrap('M.'st'.')
push 'END'
push cmd
address tso 'DSN SYSTEM('sys')'
rr = rc
x = outtrap(off)
if rr = 0 | rcOk = '*' | wordPos(rr, rcOk) > 0 then
return rr
fl = max(1, m.st.0 - 10)
em = 'rc' rr 'for DSN SYSTEM('sys') cmd' cmd,
'\nOuputlines' fl '-' m.st.0':'
do lx=fl to m.st.0
em = em '\n' strip(m.st.lx, 't')
end
call err em
endProcedure sqlDsn
/* copy sql end **************************************************/
/* copy fmt begin **************************************************/
/*--- format the first arg by the format in the second ---------------*/
fmt: procedure
parse arg v, f 2 l
if abbrev('-', f) then
return v
else if f == 'l' then
return left(v, l)
else if f == 'r' then
return right(v, l)
else if f == 'f' then do
parse value l'.0.0.' with b '.' a '.' e '.'
return format(v, b, a, e, 0)
end
else if f == 'e' then do
parse var l b '.' a '.' e '.'
if b == '' then b = 2
if a == '' then a = 2
if e == '' then e = 2
res = format(v, b, a, e, 0)
y = length(res)-e-1
if substr(res, y) = '' then
return left(res, y-1)left('E', e+1, 0)
else if substr(res, y+1, 1) == '+' then
return left(res, y)substr(res, y+2)
else if substr(res, y+2, 1) == '0' then
return left(res, y+1)substr(res, y+3)
else
call err 'formatoverflow' f || l 'for' v '-->' res
end
else if f = 's' then
if l == '' then
return strip(v, 't')
else
return strip(v, l)
else if f == 'w' then do
parse var l st ',' le
return substr(v, st, le)
end
else
call err 'bad format' f l 'for' v
endProcedure fmt
/*--- format special (title, null Value also for numbers) ------------*/
fmtS: procedure expose m.
parse arg v, ty 2 l
if ty == 'f' then do
if \ dataType(v, 'n') then do
parse value l'.0.0.' with b '.' a '.' e '.'
return right(v, b + a + (a \== 0) + e + 2 * (e > 0))
end
end
else if ty == 'e' then do
if \ dataType(v, 'n') then do
parse var l b '.' a '.' e '.'
if b == '' then b = 2
if a == '' then a = 2
if e == '' then e = 2
return right(v, b + a + (a \== 0) + e + (e > 0))
end
end
return fmt(v, ty || l)
endProcedure fmtS
fmtTime: procedure expose m.
parse arg s, signed
return fmtUnits(s, 't', signed==1)
endProcedure fmtTime
fmtDec: procedure expose m.
parse arg s, signed
return fmtUnits(s, 'd', signed==1)
endProcedure fmtDec
fmtUnits: procedure expose m.
parse arg s, scale, signed
if s >= 0 then
res = fmtUnitsNN(s, scale, wi)
else
res = '-'fmtUnitsNN(abs(s), scale, wi)
len = m.fmt.units.scale.f.length + signed
if length(res) <= len then
return right(res, len)
if \ abbrev(res, '-') then
return right(right(res, 1), len, '+')
if length(res) = len+1 & datatype(right(res, 1), 'n') then
return left(res, len)
return right(right(res, 1), len, '-')
endProcedure fmtUnits
fmtUnitsNN: procedure expose m.
parse arg s, scale
sf = 'FMT.UNITS.'scale'.F'
sp = 'FMT.UNITS.'scale'.P'
if m.sf \== 1 then do
call fmtIni
if m.sf \== 1 then
call err 'fmtUnitsNN bad scale' scale
end
do q=3 to m.sp.0 while s >= m.sp.q
end
do forever
qb = q-2
qu = q-1
r = format(s / m.sp.qb, ,0)
if q > m.sf.0 then
return r || substr(m.sf.units, qb, 1)
if r < m.sf.q * m.sf.qu then
return (r % m.sf.qu) || substr(m.sf.units, qu, 1) ,
|| right(r //m.sf.qu, m.sf.width, 0)
/* overflow because of rounding, thus 1u000: loop back */
q = q + 1
end
endProcedure fmtUnitsNN
fmtIni: procedure expose m.
if m.fmt.ini == 1 then
return
m.fmt.ini = 1
call fmtIniUnits 't', '?smhd', 0 100 60 60 24 100, 0.01, 2
call fmtIniUnits 'd', '?.kMGTPE', 0 copies('1000 ',8), 0.001, 3
return
endProcedure fmtIni
fmtIniUnits: procedure expose m.
parse arg sc, us, fact, prod, wi
sf = 'FMT.UNITS.'sc'.F'
sp = 'FMT.UNITS.'sc'.P'
m.sf.0 = words(fact)
if length(us) + 1 <> m.sf.0 then
call err 'fmtIniUnits mismatch' us '<==>' fact
m.sf.1 = word(fact, 1)
m.sp.1 = prod
do wx=2 to m.sf.0
wx1 = wx-1
m.sf.wx = word(fact, wx)
m.sp.wx = m.sp.wx1 * m.sf.wx
end
m.sp.0 = m.sf.0
m.sf.units = us
m.sf.width = wi
m.sf.length= 2 * wi + 1
m.sf = 1
return
endProcedure fmtIniUnits
/* copy fmt end **************************************************/
/* copy map begin ******************************************************
a map stores values at keys
it may also maintain a list of keys
the basic ideas are similar to the java Interface java.util.Map
contrary to stems we also handle keys longer then 250 bytes
***********************************************************************/
/*--- initialize the module ------------------------------------------*/
mapIni: procedure expose m.
if m.map.ini = 1 then
return
m.map.ini = 1
call mIni
m.map.0 = 0
m.map.inlineSearch = 1
call mapReset map.inlineName, map.inline
return
endProcedure mapIni
mapInline: procedure expose m.
parse arg pName, opt
if mapHasKey(map.inlineName, pName) then do
im = mapGet(map.inlineName, pName)
if pos('l', opt) < 1 & symbol('m.im.0') \== 'VAR' then do
m.im.0 = m.im.lEnd - m.im.lBegin - 1
do ix=1 to m.im.0
m.im.ix = strip(sourceline(ix+m.im.lBegin), 't')
end
end
return im
end
name = '/'
do lx = m.map.inlineSearch to sourceline()
if \ abbrev(sourceline(lx), '$') then
iterate
li = sourceline(lx)
s1 = pos('/', li)+ 1
if s1 < 3 | s1 > 4 then
iterate
s2 = pos('/', li, s1)
if s2 <= s1 then
iterate
if s1 == 3 then do
if name \== substr(li, s1, s2-s1) then
iterate
im = 'MAP.INLINE.' || (m.map.inline.0+1)
call mapAdd map.inlineName, name, im
m.im.lBegin = lBeg
m.im.lEnd = lx
m.im.mark = mrk
if name == pName then do
m.map.inlineSearch = lx+1
return mapInline(pName)
end
name = '/'
end
else if \ mapHasKey(map.inlineName,
, substr(li, s1, s2-s1)) then do
lBeg = lx
mrk = substr(li, 2, s1-3)
name = substr(li, s1, s2-s1)
end
else do
name = '/'
end
end
if pos('r', opt) > 0 then
return ''
return err('no inline data /'pName'/ found')
endProcedure mapInline
/*--- create a new map ----------------------------------------------*/
mapNew: procedure expose m.
parse arg opt
m.map.0 = m.map.0 + 1
return mapReset('MAP.'m.map.0 , opt)
endProcedure mapNew
/*--- make an empty map, if opt <> '' maintain stem of keys
('K' in map.keys, '=' in a else in opt) --------------*/
mapReset: procedure expose m.
parse arg a, opt
if symbol('m.map.keys.a') == 'VAR' then
call mapClear a
if opt = '=' then
st = a
else if translate(opt) = 'K' then
st = 'MAP.KEYS.'a
else
st = opt
m.map.keys.a = st
if st \== '' then
m.st.0 = 0
return a
endProcedure
/*--- add a new key value pair to the map ----------------------------*/
mapAdd: procedure expose m.
parse arg a, ky, val
vv = mapValAdr(a, ky, 'a')
m.vv = val
return val
endProcedure mapAdd
/*--- change the value at a key or add key value ---------------------*/
mapPut: procedure expose m.
parse arg a, ky, val
vv = mapValAdr(a, ky, 'p')
m.vv = val
return val
endProcedure mapPut
/*--- return 1 if key ky exists in map a, 0 otherwise ----------------*/
mapHasKey: procedure expose m.
parse arg a, ky
return mapValAdr(a, ky) \== ''
endProcedure mapHasKey
/*--- return the value of key ky in map a if it exists,
else if called with a third argument return third argument
else issue an error ----------------------------------------*/
mapGet: procedure expose m.
parse arg a, ky
vv = mapValAdr(a, ky)
if vv \== '' then
return m.vv
else if arg() > 2 then
return arg(3)
else
return err('missing key in mapGet('a',' ky')')
endProcedure mapGet
/*--- return a stem of all keys --------------------------------------*/
mapKeys: procedure expose m.
parse arg a
if m.map.keys.a == '' then
call err 'mapKeys('a') with no keys'
return m.map.keys.a
endProcedure mapKeys
/*--- remove a key from the map, do nothing if it is missing ---------*/
mapRemove: procedure expose m.
parse arg a, ky
vv = mapValAdr(a, ky)
if vv == '' then
return ''
if m.map.keys.a \== '' then do
trace ?R /* not tested yet ???wkTest */
k = m.map.keys.a
mx = m.k.0
do i=1 to mx
if m.k.i == ky then do
m.k.i = m.k.mx
m.k.0 = mx - 1
return
end
end
end
val = m.vv
drop m.a.ky
return val
endProcedure mapRemove
/*--- remove all entries ---------------------------------------------*/
mapClear: procedure expose m.
parse arg a
st = mapKeys(a)
liLe = 243 - length(a)
do kx=1 to m.st.0
ky = m.st.kx
drop m.st.kx
if length(ky) <= liLe then do
drop m.a.ky
end
else do
adr = mapValAdr(a, ky)
if adr \== '' then do
ha = left(adr, lastPos('.', adr) - 3)
do i = 1 to m.ha.k.0
drop m.ha.k.i m.ha.v.i
end
drop m.ha.k.0
end
end
end
m.st.0 = 0
return a
endProcedure mapClear
/*--- return the value pointer for a key, '' if non existing
with fun = 'a' add a key, with 'p' put a key ------------*/
mapValAdr: procedure expose m.
parse arg a, ky, fun
if length(ky) + length(a) <= 243 then do
res = a'.'ky
if symbol('m.res') == 'VAR' then do
if fun == 'a' then
call err 'duplicate key' ky 'in map' a
return res
end
else if fun == '' then
return ''
end
else do
len = 243 - length(a)
q = len % 4
ha = a'.'left(ky, len - 2 * q) || substr(ky,
, (length(ky)-len) % 2 + 2 * q, q) || right(ky, q)
if symbol('M.ha.k.0') == 'VAR' then do
do i=1 to m.ha.k.0
if m.ha.k.i == ky then do
if fun == 'a' then
call err 'duplicate key' ky ,
'map' a 'hash' ha'.K.'i
return ha'.V.'i
end
end
end
else do
i = 1
end
if fun == '' then
return ''
if i > 9 then
call err 'overflow long key' y 'in map' a 'hash' ha'.K.'i
m.ha.k.0 = i
m.ha.k.i = ky
res = ha'.V.'i
end
if m.map.keys.a \== '' then
call mAdd m.map.Keys.a, ky
m.res = ''
return res
endProcedure mapValAdr
/* copy map end *******************************************************/
/* copy m begin ********************************************************
we use variables as follows
m. stem m: all global data and object data that must survive
a procedure call (m for memory in Memoria of B5000)
m.<mbr>.** to avoid conflicts: every rexx Module (copy) should
only allocate addresses m.<mbr>.** with <mbr> the name of
the rexx module
we pass parameters around (e.g. a=address, m=memory, st=stem)
and the called function may use m.a or m.a.subField etc.
gg*: local variable in subroutines without procedure
everything else: temporary data within procedure
every subroutine is declared as procedure expose m.
(also if no m. variable is used, because e.g. of error handling)
the few subroutines that cannot use procedure, should use only
variables starting with gg
***********************************************************************/
/*---make an area -----*/
mNewArea: procedure expose m.
parse arg nm, adr, newCd, freeCd
m.m.area.0 = m.m.area.0 + 1
a = 'M.AREA.'m.m.area.0
if adr == '=' then
adr = nm
else if adr == '' then
adr = 'M.'m.m.area.0
if symbol('m.m.n2a.adr') == 'VAR' then
call err 'adr' adr 'for area' nm 'already used'
m.m.n2a.adr = a
call mAlias adr, nm
m.m.p2a.adr = a
m.a.0 = 0
m.a.free.0 = 0
m.a.address = adr
m.a.newCode = newCd
m.a.freeCode = freeCd
return nm
endProcedure mNewArea
mAlias: procedure expose m.
parse arg oldNa, newNa
if symbol('m.m.n2a.oldNa') \== 'VAR' then
call err 'area' oldNa 'does not exist'
if oldNa == newNa then
return
if symbol('m.m.n2a.newNa') == 'VAR' then
call err 'newName' newNa 'for old' oldNa 'already used'
m.m.n2a.newNa = m.m.n2a.oldNa
return
endProcedure mAlias
mBasicNew: procedure expose m. ggArea
parse arg name
if symbol('m.m.n2a.name') \== 'VAR' then
call err 'area' name 'does not exists'
ggArea = m.m.n2a.name
if m.ggArea.free.0 > 0 then do
fx = m.ggArea.free.0
m.ggArea.free.0 = fx-1
m = m.ggArea.free.fx
end
else do
m.ggArea.0 = m.ggArea.0 + 1
m = m.ggArea.address'.'m.ggArea.0
end
return m
endProcedure mBasicNew
mNew: procedure expose m.
labelMNew:
parse arg name, arg, arg2, arg3
m = mBasicNew(name)
interpret m.ggArea.newCode
return m
endProcedure mNew
mReset: procedure expose m.
parse arg a, name
ggArea = m.m.n2a.name
m = a
interpret m.ggArea.newCode
return m
endProcedure mReset
mFree: procedure expose m.
parse arg m
p = 'M.P2A.'left(m, lastPos('.', m)-1)
area = m.p
if m.area.freeCode \== '' then
interpret m.area.freeCode
fx = m.area.free.0 + 1
m.area.free.0 = fx
m.area.free.fx = m
return
endProcedure mFree
/*--- iterate over all allocate elements of an area ------------------*/
mIterBegin: procedure expose m.
parse arg nm
a = m.m.n2a.nm
return m.a.address'.0'
endProcedure mIterBegin
mIter: procedure expose m.
parse arg cur
if cur == '' then
return ''
lx = lastPos('.', cur)
p = 'M.P2A.'left(cur, lx-1)
a = m.p
ix = substr(cur, lx+1)
do ix=ix+1 to m.a.0
n = m.a.address'.'ix
do fx=1 to m.a.free.0 while m.a.free \== n
end
if fx > m.a.free.0 then
return n
end
return ''
endProcedure mIter
/*--- cut stem a to length len ---------------------------------------*/
mCut: procedure expose m.
parse arg a, len
m.a.0 = len
return a
endProcedure mCut
/*--- add one or several arguments to stem m.a -----------------------*/
mAdd: procedure expose m.
parse arg a
ix = m.a.0
do ax = 2 to arg()
ix = ix + 1
m.a.ix = arg(ax)
end
m.a.0 = ix
return a'.'ix
endProcedure mAdd
/*--- pop last element from stem m.a ---------------------------------*/
mPop: procedure expose m.
parse arg a
ix = m.a.0
if ix < 1 then
call err 'pop from empty stem' a
m.a.0 = ix-1
return m.a.ix
endProcedure mPop
/*--- add to m.dst.* a (sub)sequence of m.src.* ----------------------*/
mAddSt: procedure expose m.
parse arg dst, src
dx = m.dst.0
do sx = 1 to m.src.0
dx = dx + 1
m.dst.dx = m.src.sx
end
m.dst.0 = dx
return
endProcedure mAddSt
/*--- find position of first occurrence of ele in stem m,
return 0 if nonemove a part of a stem -----------------------*/
mPos: procedure expose m.
parse arg m, ele, sx
if sx == '' then
sx = 1
do x=sx to m.m.0
if m.m.x = ele then
return x
end
return 0
endProcedure mPos
/*--- move a part of a stem ------------------------------------------*/
mMove: procedure expose m.
parse arg m, sx, dx
if dx < sx then do
y = dx
do x=sx to m.m.0
m.m.y = m.m.x
y = y + 1
end
end
else if dx > sx then do
y = m.m.0 + dx - sx
do x=m.m.0 by -1 to sx
m.m.y = m.m.x
y = y - 1
end
end
m.m.0 = m.m.0 + dx - sx
return
endProcedure mMove
/*--- insert a stem into another ------------------------------------*/
mInsert: procedure expose m.
parse arg m, tx, st
call mMove m, tx, tx+m.st.0
do sx=1 to m.st.0
dx = tx-1+sx
m.m.dx = m.st.sx
end
return
endProcedure mInsert
/*--- strip all elements of a stem -----------------------------------*/
mStrip: procedure expose m.
parse arg st, opt
if opt == '' then
opt = 'b'
do x=1 to m.st.0
m.st.x = strip(m.st.x, opt)
end
return st
endProcedure mStrip
/*--- cat all elements of a stem together ----------------------------*/
mCat: procedure expose m.
parse arg st, mid
if m.st.0 < 1 then
return ''
res = m.st.1
do x=2 to m.st.0
res = res || mid || m.st.x
end
return res
endProcedure mCat
mIni: procedure expose m.
if m.m.ini = 1 then
return
m.m.ini = 1
m.mAlfLC = 'abcdefghijklmnopqrstuvwxyz'
m.mAlfUC = translate(m.mAlfLC)
m.mAlfa = m.mAlfLC || m.mAlfUC
m.mAlfNum = m.mAlfa || '0123456789'
m.mAlfDot = m.mAlfNum || '.'
m.m.area.0 = 0
call mNewArea
return
endProcedure mIni
/* copy m end *********************************************************/
/* copy adrTso begin *************************************************/
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet ---*/
adrTso:
parse arg ggTsoCmd, ggRet
address tso ggTsoCmd
if rc == 0 then return 0
else if ggRet == '*' then return rc
else if wordPos(rc, ggRet) > 0 then return rc
else
call err 'adrTso rc' rc 'for' ggTsoCmd
return /* end adrTso */
/*--- format dsn from tso format to jcl format -----------------------*/
dsn2jcl: procedure expose m.
parse upper arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
cx = pos('~', dsn)
if cx < 1 & addPrefix == 1 then
return sp'.'dsn
do while cx \== 0
le = left(dsn, cx-1)
ri = substr(dsn, cx+1)
if right(le, 1) == '.' | left(ri, 1) == '.' then
dsn = le || sp || ri
else
dsn = le || left('.', le \== '') || sp ,
|| left('.', ri \== '') || ri
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
parse arg dsn, mbr
bx = pos('(', dsn)
if bx > 0 then
dsn = strip(left(dsn, bx-1))
if mbr <> '' then
dsn = dsn'('strip(mbr)')'
return dsn
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn
lx = pos('(', dsn)
rx = pos(')', dsn, lx+1)
if lx < 1 then
return ''
else if lx < rx then
return substr(dsn, lx+1, rx-lx-1)
else
return strip(substr(dsn,lx+1))
endProcedure dsnGetMbr
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: readDDBegin, readDD*, readDDEnd
write: writeBegin, writeDD*, writeEnd
readDD returns true if data read, false at eof
***********************************************************************/
/*--- prepare reading from a DD --------------------------------------*/
readDDBegin: procedure expose m.
parse upper arg ggDD
call errAddCleanup 'call readDDEnd' ggDD', "*"'
return /* end readDDBegin */
/*--- read from DD ggDD into ggSt, return false at eof ---------------*/
readDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskr' ggDD '(stem' ggSt')', 2
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- finish reading DD ggDD ----------------------------------------*/
readDDEnd: procedure expose m.
parse upper arg ggDD, ggRet
call errRmCleanup 'call readDDEnd' ggDD', "*"'
return adrTso('execio 0 diskr' ggDD '(finis)', ggRet)
endProcedure readDDEnd
/*--- prepare writing to DD ggDD -------------------------------------*/
writeDDBegin: procedure expose m.
parse upper arg ggDD
/* ensure file is erased, if no records are written */
call adrTso 'execio' 0 'diskw' ggDD '(open)'
call errAddCleanup 'call writeDDEnd' ggDD', "*"'
return /* end writeDDBegin */
/*--- write to gg ggDD from stem ggSt, ggCnt records -----------------*/
writeDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt == '' then
ggCnt = value(ggst'0')
call adrTso 'execio' ggCnt 'diskw' ggDD '(stem' ggSt')'
return
endSubroutine writeDD
/*--- end writing to dd ggDD (close) --------------------------------*/
writeDDEnd: procedure expose m.
parse upper arg ggDD, ggRet
call errRmCleanup 'call writeDDEnd' ggDD', "*"'
return adrTso('execio 0 diskw' ggDD '(finis)', ggRet)
endProcedure writeDDEnd
/*--- readNx: read next line, using buffer ---------------------------*/
/*--- begin: allocate dsnSpec and ini ------------------------ -------*/
readNxBegin: procedure expose m.
parse arg m, m.m.dsn, m.m.dd, m.m.Cnt
if m.m.dd = '' then
m.m.dd = 'DDNX'
if m.m.cnt = '' then
m.m.cnt = 1000
m.m.cx = m.m.cnt + 999
m.m.buf0x = 0
m.m.0 = 0
call dsnAlloc 'dd('m.m.dd')' m.m.dsn
call readDDBegin m.m.dd
return m
endProcedure readDDNxBegin
/*--- return the stem of the next line, or '' at end -----------------*/
readNx: procedure expose m.
parse arg m
ix = m.m.cx + 1
m.m.cx = ix
if m.m.cx <= m.m.0 then
return m'.'ix
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 position (line number) of reader
plus le characters of the current line (default 50) ------*/
readnxPos: procedure expose m.
parse arg m, le
li = m'.'m.m.cx
li = strip(m.li, 't')
if arg() < 2 then
le = 50
if le < 1 then
li = ''
else if length(li) <= le then
li = ':' li
else
li = ':' left(li, le-3)'...'
return 'line' (m.m.buf0x + m.m.cx)li
endProcedure readnxPos
/*--- close and deallocate ------------------------------------------*/
readNxEnd: procedure expose m.
parse arg m
call readDDEnd m.m.dd
call tsoFree m.m.dd
return
endProcedure readDDNxEnd
/*--- standardise a dsn spec
word1 dsName or -
word2 dd or -
word3 disp or -
word4 to first : attributes in tso format
after first : attributes for new allocation
----------------------------------------------------------------------*/
dsnSpec: procedure expose m.
parse upper arg spec
rr = '' /* put leading - in separate words */
do sx=1 while words(rr) < 3 & wx \= ''
wx = word(spec, sx)
do while abbrev(wx, '-') & words(rr) < 3
wx = substr(wx, 2)
rr = rr '-'
end
rr = rr wx
end
spec = rr subWord(spec, sx)
na = ''
dd = ''
di = ''
if left(spec, 1) = '&' then /* external spec is handled ok */
spec = strip(substr(spec, 2))
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, '.') | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
di = w
else if w = 'CATALOG' then
di = di w
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
na = strip(substr(w, 5, length(w)-5))
else if na == '' then
na = dsn2jcl(w)
else if dd == '' then
dd = w
else if di == '' then
di = w
else
leave
end
if na == '' then
na = '-'
else if abbrev(na, "'") then
na = substr(na, 2, length(na)-2)
if dd == '' then dd = '-'
if di == '' then di = '-'
re = subword(spec, wx)
if abbrev(re, '.') then
re = substr(re, 2)
return na dd di re
endProcedure dsnSpec
/*--- alloc a dsn with dsnAlloc
if the dsn is inuse wait and retry
until either the allocation is successfull
or the timeout occurs --------------------------------------*/
dsnAllocWait: procedure expose m.
parse upper arg spec, pDi, pDD, timeOut
x = max(1, arg() - 1)
do rt=0
m.adrTsoAl.1 = ''
m.adrTsoAl.2 = ''
m.adrTsoAl.3 = ''
call outtrap m.adrTsoAl.
res = dsnAlloc(spec, pDi, pDD, '*')
call outtrap off
if \ abbrev(res, ' ') then
return res
msg = m.adrTsoAl.1'\n'm.adrTsoAl.2'\n'm.adrTsoAl.3
if rt > timeOut & timeOut \== '' then
return err('timeout allocating' spec time() '\n'msg)
if pos('DATA SET IS ALLOCATED TO ANOTHER', msg) < 1 then
return err('allocating' spec'\n'msg)
say time() 'sleep and retry alloc' spec
call sleep 1, 0
end
endProcedure dsnAllocWait
/*--- alloc a dsn or a dd
spec '-'<ddName>
datasetName? disposition? '.'? attributes? (':' newAtts)?
disp default disposition
dd default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc -----*/
dsnAlloc: procedure expose m.
parse upper arg spec, pDi, pDD, retRc
parse value dsnSpec(spec) with na dd di rest
if na = '-' then
m.dsnAlloc.dsn = ''
else
m.dsnAlloc.dsn = na
if na == '-' & dd \== '-' & di == '-' & rest = '' then
return dd
if dd == '-' & pDD \== '' then
dd = pDD
if dd == '-' then do
if symbol('m.adrTso.ddNum') = 'VAR' then
dd = m.adrTso.ddNum + 1
else
dd = 1
m.adrTso.ddNum = dd
dd = 'DD' || dd
end
if di = '-' & pDi \== '' then
di = pDi
if di = '-' then
di = 'SHR'
else if pos('(', na) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if pos('/', na) > 0 then
return csmAlloc(na dd di rest, retRc)
else
return tsoAlloc(na dd di rest, retRc)
endProcedure dsnAlloc
tsoAlloc: procedure expose m.
parse arg na dd disp rest ':' nn, retRc
c = 'alloc dd('dd')' disp
if na \== '-' then
c = c "DSN('"na"')"
else if disp = 'NEW' and nn \== '' then
c = c dsnCreateAtts(,nn)
call outtrap m.adrTsoAl.
alRc = adrTso(c rest, '*')
call outtrap off
if alRc = 0 then do
call errAddCleanup 'call tsoFree' dd', "*"'
return dd 'call tsoFree' dd';'
end
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& sysDsn("'"m.dsnAlloc.dsn"'") == 'DATASET NOT FOUND' then do
say 'tsoAlloc creating' c rest ':'nn
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na dd disp rest, retRc)
end
do ax=1 to m.adrTsoAl.0
say m.adrTsoal.ax
end
if retRc = '*' | wordPos(alRc, retRc) > 0 then
return ' ' alRc
call err 'tsoAlloc rc' alRc 'for' c rest
endProcedure tsoAlloc
tsoAtts: procedure expose m.
parse arg dsn
rc = listDsi("'"dsn"' SMSINFO")
if rc = 0 then
mv = ''
else if rc = 4 & sysReason = 19 then do
mv = 'UNITCNT(30)'
say 'multi volume' mv
end
else if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
al = 'CAT'
al = ''
if right(sysDsSms, 7) == 'LIBRARY' ,
| abbrev(sysDsSms, 'PDS') then
al = al 'DSNTYPE(LIBRARY)'
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
al = al "DSORG("sysDSorg") MGMTCLAS("sysMgmtClass")",
"DATACLAS("sysDataClass")" ,
"RECFM("translate('1 2 3', ' 'sysREcFM, ' 123')")",
"LRECL("SYSLRECL")",
"blksize("sysBLkSIZE")",
"SPACE("sysPrimary"," sysSeconds")" sysUnits mv
return al
endProcedure tsoAtts
tsoFree: procedure expose m.
parse arg dd, ggRet
call adrTso 'free dd('dd')', ggRet
call errRmCleanup 'call tsoFree' dd', "*"'
return
endProcedure tsoFree
dsnCreateAtts: procedure expose m.
parse arg dsn, atts, forCsm
forCsm = forCsm == 1
aU = ' 'translate(atts)
if abbrev(atts, ':') then do
parse var atts a1 atts
bl = 32760
rl = substr(a1, 3)
if abbrev(a1, ':F') then do
if rl = '' then
rl = 80
recfm='f b'
bl = bl - (bl // rl)
end
else do
if rl = '' then
rl = bl-4
recfm = substr(a1, 2, 1) 'b'
end
if forCsm then
atts = atts "recfm("space(recfm, 0)") lrecl("rl")",
"blkSize("bl")"
else
atts = atts "recfm("recfm") lrecl("rl") block("bl")"
end
if pos('(', dsn) > 0 & pos(' DSNTYPE(', aU) < 1 ,
& pos(' DSORG(', aU) < 1 then
atts = atts 'dsntype(library) dsorg(po)'
if pos(' MGMTCLAS(', aU) < 1 then
atts = atts 'mgmtclas(COM#A091)'
if pos(' SPACE(', aU) < 1 then
if forCsm then
atts = atts 'space(10, 1000) cylinder'
else
atts = atts 'space(10, 1000) cyl'
if dsn == '' then
return atts
return "dataset('"dsnSetMbr(dsn)"')" atts
endProcedure dsnCreateAtts
/*--- read the dataset specified in ggDsnSpec to stem ggSt -----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
interpret subword(ggAlloc, 2)
return
endSubroutine readDsn
/*--- write the dataset specified in ggDsnSpec from stem ggSt
write ggCnt records if not empty otherwise ggst0
if ggSay 1 then say ... records written to ... -------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'open finis)'
interpret subword(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
copyDSN: procedure expose m.
parse arg frSpec, toSpec, ggSay
frDD = dsnAlloc(frSpec, 'SHR', 'FRDD')
toDD = dsnAlloc(toSpec, 'OLD', 'TODD')
call readDDBegin word(frDD, 1)
call writeDDBegin word(toDD, 1)
cnt = 0
do while readDD(word(frDD, 1), r.)
call writeDD word(toDD, 1), r.
cnt = cnt + r.0
end
call readDDEnd word(frDD, 1)
call writeDDEnd word(toDD, 1)
interpret ';' subword(frDD, 2) '; ; ;' subword(toDD, 2)
if ggSay == 1 | m.debug == 1 then
say cnt 'records copied from' frSpec 'to' to toSpec
return
endSubroutine writeDsn
/* copy adrTso end ****************************************************/
/* copy err begin ******************************************************
messages, errorhandling,help
***********************************************************************/
errIni: procedure expose m.
if m.err.ini == 1 then
return
call outIni
m.err.ini = 1
m.err.handler = ''
m.err.cleanup = ';'
m.err.opt = ''
return
endProcedure errIni
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err.opt, m.err.handler
if pos('I', translate(m.err.opt)) > 0 then
if errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
call adrIsp 'control errors return'
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
call errIni
drop err handler cleanup opt call return
if ggOpt == '' & m.err.handler \== '' then do
if 1 then do /* no detection of recursive err call loop
--> will anyway fail by stack overflow */
interpret m.err.handler
end
else do
/* avoid recursive err call loop */
drop call return
if symbol('m.err.call') \== 'VAR' then
m.err.call = 1
else
m.err.call = m.err.call + 1
if m.err.call > 10 then do
say 'errHandler loop:' m.err.handler
end
else do
m.err.return = 1
call errInterpret m.err.handler
m.err.call = m.err.call - 1
if m.err.return then
return result
end
end
end
call outPush
call errSay ggTxt, 'e'
call errCleanup
if ggOpt == '' then
ggOpt = m.err.opt
ggOpt = translate(ggOpt)
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 then do
call errSay 'divide by zero to show stackHistory', 'e'
x = 1 / 0
end
call errSay 'exit(12)', 'e'
exit errSetRc(12)
endSubroutine err
/*--- error routine: user message cleanup exit -----------------------*/
errEx:
parse arg ggTxt
call errIni
call outPush
call errSay ggTxt
call errCleanup
exit 8
endProcedure errEx
errAddCleanup: procedure expose m.
parse arg code
if m.err.ini \== 1 then
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
if m.err.ini \== 1 then
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
cl = m.err.cleanup
if cl = ';' then
return
m.err.cleanup = ';'
call out 'err cleanup begin' cl
call errInterpret cl
call out 'err cleanup end' cl
return
endProcedure errCleanup
errInterpret: procedure expose m.
parse arg code
interpret code
m.err.return = 0
return
endProcedure errInterpret
/*--- assert that the passed rexx expression evaluates to true -------*/
assert:
interpret 'assertRes =' arg(1)
if \ assertRes then
call err 'assert failed' arg(1)':' arg(2)
return
endProcedure assert
/*--- output an errorMessage msg with pref pref
split message in lines at '/n' ---------------------------*/
errSay: procedure expose m.
parse arg msg, pref
parse source . . ggS3 . /* current rexx */
if pref == 'e' then
msg = 'fatal error in' ggS3':' msg
else if pref == 'w' then
msg = 'warning in' ggS3':' msg
else if pref \== '' then
msg = pref':' msg
return outNl(msg)
endProcedure errSay
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg, op
call errSay msg, 'e'
call help
call err msg, op
endProcedure errHelp
/*--- return the Operating System we are running on: TSO or LINUX ---*/
errOS: procedure expose m.
parse source os .
return os
endProcedure errOS
/*--- set rc for ispf: -------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared varible 3IspfRc
back as return code
----------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- output a trace message if m.tr is set -----------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
call out 'debug' msg
return
endProcedure debug
/*--- display the first comment block of the source as help ----------*/
help: procedure expose m.
parse source . . s3 .
call out right(' help for rexx' s3, 79, '*')
do ax=1 to arg()
say ' ' arg(ax)
end
do lx=1 by 1
if pos('/*', sourceLine(lx)) > 0 then
leave
else if lx > 10 then do
call out '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
call out li
end
call out right(' end help for rexx' s3, 79, '*')
return 4
endProcedure help
/*--- output all lines (separated by '\n') of all args --------------*/
outNl: procedure expose m.
do ax=1 to max(1, arg())
msg = arg(ax)
sx = 0
bx = -1
do lx=1 until bx >= length(msg)
ex = pos('\n', msg, bx+2)
if ex < 1 then
ex = length(msg)+1
call out substr(msg, bx+2, ex-bx-2)
bx = ex
end
end
return 0
endProcedure outNl
/* copy err end *****************************************************/
/* copy out begin ******************************************************
out interface with simplistic implementation
***********************************************************************/
outIni: procedure expose m.
parse arg msg
if m.out.ini == 1 then
return
m.out.ini = 1
m.out.dst = ''
return
endProcedure outIni
/*--- output a message to the current destination -------------------*/
out: procedure expose m.
parse arg msg
if m.out.ini \== 1 then
call outIni
if m.out.dst == '' then do
say msg
end
else do
st = m.out.dst
sx = m.st.0 + 1
m.st.0 = sx
m.st.sx = msg
end
return 0
endProcedure out
/*--- push an out destination ---------------------------------------*/
outPush: procedure expose m.
parse arg m.out.dst
return
endProcedure outPush
/* copy out end *****************************************************/
/* copy ut begin *****************************************************/
/*--- if function warning all3 arguments get evaluated|
e.g if(x=0, 'infinity', 1/0) will fail| -----------*/
if: procedure expose m.
parse arg co, ifTrue, ifFalse
if co then
return ifTrue
else
return ifFalse
endProcedure if
/*--- embedded ASSignement:
assign the second argument to the variable with name in first arg
and return the value assigned ----------------------------------*/
ass:
call value arg(1), arg(2)
return arg(2)
/*--- embedded ASSignement only if NotNull:
assign the second argument to the variable with name in first arg
if the second arg is not null, return new value ---------------*/
assIf:
if arg(2) == '' then
return value(arg(1))
call value arg(1), arg(2)
return arg(2)
/*--- return first nonNull argument ---------------------------------*/
nn:
if arg(1) \== '' then
return arg(1)
if arg(2) \== '' then
return arg(2)
call err 'nn() both args empty'
/*--- embedded ASSignement return NotNull:
assign the second argument to the variable with name in first arg
and return 1 if value not null, 0 if null ----------------------*/
assNN:
call value arg(1), arg(2)
return arg(2) \== ''
/*--- return current time and cpu usage ------------------------------*/
timing: procedure expose m.
return return time() 'ela='time('E') 'cpu='sysvar('syscpu'),
'su='sysvar('syssrv')
timingTest: procedure expose m.
say 'begin' timing() sysvar('sysnode')
do 30000000
end
say 'end ' timing()
return
/*--- sleep several seconds ------------------------------------------*/
sleep: procedure expose m.
parse arg secs, sayIt
if sayit <> 0 then
say 'sleeping' secs 'secs' time()
CALL SYSCALLS 'ON'
ADDRESS SYSCALL "sleep" secs
CALL SYSCALLS 'OFF'
if sayit <> 0 then
say 'slept' secs 'secs' time()
return
endProcedure sleep
/*--- elongate inp with spaces up to given len -----------------------*/
elong: procedure expose m.
parse arg inp, len
if length(inp) >= len then
return inp
return left(inp, len)
endProcedure elong
/*--- quote string txt using quoteChar qu ("""" ==> ") ---------------*/
quote: procedure expose m.
parse arg txt, qu
if qu = '' then
qu = '"'
res = qu
ix = 1
do forever
qx = pos(qu, txt, ix)
if qx = 0 then
return res || substr(txt, ix) || qu
res = res || substr(txt, ix, qx-ix) || qu || qu
ix = qx + length(qu)
end
endProcedure quote
/*--- return the count of occurrences of needle in heyStack ----------*/
posCount: procedure expose m.
parse arg needle, hayStack, start, fin
if start = '' then
start = 1
if fin = '' then
fin = length(hayStack) + 1 - length(needle)
do cnt = 0 by 1
start = pos(needle, haystack, start)
if start < 1 | start > fin then
return cnt
start = start + length(needle)
end
endProcedure posCount
repAll: procedure expose m.
parse arg src, w, new
res = ''
cx = 1
do forever
nx = pos(w, src, cx)
if nx < 1 then
return res || substr(src, cx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAll
repAllWords: procedure expose m.
parse arg src, w, new
res = ''
wx = 0
cx = 1
do forever
wx = wordPos(w, src, wx+1)
if wx < 1 then
return res || substr(src, cx)
nx = wordindex(src, wx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAllWords
/* copy ut end ********************************************************/
}¢--- A540769.WK.REXX(REOREFJJ) cre=2009-10-29 mod=2011-09-09-10.13.33 A540769 ---
$** test job für parallele reoRefSt
$**$>.jclSub()
$@do i=1 to 13 $@=¢
$=j=- substr('0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ@',$i,1)
//A540769$j JOB (CP00,KE50),TIME=60 01
//*MAIN=LOG
//S EXEC PGM=IKJEFT01,DYNAMNBR=200,TIME=99,
// PARM='checkRef DBAF 5'
//SYSIN DD DUMMY
//SYSTSIN DD DUMMY
//SYSTSPRT DD SYSOUT=*
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTERM DD DUMMY
//SYSPROC DD DISP=SHR,DSN=A540769.WK.REXX
$!
$#out 20091030 16:58:24
//A5407690 JOB (CP00,KE50),TIME=60 01
//*MAIN=LOG
//S EXEC PGM=IKJEFT01,DYNAMNBR=200,TIME=99,
// PARM='checkRef DBAF 5'
//SYSIN DD DUMMY
//SYSTSIN DD DUMMY
//SYSTSPRT DD SYSOUT=*
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTERM DD DUMMY
//SYSPROC DD DISP=SHR,DSN=A540769.WK.REXX
//A5407691 JOB (CP00,KE50),TIME=60 01
//*MAIN=LOG
//S EXEC PGM=IKJEFT01,DYNAMNBR=200,TIME=99,
// PARM='checkRef DBAF 5'
//SYSIN DD DUMMY
//SYSTSIN DD DUMMY
//SYSTSPRT DD SYSOUT=*
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTERM DD DUMMY
//SYSPROC DD DISP=SHR,DSN=A540769.WK.REXX
//A5407692 JOB (CP00,KE50),TIME=60 01
//*MAIN=LOG
//S EXEC PGM=IKJEFT01,DYNAMNBR=200,TIME=99,
// PARM='checkRef DBAF 5'
//SYSIN DD DUMMY
//SYSTSIN DD DUMMY
//SYSTSPRT DD SYSOUT=*
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTERM DD DUMMY
//SYSPROC DD DISP=SHR,DSN=A540769.WK.REXX
//A5407693 JOB (CP00,KE50),TIME=60 01
//*MAIN=LOG
//S EXEC PGM=IKJEFT01,DYNAMNBR=200,TIME=99,
// PARM='checkRef DBAF 5'
//SYSIN DD DUMMY
//SYSTSIN DD DUMMY
//SYSTSPRT DD SYSOUT=*
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTERM DD DUMMY
//SYSPROC DD DISP=SHR,DSN=A540769.WK.REXX
//A5407694 JOB (CP00,KE50),TIME=60 01
//*MAIN=LOG
//S EXEC PGM=IKJEFT01,DYNAMNBR=200,TIME=99,
// PARM='checkRef DBAF 5'
//SYSIN DD DUMMY
//SYSTSIN DD DUMMY
//SYSTSPRT DD SYSOUT=*
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTERM DD DUMMY
//SYSPROC DD DISP=SHR,DSN=A540769.WK.REXX
//A5407695 JOB (CP00,KE50),TIME=60 01
//*MAIN=LOG
//S EXEC PGM=IKJEFT01,DYNAMNBR=200,TIME=99,
// PARM='checkRef DBAF 5'
//SYSIN DD DUMMY
//SYSTSIN DD DUMMY
//SYSTSPRT DD SYSOUT=*
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTERM DD DUMMY
//SYSPROC DD DISP=SHR,DSN=A540769.WK.REXX
//A5407696 JOB (CP00,KE50),TIME=60 01
//*MAIN=LOG
//S EXEC PGM=IKJEFT01,DYNAMNBR=200,TIME=99,
// PARM='checkRef DBAF 5'
//SYSIN DD DUMMY
//SYSTSIN DD DUMMY
//SYSTSPRT DD SYSOUT=*
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTERM DD DUMMY
//SYSPROC DD DISP=SHR,DSN=A540769.WK.REXX
//A5407697 JOB (CP00,KE50),TIME=60 01
//*MAIN=LOG
//S EXEC PGM=IKJEFT01,DYNAMNBR=200,TIME=99,
// PARM='checkRef DBAF 5'
//SYSIN DD DUMMY
//SYSTSIN DD DUMMY
//SYSTSPRT DD SYSOUT=*
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTERM DD DUMMY
//SYSPROC DD DISP=SHR,DSN=A540769.WK.REXX
//A5407698 JOB (CP00,KE50),TIME=60 01
//*MAIN=LOG
//S EXEC PGM=IKJEFT01,DYNAMNBR=200,TIME=99,
// PARM='checkRef DBAF 5'
//SYSIN DD DUMMY
//SYSTSIN DD DUMMY
//SYSTSPRT DD SYSOUT=*
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTERM DD DUMMY
//SYSPROC DD DISP=SHR,DSN=A540769.WK.REXX
//A5407699 JOB (CP00,KE50),TIME=60 01
//*MAIN=LOG
//S EXEC PGM=IKJEFT01,DYNAMNBR=200,TIME=99,
// PARM='checkRef DBAF 5'
//SYSIN DD DUMMY
//SYSTSIN DD DUMMY
//SYSTSPRT DD SYSOUT=*
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTERM DD DUMMY
//SYSPROC DD DISP=SHR,DSN=A540769.WK.REXX
//A540769A JOB (CP00,KE50),TIME=60 01
//*MAIN=LOG
//S EXEC PGM=IKJEFT01,DYNAMNBR=200,TIME=99,
// PARM='checkRef DBAF 5'
//SYSIN DD DUMMY
//SYSTSIN DD DUMMY
//SYSTSPRT DD SYSOUT=*
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTERM DD DUMMY
//SYSPROC DD DISP=SHR,DSN=A540769.WK.REXX
//A540769B JOB (CP00,KE50),TIME=60 01
//*MAIN=LOG
//S EXEC PGM=IKJEFT01,DYNAMNBR=200,TIME=99,
// PARM='checkRef DBAF 5'
//SYSIN DD DUMMY
//SYSTSIN DD DUMMY
//SYSTSPRT DD SYSOUT=*
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTERM DD DUMMY
//SYSPROC DD DISP=SHR,DSN=A540769.WK.REXX
//A540769C JOB (CP00,KE50),TIME=60 01
//*MAIN=LOG
//S EXEC PGM=IKJEFT01,DYNAMNBR=200,TIME=99,
// PARM='checkRef DBAF 5'
//SYSIN DD DUMMY
//SYSTSIN DD DUMMY
//SYSTSPRT DD SYSOUT=*
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTERM DD DUMMY
//SYSPROC DD DISP=SHR,DSN=A540769.WK.REXX
$#out 20091030 16:58:13
}¢--- A540769.WK.REXX(REOREFST) cre=2010-09-27 mod=2013-11-28-16.26.03 A540769 ---
/* rexx ****************************************************************
reoRefSt: refresh status table or update stats table for rtsReorg
synopsys: reoRefSt ssid fun*
ssid : ssid for the db2 group, prefixed by - if already connected
fun : one or several of the following functions (may be abbrev):
refresh age? : refresh tDbState from -dis db restrict ...
age a number: refresh only if older than age seconds,
default 60
if refreshed then staTime 240
age : same as ref age
hours h : number of hours for staJob to look back
staLevel l : statistikLevel n=no,j=job,p=part, s=rts
staJob j : j a jobname or mask (db2 like: % and _ )
set eoj to current tst in tRtsReoRunJob
set reoTst from rts in tRtsReoRunPart
staTime t : t an integer = number of hours
set reoTst from rts into tRtsReoRunPart
reoTime t : t an integer = number of hours
set reoTime from reoTst in tRtsReoRunPart
history:
27.19.13 6.2 neues sql interface
********/ /*** end comment for end help ********************************
17.09.13 6.1 leere sta werden nicht mehr in tdbState eingefügt,
das eliminiert part überlappungen
9.09.11 5.7 reoTime implementiert und new sql copy
7.02.11 5.61 new sql copy
17.01.11 5.6 Refactoring, new copies and removed unnecessary one's
11.10.10 5.4 für DVBP usw. nur -dis DB(D*), sonst gehts viel zulange
und Fortsetzung Call mit limit(*) after läuft nicht richtig
1.10.10 1.0 nach jedem refresh staTime 240, staLate ausgebaut
27.09.10 rename auf checkRef --> reoRefSt, tb s100447.tReo*
13.07.10 falsche new enough Meldung eliminiert
09.07.10 hours parameter ==> allow to update very old jobs
14.06.10 tstRts.t.tDbState, -ssid ==> kein sql(Dis)connect
9.12.09 FortsetzungsZeilen --- ignorieren (statt Absturz)
7.12.09 plus dislay ohne sp(*) um auch gestoppte DB's zu bekommen
28.10.09 W. Keller new
***********************************************************************/
parse upper arg ssid parm2
call errReset 'h'
call sqlIni
say 'reoRefSt v6.2' ssid parm2
call errReset 'h'
if pos('-', ssid) > 0 then do
m.doConn = 0
ssid = strip(ssid, 'b', '-')
end
else if ssid = '' | pos('?', ssid rest) > 0 then
return help()
else
m.doConn = 1
call errAddCleanup 'call cleanup'
if m.doConn then
call sqlConnect ssid
call sqlCommit
call makeTableNames ssid, 's100447'
m.staLevel = 'S'
m.hours = 240
parse upper var parm2 fun w2 rest
if fun = '' then
fun = 'REF'
do until fun = ''
only1 = 0
m.doAll = 0
if datatype(fun, 'n') then do
call doRefresh ssid, m.dbSt, fun
only1 = 1
end
else if abbrev('REFRESH', fun) | abbrev('REFALL', fun) then do
m.doAll = abbrev('REFALL', fun, 4)
say fun '???==> all='m.doAll
p2 = w2
only1 = \ datatype(p2, 'n')
if only1 then
p2 = 60
call doRefresh ssid, m.dbSt, p2
end
else if abbrev('STALEVEL', fun) then do
if wordPos(w2, 'N J P S') < 1 then
call err 'bad parm for staLevel' w2 'in' parm2
m.staLevel = w2
end
else if abbrev('HOURS', fun) then do
if \ datatype(w2, 'n') then
call err 'hours not numeric' w2 'in' parm2
m.hours = w2
end
else if abbrev('STAJOB', fun) then do
if w2 = '' then
call err 'staJob parms job missing in' parm2
call updateStats w2, m.hours
end
else if abbrev('STATIME', fun) then do
if \ datatype(w2, 'n') then
call err 'staTime parm time not numeric' w2 'in' parm2
call updateStats '', w2
end
else if abbrev('REOTIME', fun) then do
if \ datatype(w2, 'n') then
call err 'reoTime parm time not numeric' w2 'in' parm2
call updateReoTime '', w2
end
else do
call err 'bad parm' fun 'in' ssid parm2
end
if only1 then
parse upper value rest w2 with fun w2 rest
else
parse upper var rest fun w2 rest
end
if m.doConn then
call sqlDisconnect
exit 0
cleanup: procedure expose m.
say 'cleanup trying rollback'
if sqlUpdate(,'rollback', '*') \= 0 then
call errSay 'cleanup trying rollback \n'sqlMsg(), ,'w'
if m.doConn == 1 then do
say 'cleanup trying disconnect'
if sqlDisconnect('*') \= 0 then
call errSay 'cleanup trying disconnect \n'sqlMsg(), ,'w'
end
return
endProcedure cleanup
/*--- view and tableNames, original in reoCheck ----------------------*/
makeTableNames: procedure expose m.
parse arg ssid, q
if q = 'OA1P' wordPos(ssid, 'DBAF DBTF DBZF DBLF') > 0 then
q = overlay(substr(ssid, 3, 1), q, 4)
m.rrTS = q".vReoTS"
m.rrIx = q".vReoIX"
m.dbSt = q".tDbState"
m.exJob = q".vReoJobParms"
m.ruJob = q".tReoRunJob"
m.ruPart = q".tReoRunPart"
m.ruTsSt = q".tReoRunTSStats"
m.ruIxSt = q".tReoRunIXStats"
m.tsStats= q".vReoTSStatsFix"
return
endProcedure makeTableNames
/*--- load table tDbState with new infos from -dis ------------------*/
doRefresh: procedure expose m.
parse arg ssid, tb, age
m.where = "where db='' and sp = '' and ty = '@'"
cnt = sql2St( ,
"select sta, current timestamp -" age "seconds,current timestamp",
"from" tb m.where, ll, 'sta lim tst')
if cnt \= 1 then
return err(cnt 'control records in' tb 'in' ssid)
lim = space(translate(m.ll.1.lim, ' ', '.-'), 0)
tst = space(translate(m.ll.1.tst, ' ', '.-'), 0)
sta = m.ll.1.sta
if sta >>= lim then do
say 'reoRefSt:' tb 'is new enough - no refresh'
return
end
call sqlUpdate , "update" tb "set sta = '"tst"'" m.where
call sqlUpdate ,"delete from" tb "where not ("substr(m.where, 7)")",
, 100
call sqlUpdPrep 7,
, 'insert into' tb '(db, sp, paFr, paTo, ty, sta)',
'values(?, ?, ?, ?, ?, ?)'
m.ins = 0
m.dup = 0
if wordPos(ssid, 'DVBP DVTB') > 0 & \ m.doAll then
dbLi = 'DB(D*)'
else
dbLi = 'DB(*)'
call displayInsert ssid, '-DIS' dbLi ' RESTRICT'
call displayInsert ssid, '-DIS' dbLi 'SPACE(*) RESTRICT'
call displayInsert ssid, '-DIS' dbLi ' ADVISORY'
call displayInsert ssid, '-DIS' dbLi 'SPACE(*) ADVISORY'
call sqlCommit
call updateStats '', 240
return
endProcedure doRefresh
/*--- do one -dis db... and insert it into table --------------------*/
displayInsert: procedure expose m.
parse upper arg ssid, aCmd aDb aRest
/* loop with fromDb toDB is extremely slow, do not use| */
call debug 'displayInsert' time() aCmd aDb aRest
if \ abbrev(aDb, 'DB(') then
call err 'no db( in 2. word of:' aCmd aDb aRest
aDbPr = strip(translate(substr(aDB, 4), ' ', '*)'))
say '????' aCmd aDb aRest '==> aDb='aDb 'aDbPr='aDbPr
m.prNext = 500
m.dbs = 0
m.laDb = ''
cBef = 0
m.cc.0 = 0
do disX=1
if disX == 1 then do
looping = sqlDsnCont(cc, ssid, aCmd aDb aRest 'limit(5)')
if looping then do
if aDbPr \== m.dbPre then do
call sql2one 'select min(name), max(name)',
"from sysibm.sysDatabase where name like '"aDbPr"%'",
, xx, ':m.dbMin, :m.dbMax'
m.dbPre = aDbPr
say '???dbPre' aDbPr '==>' m.dbMin m.dbMax
end
d1 = m.dbMin
end
end
else do
if \ looping | aDbPr \== m.dbPre then
call err 'not looping'
if m.cuDb = m.laDb then
call err 'lastDb' m.laDb '= current' m.cuDb
d1 = m.cuDb
m.laDb = m.cuDb
end
if looping then
looping = sqlDsnCont(cc, ssid, aCmd 'db('d1':'m.dbMax')' ,
aRest 'limit(137)')
disFi = 1
cx = 0
do forever
do cx=cx+1 to m.cc.0 while \ abbrev(m.cc.cx, 'DSNT362I ')
end
if cx > m.cc.0 then do
if looping then
leave
call progress cx, db'.'sp
return
end
dx = pos('DATABASE =', m.cc.cx)
sx = pos('STATUS =' , m.cc.cx)
if dx < 1 | sx <= dx then
call err 'bad DSNT362I line' cx':' m.cc.cx
db = word(substr(m.cc.cx, dx+10), 1)
if disFi then do
say '???disFi db='db 'cuDb='m.cuDb
disFi = 0
end
if db <> m.cuDb then do
say '???<> db='db 'cuDb='m.cuDb 'last='m.laDb
if \ abbrev(db, aDbPr) then do
call progress cx, db'.'sp
say '????? return no abbrev'
return
end
m.cuDb = db
m.dbs = m.dbs + 1
end
sta = strip(substr(m.cc.cx, sx+8))
call tbIns db, ,0, 0, 'D', sta, cx
do cx=cx+1 while abbrev(m.cc.cx, ' ')
end
if abbrev(m.cc.cx, 'DSNT397I ') then do
cx = cx + 1
if looping & cx >= m.cc.0 then
leave
if \ abbrev(space(m.cc.cx, 1),
, 'NAME TYPE PART STATUS ') then
call err 'NAME TYPE PART STATUS mismatch' cx m.cc.cx
txNa = pos('NAME', m.cc.cx)
txTy = pos('TYPE', m.cc.cx)
txPa = pos('PART', m.cc.cx)
txSt = pos('STAT', m.cc.cx)
txEn = verify(m.cc.cx, ' ', 'n', txSt+6)
if 0 then say 'title' txNa txTy txPa txSt txEn cx m.cc.cx
cx=cx+1
do forever
do while abbrev(m.cc.cx, '----')
cx = cx + 1
end
if cx + cBef >= m.prNext then
call progress cx + cBef, db'.'sp
if abbrev(m.cc.cx, '*') then
leave
parse var m.cc.cx sp =(txTy) ty . =(txPa) paFr . ,
=(txSt) sta =(txEn)
sp = strip(sp)
if words(sp) \= 1 | wordPos(ty, 'TS IX') < 0 then
call err 'bad name or type' cx':'m.cc.cx
if paFr == '' | paFr == 'L*' then
paFr = 0
else if abbrev(paFr, 'D') | abbrev(paFr, 'L') then
paFr = substr(paFr, 2)
if \ datatype(paFr, 'n') then
call err 'part not numeric' cx':'m.cc.cx
paTo = paFr
cw = cx
cx = cx + 1
if abbrev(m.cc.cx, ' -THRU ') then do
parse var m.cc.cx =(txPa) paTo . =(txSt)
if \ datatype(paTo, 'n') then
call err '-thru part not numeric' cx':'m.cc.cx
cx = cx + 1
end
if sta <> '' then
call tbIns db, sp, paFr, paTo, left(ty, 1), sta, cw
end
end
if m.cc.cx = '******** NO SPACES FOUND' then
nop
else if abbrev(m.cc.cx, '******* DISPLAY OF DATABASE ') ,
& word(m.cc.cx,5) == db then do
if word(m.cc.cx,6) == 'ENDED' then
nop
else if word(m.cc.cx,6) == 'TERMINATED' & looping then
leave
end
else
call err 'database' db 'ENDED mismatch' cx':' m.cc.cx
if 0 then say 'end db' db cx m.cc.cx
end
/* call err 'end of display database' db 'not found' */
end /* display loop */
endProcedure displayInsert
/*--- dsn Command, return true if continuation needed ----------------*/
sqlDsnCont: procedure expose m.
parse arg cc, ssid, cmd
say '???dsnCont' cmd
cont = sqlDsn(cc, ssid, cmd, 12) <> 0
if cont then do
cz = m.cc.0
cy = cz - 1
if \ abbrev(m.cc.cy, DSNT311I) ,
| \ abbrev(m.cc.cz, 'DSN9023I') then
call err 'sqlDsn rc=12 for' cmd 'out='cz ,
'\n'cy'='m.cc.cy'\n'cz'='m.cc.cz
m.cc.0 = cz-2
end
return cont
endProcedure sqlDsnCont
/*--- insert one tuple into tDbState ---------------------------------*/
tbIns: procedure expose m.
parse arg db, sp, paFr, paTo, ty, sta, cx
if sta = 'RW' then
return
if 0 then
say 'tbIns' db'.'sp'.'paFr'-'paTo'.'ty':'sta '#'cx'#'strip(m.cc.cx)
if sqlupdArgs('7 -803', db, sp, paFr, paTo, ty, sta) >= 0 then
m.ins = m.ins + 1
else
m.dup = m.dup + 1
return
endProceedure tbIns
/*--- progress message -----------------------------------------------*/
progress: procedure expose m.
parse arg cx, msg
say 'reoRefSt:' m.dbSt time() /* 'line' cx 'of' m.cc.0, */ ,
', ins' m.ins', dup' m.dup', dbs' m.dbs msg
m.prNext = m.prNext + 500
return
endProcedure progress
/*--- update tReoRun* statistics (from latest rts) -------------------*/
updateStats: procedure expose m.
parse arg job, time
if m.staLevel == 'N' then
return
if job = '' then
wh = ''
else if verify(job, '_%', 'm') > 0 then
wh = "job like '"strip(job)"'"
else
wh = "job = '"strip(job)"'"
if wh = '' then do
st = 'newer' time 'hours'
wh = 'j.tst >= current timestamp -' time 'hours'
end
else do
st = wh
wh = 'j.'wh 'and j.tst >= current timestamp -' time 'hours'
end
if job \= '' then do
call sqlUpdate , "update" m.ruJob 'j' ,
"set eoj = current timestamp" ,
"where" wh "and eoj is null" , 100
say 'reoRefSt:' m.sql..updateCount ,
'eoj updated for' st 'in' m.ruJob
call sqlCommit
end
if m.staLevel == 'J' then
return
whPSR = 's.tst = p.tst and s.rng = p.rng and s.partition = p.part' ,
'and r.dbid = s.dbid and r.psid = s.psid' ,
'and r.partition = s.partition and r.instance = s.instance'
whJWSR = 'w.tst = j.tst' and repAll(whPSR, 'p.', 'w.')
call sqlUpdate , 'update' m.ruPart 'p',
'set p.reoTst = (select r.reorgLastTime',
'from' m.ruTsSt 's, sysibm.sysTablespacestats r',
'where' whPSR ,
') where (p.tst, p.rng, p.part) in' ,
'( select w.tst, w.rng, w.part' ,
'from' m.ruJob 'j,' m.ruPart 'w,' m.ruTSSt 's,' ,
'sysibm.sysTablespacestats r',
"where" wh "and w.ty = 't' and" whJWSR,
'and r.reorgLasttime > j.tst',
'and (j.eoj is null or r.reorgLastTime < j.eoj)' ,
'and (w.reoTst is null or r.reorgLastTime < w.reoTst)',
')', 100
say 'reoRefSt:' m.sql..updateCount ,
'ts reoTst updated for' st 'in' m.ruPart
whPSR = repAll(whPsr, '.psid', '.isobid')
whJWSR = 'w.tst = j.tst' and repAll(whPSR, 'p.', 'w.')
call sqlUpdate , 'update' m.ruPart 'p',
'set p.reoTst = (select r.reorgLastTime',
'from' m.ruIxSt 's, sysibm.sysIndexSpacestats r',
'where' whPSR ,
') where (p.tst, p.rng, p.part) in' ,
'( select w.tst, w.rng, w.part' ,
'from' m.ruJob 'j,' m.ruPart 'w,' m.ruIxSt 's,' ,
'sysibm.sysIndexSpaceStats r',
"where" wh "and w.ty = 'i' and" whJWSR,
'and r.reorgLasttime > j.tst',
'and (j.eoj is null or r.reorgLastTime < j.eoj)' ,
'and (w.reoTst is null or r.reorgLastTime < w.reoTst)',
')', 100
say 'reoRefSt:' m.sql..updateCount ,
'ix reoTst updated for' st 'in' m.ruPart
call sqlCommit
call updateReoTime job, time
return
endProcedure updateStats
/*--- update tReoRunPart reoTime (from reoTst in tReoRunPart) --------*/
updateReoTime: procedure expose m.
parse arg job, time
if m.staLevel == 'N' then
return
if job = '' then
wh = ''
else if verify(job, '_%', 'm') > 0 then
wh = "job like '"strip(job)"' and"
else
wh = "job = '"strip(job)"' and"
fr = 'from' m.ruPart 'p'
if wh \== '' then
fr = fr 'join' m.ruJob 'j on p.tst = j.tst'
st = wh 'newer' time 'hours'
wh = wh 'p.tst >= current timestamp -' time 'hours'
say 'updating reoTime for' st
call sqlQuery 1, 'select p.tst, rng, part, paVon, paBis',
', p.sta, reoTst, reoTime',
fr 'where' wh ,
'order by p.tst, rng, part'
cJob = 0
cRng = 0
cPrt = 0
cUpd = 0
/* fVars = ':tst, :rng, :part, :paVon, :paBis, :sta,' ,
':reoTst :reoTst.sqlInd, :reoTime :reoTime.sqlInd' */
grpBrk = 9 * (\ sqlFetch(1, f1))
do while grpBrk < 9
cJob = cJob + 1
jTst = m.f1.TST
jLaEnd = m.f1.TST
jErr = 0
do until grpBrk > 1 /* each Rng in job */
cRng = cRng + 1
rRng = m.f1.RNG
rVon = m.f1.paVon
rReoTime = ''
rOk = 1
rEnd = ''
rSta = m.f1.sta
do until grpBrk > 0 /* each part in Rng */
/* say m.f1.tst m.f1.rng part' ,
'von' m.f1.paVon m.f1.paBis m.f1.sta ,
'reoTst' m.f1.reoTst ,
'reoTime' m.f1.reoTime
*/ cPrt = cPrt + 1
erI = 'in updateReoTime tst='m.f1.tst ,
'rng='m.f1.rng 'part='m.f1.part
if m.f1.rng < 1 then
call URTErr 'bad rng' m.f1.rng erI
if m.f1.part = m.f1.paVon then
rReoTime = m.f1.reoTime
if m.f1.reoTst == m.sqlNull then
rOk = 0
else if m.f1.reoTst <<= jLaEnd then
call URTErr 'reoTst' m.f1.reoTst '<<= la' jLaEnd erI
else if m.f1.reoTst >> rEnd then
rEnd = m.f1.reoTst
if \ sqlFetch(1, f1) then
grpBrk = 9
else if jTst \== m.f1.tst then
grpBrk = 2
else
grpBrk = rRng \== m.f1.rng
end /* each part in Rng */
if rSta == '0' then
nop
else if rReoTime == '' then
call URTErr 'no pavon found' erI
else if \ rOK | jErr then
jLaEnd = ''
else do
if rReotime == m.sqlNull & jLaEnd \== '' then
call updateReotimeRng
jLaEnd = rEnd
end
end /* each Rng in job */
call updateReotimeJob
end /* each Job */
call sqlCommit
say cJob 'jobs,' cRng 'ranges,' cPrt 'parts,' cUpd 'updates' ,
'of reotime in' m.ruPart
return
endProcedure updateReoTime
updateReoTimeRng:
/* say 'rRng' jTst rRng 'c' cJob cRng cPrt cUpd 'ok' rOk 'rEnd' rEnd ,
'paVon' rVon 'reoTime' rReoTime 'jlaEnd' jLaEnd
*/ numeric digits 12
nt = (substr(rEnd, 12, 2) * 60 ,
+substr(rEnd, 15, 2)) * 60 ,
+substr(rEnd, 18 ) ,
-((substr(jLaEnd, 12, 2) * 60 ,
+substr(jLaEnd, 15, 2)) * 60 ,
+substr(jLaEnd, 18 ))
sq = "update" m.ruPart "set reoTime = " ,
"(days('"left(rEnd, 10)"')" ,
"-days('"left(jLaEnd, 10)"')) * 86400" ,
"+" format(nt, ,0) ,
"where tst = '"jTst"' and rng =" rRng ,
"and part =" rVon "and part = paVon"
/* say ' updating reotime' nt '= -'jLaEnd'+'rEnd erI
*/ call sqlUpdate , sq
if m.sql..updateCount <> 1 then
call err m.sql..updateCount 'updates for' sq':' erI
cUpd = cUpd + 1
return
endSubroutine updateReoTimeRng
updateReoTimeJob:
if cJob // 1000 = 0 | jErr then
say time() 'end job' jTst',' cJob 'jobs,' cRng 'ranges,',
cPrt 'parts,' cUpd 'updates' erI
if jErr then do
/* in case eoj is wrong */
call sqlUpdate , "update" m.ruJob "set eoj = tst",
"where tst ='"jTst"'"
call sqlUpdate "update" m.ruPart "set reoTime=null,reoTst=null",
"where tst ='"jTst"'"
say '>>>>>' m.sql..updateCount m.ruPart'.reoTst set to null' erI
say ''
end
return
endSubroutine updateReoTimeRngJob
URTErr:
say '***error:' arg(1)
jErr = 1
return
endSubroutine URTErr
/* copy SQL begin ***************************************************
Achtung: inc generiert sql aus sqlRx, Aenderungen nur in sqlRx|
sql interface
***********************************************************************/
/*--- initialize sql -----------------------------------------------*/
sqlIni: procedure expose m.
if m.sql_ini == 1 then
return
m.sql_ini = 1
m.sqlNull = '---'
m.sqlInd = 'sqlInd'
m.sql_defCurs= 49
m.sqlCAMsg = 0
m.sqlSuMsg = 2
m.sql_csmhost = ''
isInProd = wordPos(sysvar(sysNode), 'RZ2 RZ4') > 0
m.sqlRetOK = 'dne' copies('rod', \ isInProd)
return 0
endProcedure sqlIni
/*--- get default db2System ------------------------------------------*/
sqlDefaultSys: procedure expose m.
parse arg
if sysvar(sysnode) == 'RZ1' then
return 'DBAF'
else if sysvar(sysnode) == 'RZ4' then
return 'DP4G'
else
call err 'no default subsys for' sysvar(sysnode)
endProcedure sqlDefaultSys
/*--- connect to the db2 subsystem sys -----------------------------*/
sqlConnect: procedure expose m.
parse upper arg sys, ggRetOk
call sqlIni
address tso "SUBCOM DSNREXX"
if rc <> 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
if sys = '-' then
return 0
if sys == '' then
sys = sqlDefaultSys()
m.sql_dbSys = sys
ggSqlStmt = 'connect' sys
address dsnRexx ggSqlStmt
if rc = 0 then
return 0
interpret sqlErrorHandler(rc, ggRetOk, ggSqlStmt)
endProcedure sqlConnect
/*--- diconnect from db2 ---------------------------------------------*/
sqlDisconnect: procedure expose m.
parse arg retOk
ggSqlStmt = 'disconnect'
m.sql_dbSys = ''
m.sql_csmHost = ''
address dsnRexx ggSqlStmt
if rc = 0 then
return 0
interpret sqlErrorHandler(rc, ggRetOk, ggSqlStmt)
endProcedure sqlDisconnect
/*--- reset sql cursor 'c'cx fields ----------------------------------*/
sqlReset: procedure expose m.
parse arg cx
m.sql.cx.updateCount = ''
m.sql.cx.resultSet = ''
m.sql.cx.d.sqlD = 'noSqlDA'
m.sql.cx.i.sqlD = 'noDescInp'
m.sql.cx.fetchVars = ''
m.sql.cx.type = ''
call sqlRemVars 'SQL.'cx'.COL'
return
endProcedue sqlReset
/*--- execute a query from sql, with one resultset -------------------*/
sqlQuery: procedure expose m.
parse arg cx, src, feVa, retOk
call sqlReset cx
src = inp2str(src, '%qn%s ')
s1 = ''
if pos(left(feVa, 1), '?:') < 1 then
s1 = 'into :M.SQL.'cx'.D'
res = sqlExec('prepare s'cx s1 'from :src', retOk)
if res < 0 then
return res
call sqlFetchVars cx, feVa
call sqlExec 'declare c'cx 'cursor for s'cx
res = sqlExec('open c'cx, retOk)
if res < 0 then
return res
m.sql.cx.updateCount = sqlErrd.3
m.sql.cx.resultSet = cx
return res
endProcedure sqlQuery
/*--- prepare a query from sql, with one resultset -------------------*/
sqlQueryPrep: procedure expose m.
parse arg cx, src, feVa, retOk
call sqlReset cx
src = inp2str(src, '%qn%s ')
s1 = ''
if feVa == '' | feVa = 'd' then
s1 = 'into :M.SQL.'cx'.D'
res = sqlExec('prepare s'cx s1 'from :src', retOk)
if res < 0 then
return res
call sqlFetchVars cx, feVa
call sqlExec 'declare c'cx 'cursor for s'cx
return sqlExec('describe input s'cx 'into :M.SQL.'cx'.I')
endProcedure sqlQueryPrep
sqlQueryArgs: procedure expose m.
parse arg cx retOk
do ix=1 to arg()-1
call sqlDASet cx , 'I', ix, arg(ix+1)
end
res = sqlExec('open c'cx 'using descriptor :M.SQL.'cx'.I', retOk)
if res < 0 then
return res
m.sql.cx.updateCount = sqlErrd.3
m.sql.cx.resultSet = cx
return res
endProcedure sqlQueryArgs
/*--- fetch next row to m.dst.* at end return false ------------------*/
sqlFetch: procedure expose m.
parse arg cx, dst, retOk
fetCode = sqlExec('fetch c'cx 'into' m.sql.cx.fetchVars, 100 retOk)
if fetCode == 100 then
return 0
if fetCode < 0 then
return fetCode
interpret m.sql.cx.fetchCode
return 1
endProcedure sqlFetch
/*--- close cursor 'c'cx ---------------------------------------------*/
sqlClose: procedure expose m.
parse arg cx, retOk
return sqlExec('close c'cx, retOk)
endProcedure sqlClose
/*-- execute an sql with no resultset, but possibly outParms ---------*/
sqlUpdate: procedure expose m.
parse arg cx, src, retOk
m.sql.cx.updateCount = ''
m.sql.cx.resultSet = ''
bx = verify(src, '( ')
if bx > 0 then
fun = translate(word(substr(src, bx), 1))
if fun = 'SET' then do
w2 = translate(word(substr(src, bx), 2))
if \ abbrev(w2, ':') then
return sqlExec('execute immediate :src', retOk)
trace ?r
ex = pos('=', w2)
if ex = 0 then
ex = length(w2)+1
var = strip(substr(w2, 2, ex-2))
if var = '' then
call err 'bad hostVar in' src
m.sql.outVar = var
src2 = 'set :M.sql.out.'var substr(w, ex) subword(src, 3)
return sqlExec(src2, retOk)
end
if fun == 'DECLARE' then do
if 'GLOBAL' == translate(word(substr(src, bx), 2)) then
return sqlExec('execute immediate :src', retOk)
end
res = sqlExec(src, retOk)
if wordPos(fun, 'DELETE INSERT UPDATE') > 0 then
m.sql.cx.updateCount = sqlErrd.3
return res
endProcedure sqlUpdate
/*-- prepare an update -----------------------------------------------*/
sqlUpdPrep: procedure expose m.
parse arg cx, src, retOk
res = sqlExec('prepare s'cx 'from :src', retOk)
return sqlExec('describe input s'cx 'into :M.SQL.'cx'.I')
endProcedure sqlUpdPrep
/*-- execute a prepared update with the given arguments --------------*/
sqlUpdArgs: procedure expose m.
parse arg cx retOk
do ix=1 to arg()-1
call sqlDASet cx , 'I', ix, arg(ix+1)
end
res = sqlExec('execute s'cx 'using descriptor :M.SQL.'cx'.I',
, retOk)
m.sql.cx.updateCount = sqlErrd.3
return res
endProcedure sqlUpdArgs
/*-- execute a query, update or call ---------------------------------*/
sqlExecute: procedure expose m.
parse arg cx, src, retOk
src = inp2Str(src, '-sql')
f = translate(word(src, 1))
bx = pos('(', f)
if bx > 0 then
f = left(f, max(1, bx-1))
m.sql.cx.fun = f
if f == 'SELECT' | f == 'WITH' | f == '(' then
return sqlQuery(cx, src, , retOk)
else if f == 'CALL' then
call err 'implement sql call for:' src
else
return sqlUpdate(cx, src, retOk)
endProcedure sqlExecute
/*-- fetch all rows to stem and close --------------------------------*/
sqlFetch2St: procedure expose m.
parse arg cx, dst, retOK
do sx=1 while sqlFetch(cx, dst'.'sx)
end
res = sx-1
m.dst.0 = sx-1
call sqlClose cx
return m.dst.0
endProcedure sqlFetch2St
/*-- execute a query, copy result to stem ----------------------------*/
sql2St: procedure expose m.
parse arg src, dst, feVa, retOK
cx = m.sql_defCurs
res = sqlQuery(cx, src, feVa, retOk)
return sqlFetch2St(cx, dst, retOk)
endProcedure sql2St
/*-- return first column of the only row and close -------------------*/
sqlFetch2One: procedure expose m.
parse arg cx, dst, retNone
f1 = sqlFetch(cx, dst)
if f1 then
f2 = sqlFetch(cx, dst)
call sqlClose cx
if \ f1 then
if retNone \== '' then
return substr(retNone, 2)
else
call err 'sqlFetch2One: no row returned'
else if f2 then
call err 'sqlFetch2One: more than 1 row'
c1 = m.sql.cx.col.1
return m.dst.c1
endProcedure sqlFetch2One
/*-- fxecute a query and return first row of the only colun
if > 1 row fail, if 0 rows return arg(3) or fail ----------*/
sql2One: procedure expose m.
parse arg src, dst, feVa, retOk, retNone
cx = m.sql_defCurs
call sqlQuery cx, src, feVa, retOk
return sqlFetch2One(cx, dst, retNone)
endProcedure sql2One
/*--- describe table and return sqlDA --------------------------------*/
sqlDescribeTable: procedure expose m.
parse upper arg tb, force
if force == 1 | \ datatype(m.sql.table.tb.sqlD, 'n') then
call sqlExec 'describe table :tb into :M.SQL.TABLE.'tb
return 'SQL.TABLE.'tb
endProcedure sqlDescribeTable
/*--- return select column list for table tb
omit Blobs (blobMax < 0) or substr(blob, 1, blobMax) ----------*/
sqlColList: procedure expose m.
parse arg tb al, blobMax
sd = sqlDescribeTable(tb)
bs = ''
lst = ''
if al \== '' & right(al, 1) \== '.' then
al = al'.'
do sx=1 to m.sd.sqld
if wordPos(m.sd.sx.sqlType, '404 405 408 409 412 413') < 1 then
lst = lst',' al || m.sd.sx.sqlName
else do
bs = bs m.sd.sx.sqlName
if blobMax >= 0 then
lst = lst', length('al || m.sd.sx.sqlName')' ,
m.sd.sx.sqlName'Len' ,
|| ', substr('al || m.sd.sx.sqlName ,
|| ', 1,' blobMax')' m.sd.sx.sqlName
end
end
m.sd.colList = substr(lst, 3)
m.sd.blobs = strip(bs)
return substr(lst, 3)
endProcedure sqlColList
/*--- use describe output to generate column names,
'' use names from ca (rexxified)
nms+ use names, check ca for null values
?('?'?nm)+ use names, check for null if preceeded by ?
:... use string as is
fetchVariables and sqlNull names ---------------------*/
sqlFetchVars: procedure expose m.
parse arg cx, src, cd
m.sql.cx.fetchCode = cd
st = 'SQL.'cx'.COL'
call sqlRemVars st
if abbrev(src, ':') then do
m.sql.cx.fetchVars = src
return
end
m.sql.cx.fetchVars = ''
vrs = ''
sNu = ''
if abbrev(src, '?') then do
r = substr(src, 2)
do wx=1 to words(src)
cn = word(src, wx)
if abbrev(cn, '?') then
call sqlRexxAddVar substr(cn, 2), 0, 1
else
call sqlRexxAddVar cn, 0, 0
end
end
else if src <> '' then do kx=1 to words(src)
cn = word(src, kx)
call sqlRexxAddVar cn, 0, m.sql.cx.d.kx.sqlType // 2
end
else do kx=1 to m.sql.cx.d.sqlD
call sqlRexxAddVar m.sql.cx.d.kx.sqlName, 1 ,
, m.sql.cx.d.kx.sqlType // 2
end
m.sql.cx.fetchVars = substr(vrs, 3)
m.sql.cx.fetchCode = sNu cd
return
endProcedure sqlFetchVars
sqlRexxAddVar:
parse arg nm, nicify, hasNulls
nm = sqlAddVar(st, nm, nicify)
if \ hasNulls then
vrs = vrs', :m.dst.'nm
else do
vrs = vrs', :m.dst.'nm ':m.dst.'nm'.sqlInd'
sNu = sNu 'if m.dst.'nm'.sqlInd < 0 then' ,
'm.dst.'nm '= m.sqlNull;'
end
return
endSubroutine sqlRexxAddVar
sqlCol2kx: procedure expose m.
parse arg cx, nm
if symbol('M.SQL.CX.COL.NM') \== 'VAR' then
return ''
kx = m.sql.cx.col.nm
if m.sql.cx.col.kx \== nm then
call err 'sqlCol2kx' nm '==>' kx 'but' m.sql.cx.col.kx
return kx
endProcedure sqlCol2kx
sqlRemVars: procedure expose m.
parse arg st
if symbol('m.st.0') == 'VAR' then do
do sx=1 to m.st.0
nm = m.st.sx
drop m.st.nm m.st.sx
end
end
m.st.0 = 0
return
endProcedure sqlRemVars
sqlAddVar: procedure expose m.
parse arg st, sNa, nicify
sx = m.st.0 + 1
if 1 | nicify then do
cx = verifId(sNa)
if cx > 0 then /* avoid bad characters for classNew| */
sNa = left(sNa, cx-1)
upper sNa
if sNa == '' | symbol('m.st.sNa') == 'VAR' then
sNa = 'COL'sx
end
m.st.0 = sx
m.st.sx = sNa
m.st.sNa = sx
return sNa
endProcedure sqlAddVar
/*--- set one value in a DA, handle nulls ----------------------------*/
sqlDASet: procedure expose m.
parse arg cx, da, ix, val
m.sql.cx.da.ix.sqlData = val
m.sql.cx.da.ix.sqlInd = - (val == m.sqlNull)
/* data types schienen einmal nicht zu funktionieren .......
if wordPos(m.da.ix.sqlType, '384 385 388 389 392 393') > 0 then
m.da.ix.sqlType = 448 + (m.da.ix.sqlType // 2) */
return
endProcedure sqlDASet
sqlCommit: procedure expose m.
parse arg src
return sqlUpdate(, 'commit')
endProcedure sqlCommit
/*--- execute sql thru the dsnRexx interface -------------------------*/
sqlExec: /* no procedure, to keep variables sql... */
parse arg ggSqlStmt, ggRetOk
m.sql_HaHi = ''
address dsnRexx 'execSql' ggSqlStmt
/* say 'sqlCode' sqlCode 'rc' rc 'for' ggSqlStmt ggNo */
if rc = 0 then
return 0
interpret sqlErrorHandler(rc, ggRetOk, ggSqlStmt)
endProcedure sqlExec
sqlErrorHandler: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
parse arg drC, retOk, verb rest
if drC == 0 then
return 'return 0'
if wordPos(drC, '1 -1') < 0 then
return "call err 'dsnRexx rc" drC"' sqlmsg()"
if pos('-', retOK) < 1 then
retOK = retOk m.sqlRetOk
if pos('*', retOK) > 0 | wordPos(sqlCode, retOK) > 0 then do
if sqlCode < 0 & pos('say', retOK) > 0 then
return "call outSt errMsg(' }'sqlMsg()); return" sqlCode
else
return "return" sqlCode
end
upper verb
if verb == 'DROP' then do
if (sqlCode == -204 | sqlCode == -458) ,
& wordPos('dne', retok) > 0 then
return 'return' sqlCode
if sqlCode = -672 & wordPos('rod', retok) > 1 then do
hahi = m.sql_HaHi ,
|| sqlMsgLine(sqlCode, 'tb='sqlErrMc ,verb rest)'\n'
call sqlExec 'alter table' SqlErrMc ,
'drop restrict on drop'
hahi = hahi || m.sql_HaHi ,
|| sqlMsgLine(sqlCode, , ggSqlStmt)'\n'
call sqlExec verb rest
m.sql_HaHi = hahi
return 'return' sqlCode
end
end
if drC < 0 then
return "call err sqlmsg(); return" sqlCode
if (sqlCode <> 0 | sqlWarn.0 ^==' ') & pos('w',retOK) < 1 then
return "call outSt errMsg(' }'sqlMsg()); return" sqlCode
return 'return' sqlCode
endProcedure sqlErrorHandler
sqlMsgLine: procedure expose m. sqlErrD.
parse arg res, cnt, src, plus
verb = translate(word(src, 1))
if datatype(res, 'n') then
res = 'sqlCode' res
if cnt \== '' then do
res = res',' cnt
vx = wordPos(translate(word(src,1)), 'DELETE INSERT UPDATE')
if datatype(cnt, 'n') then
if vx > 0 then
res = res 'rows' word('deleted inserted updated', vx)
else if cnt <> 0 then
res = res 'rows updated'
end
if plus \== '' then
res = res',' plus
if abbrev(res, ', ') then
res = substr(res, 3)
if src \== '' then do
ll = 75 - length(res)
aa = strip(src)
if length(aa) > ll then
aa = space(aa, 1)
if length(aa) > ll then
aa = left(aa, ll-3)'...'
res = res':' aa
end
return res
endProcedure sqlMsgLine
/*--- send a command to db2 through the TSO dsn processor ------------*/
sqlDsn: procedure expose m.
parse arg st, sys, cmd, rcOk
x = outtrap('M.'st'.')
push 'END'
push cmd
address tso 'DSN SYSTEM('sys')'
rr = rc
x = outtrap(off)
if rr = 0 | rcOk = '*' | wordPos(rr, rcOk) > 0 then
return rr
fl = max(1, m.st.0 - 10)
em = 'rc' rr 'for DSN SYSTEM('sys') cmd' cmd,
'\nOuputlines' fl '-' m.st.0':'
do lx=fl to m.st.0
em = em '\n' strip(m.st.lx, 't')
end
call err em
endProcedure sqlDsn
/*--- issue an sql error message -------------------------------------*/
sqlMsg: /* no procedure, to keep variables sql... */
if \ dataType(sqlCode, 'n') then do
ggRes = 'sqlCode' sqlCode 'not numeric\n'sqlCaMsg()
end
else do
ggRes = sqlDsntiar(sql2CA())
ggWa = sqlMsgWarn()
if ggWa \= '' then
ggRes = ggRes'\nwarnings' ggWa
if m.sqlCAMsg == 1 then
ggRes = ggRes'\n'sqlCaMsg()'\n'sqlCaMsg(sqlCa2Rx(sqlCa))
end
ggSt = 'SQL_HOST'
ggVa = 'SQL_HOST.VAR'
ggBe = 'SQL_HOST.BEF'
call sqlHostVars ggSqlStmt, 12, ggSt
ggFrom = 'ggSqlStmt'
ggW1 = translate(word(ggSqlStmt, 1))
ggW2 = translate(word(ggSqlStmt, 2))
if ggW1 == 'PREPARE' then
ggFrom = sqlHostVarFind(ggSt, 'FROM')
else if ggW1 ggW2 == 'EXECUTE IMMEDIATE' then
ggFrom = sqlHostVarFind(ggSt, 1)
ggPos = 0
if datatype(sqlErrd.5, 'n') & sqlErrd.5 > 0 then do
ggPos = sqlErrd.5
ggRes = ggRes || sqlMsgSrcPos(value(ggFrom), sqlErrd.5)
end
if ggFrom == 'ggSqlStmt' then do
ggRes = ggRes'\nsql =' sqlShorten(ggSqlStmt, 2000, ggPos)
end
else do
ggRes = ggRes'\nsql =' sqlShorten(value(ggFrom), 2000, ggPos)
ggRes = ggRes'\nstmt =' sqlShorten(ggSqlStmt, 2000)
end
ggPref = '\nwith'
do ggXX=1 to m.ggSt.0
if ggFrom = m.ggVa.ggXX then
iterate
ggRes = ggRes || ggPref m.ggBe.ggXX ':'m.ggVa.ggXX ,
'=' sqlShorten(value(m.ggVa.ggXX), 210)
ggPref = '\n '
end
if m.sqlSuMsg == 1 | (m.sqlSuMsg == 2 & m.sql_csmhost \== '') then
ggRes = ggRes'\nsubsys =' m.sql_dbSys ,
|| ', host =' m.sql_csmhost
return ggRes
endSubroutine sqlMsg
sqlShorten: procedure expose m.
parse arg txt, maxL, pos
if length(txt) <= maxL then
return txt
if \ datatype(pos, 'n') | pos < 1 then
pos = 1
ex = pos + min(60, maxL%7)
if ex <= maxL - 4 then
return left(txt, maxL-4) '...'
if ex >= length(txt) then
return left(txt, 67) '...\n'substr(txt, length(txt)-maxL+72)
else
return left(txt, 67) '...\n'substr(txt, ex-maxL+76, maxL-75) ,
'...'
endProcedure sqlShorten
/*--- use dsnTiar to translate sql Info to error text ----------------*/
sqlDsnTiar: procedure expose m.
parse arg ca
if -438 = sqlCa2Rx(ca) then
return '\nSQLCODE = -438:',
'APPLICATION RAISED ERROR WITH sqlState' sqlState ,
'and DIAGNOSTIC TEXT:' sqlErrMc
liLe = 78
msLe = liLe * 10
msg = d2c(msLe,2) || left('', msLe)
len = d2c(liLe, 4)
ADDRESS LINKPGM "DSNTIAR ca msg len"
if rc = 0 then nop
else if rc = 4 then say 'warn linkPgm dsnTiar rc' rc 'sqlCa' ca
else call err 'linkPgm dsnTiar rc' rc 'sqlCa' ca
res = strip(substr(msg, 13, liLe-10))
cx = pos(', ERROR: ', res)
if cx > 0 then
res = left(res, cx-1)':' strip(substr(res, cx+9))
do c=3+liLe by liLe to msLe while substr(msg, c, 10) = ''
res = res'\n 'strip(substr(msg, c+10, liLe-10))
end
return res
endProcedure sqlDsnTiar
/*--- format all rexx sqlCa fields into a message --------------------*/
sqlCaMsg:
return 'sqlCode' sqlCode 'sqlState='sqlState ,
'\n errMC='translate(sqlErrMc, ',', 'ff'x) ,
'\n warnings='sqlWarnCat('+') 'erP='sqlErrP ,
'\n errD.1='sqlErrD.1 '2='sqlErrD.2 '3='sqlErrD.3 ,
'\n errD.4='sqlErrD.4 '5='sqlErrD.5 '6='sqlErrD.6
endProcedure sqlCaMsg
/*--- format the sqlCA into the dsnTiar SQLCA ------------------------*/
sql2Ca: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
if \ (datatype(sqlcode, 'n') & datatype(sqlErrD.1, 'n') ,
& datatype(sqlErrD.3, 'n')) then
return err('sqlCode etc. not numeric\nsqlCa =' sqlCaMsg())
if digits() < 10 then
numeric digits 10
sqlCa = 'SQLCA ' || d2c(136, 4) || d2c(sqlCode, 4) ,
|| d2c(min(70, length(sqlErrMc)), 2)left(sqlErrMc, 70) ,
|| left(sqlErrP, 8) ,
|| d2c(sqlErrD.1, 4)d2c(sqlErrD.2, 4)d2c(sqlErrD.3, 4) ,
|| d2c(sqlErrD.4, 4)d2c(sqlErrD.5, 4)d2c(sqlErrD.6, 4) ,
|| sqlWarnCat() || sqlState
if length(sqlCa) <> 136 then
call err 'sqlCa length' length(sqlCa) 'not 136' ,
'\n'sqlCaMsg() '==>' ca', hex='c2x(ca)
return sqlCa
endProcedure sql2Ca
/*--- extract the fields from the SqlCA and put it to rexx vars ------*/
sqlCA2Rx: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
parse arg ca
numeric digits 10
if length(ca) < 136 | c2d(substr(ca, 9, 4), 4) <> 136 then
call err 'bad sqlCa len' length(ca) 'not 136:' ca', hex='c2x(ca)
sqlCode = c2d(substr(ca, 13 ,4), 4)
sqlErrMC = substr(ca, 19, c2d(substr(ca, 17, 2), 2))
sqlErrP = substr(ca, 89, 8)
do ix=1 to 6
sqlErrD.ix = c2d(substr(ca, 93 + 4 * ix, 4), 4)
end
do ix=0 to 10
sqlWarn.ix = substr(ca, 121 + ix, 1)
end
sqlState = substr(ca, 132, 5)
return sqlCode
endProcedure sqlCA2Rx
/*--- concat the sql warnings with Separator sep --------------------*/
sqlWarnCat: procedure expose m. sqlWarn.
parse arg sep
return sqlWarn.0 || sep,
|| sqlWarn.1||sqlWarn.2||sqlWarn.3||sqlWarn.4||sqlWarn.5||sep ,
|| sqlWarn.6||sqlWarn.7||sqlWarn.8||sqlWarn.9||sqlWarn.10||sep
endProcedure sqlWarnCat
/*--- make the text for sqlWarnings ----------------------------------*/
sqlMsgWarn: procedure expose m. sqlWarn.
r = ''
text =' 1=W var truncated, 1=S scrollable, 1=N nonScrollable,' ,
'2=W nulls in aggregate,' ,
'3=W more cols than vars,' ,
'3=Z more result sets than locators,' ,
'4=W no where, 4=D sensitive dynamic, 4=I insensitive,' ,
'4=S sensitive static,' ,
'5=W not valid sql, 5=1 readOnly, 5=2 readDelete,' ,
'5=3 readDeleteUpdate,' ,
'6=W day changed to month range,' ,
'7=W dec digits truncated,' ,
'8=W char substituted,' ,
'9=W arith excep in count, 9=Z multipe result sets,' ,
'10=W char conversion err in ca,'
do wx = 1 to 10
w = sqlWarn.wx
if w = ' ' then
iterate
t = wx'='w
cx = pos(' 'wx'='w' ', text)
ex = pos(',' , text, cx + 1)
if cx > 0 & ex > cx then
r = r substr(text, cx+1, ex-cx)
else
r = r wx'='w '?,'
end
r = strip(r, 't', ',')
if r = '' & sqlwarn.0 <> '' then
call err 'sqlWarn.0='sqlWarn.0 'but all warns empty'
return r
endProcedure sqlMsgWarn
/*--- show in the source src the point pos (where error occured)
a few lines from src around pos and arrow to pos ----------*/
sqlMsgSrcPos: procedure expose m.
parse arg src, pos
liLe = 68
liCn = 3
afLe = 25
t1 = space(left(src, pos), 1)
t2 = left(' ', substr(src, pos, 1) == ' ' ,
| substr(src, pos+1, 1) == ' ') ,
|| space(substr(src, pos+1), 1)
afLe = min(afLe, length(t2))
if length(t1) + afLe > liLe * liCn then
t1 = '...'right(t1, liLe * liCn - afLe -3)
else if length(t1)+length(t2) > liLe then
t1 = left(' ', (liCn * liLe - length(t1) -afLe) // liLe)||t1
pL = length(t1) // liLe
if length(t2) <= liLe-pL then
tx = t1 || t2
else
tx = t1 || left(t2, liLe-pL-3)'...'
res = '\nsrc' strip(substr(tx, 1, liLe), 't')
do cx=1+liLe by liLe to length(tx)
res = res || '\n +' strip(substr(tx, cx, liLe), 't')
end
loc = 'pos' pos 'of' length(src)
if length(loc)+6 < pL then
return res'\n >' right('>>>'loc'>>>', pL)
else
return res'\n >' left('', pL-1)'<<<'loc'<<<'
endProcdedure sqlMsgSrcPos
/*--- get the hostVars in the sql in src and the word before ---------*/
sqlHostVars: procedure expose m.
parse arg src, cnt, st
cx = 1
sx = 1
do cnt
cx = pos(':', src, cx) + 1
if cx < 2 then
leave
if pos(substr(src, cx, 1), m.ut.alfRexN1) > 0 then
iterate
ex = verify(src, m.ut.alfRex, 'n', cx)
if ex < 1 then
m.st.var.sx = substr(src, cx)
else
m.st.var.sx = substr(src, cx, ex - cx)
if m.st.var.sx == '' | length(m.st.var.sx) > 100 then
iterate
/* search word before */
do bE = cx-2 by -1 to 1 ,
while substr(src, bE, 1) == ' '
end
do bB = bE by -1 to max(1, bE-20),
while pos(substr(src, bB, 1), m.ut.alfa) > 0
end
if bB < bE & bB >= 0 then
m.st.bef.sx = substr(src, bB+1, bE-bB)
else
m.st.bef.sx = ''
sx = sx + 1
end
m.st.0 = sx-1
return sx
endProcedure sqlHostVars
/*--- find the name of hostvar, by index or by before ----------------*/
sqlHostVarFind: procedure expose m.
parse arg st, fnd
if datatype(fnd, 'n') & fnd <= m.st.0 then
return m.st.var.fnd
do ix=1 to m.st.0
if translate(m.st.bef.ix) = fnd then
return m.st.var.ix
end
return ''
endSubroutine sqlHostVarFind
/* copy SQL end **************************************************/
/* copy adrTso begin *************************************************/
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet ---*/
adrTso:
parse arg ggTsoCmd, ggRet
address tso ggTsoCmd
if rc == 0 then return 0
else if ggRet == '*' then return rc
else if wordPos(rc, ggRet) > 0 then return rc
else
call err 'adrTso rc' rc 'for' ggTsoCmd
return /* end adrTso */
/*--- format dsn from tso format to jcl format -----------------------*/
dsn2jcl: procedure expose m.
parse upper arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
cx = pos('~', dsn)
if cx < 1 & addPrefix == 1 then
return sp'.'dsn
do while cx \== 0
le = left(dsn, cx-1)
ri = substr(dsn, cx+1)
if right(le, 1) == '.' | left(ri, 1) == '.' then
dsn = le || sp || ri
else
dsn = le || left('.', le \== '') || sp ,
|| left('.', ri \== '') || ri
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
parse arg dsn, mbr
bx = pos('(', dsn)
if bx > 0 then
dsn = strip(left(dsn, bx-1))
if mbr <> '' then
dsn = dsn'('strip(mbr)')'
return dsn
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn
lx = pos('(', dsn)
rx = pos(')', dsn, lx+1)
if lx < 1 then
return ''
else if lx < rx then
return substr(dsn, lx+1, rx-lx-1)
else
return strip(substr(dsn,lx+1))
endProcedure dsnGetMbr
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: 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.adrTsoAl.1 = ''
m.adrTsoAl.2 = ''
m.adrTsoAl.3 = ''
call outtrap m.adrTsoAl.
res = dsnAlloc(spec, pDi, pDD, '*')
call outtrap off
if \ datatype(res, 'n') then
return res
msg = m.adrTsoAl.1'\n'm.adrTsoAl.2'\n'm.adrTsoAl.3
if rt > timeOut & timeOut \== '' then
return err('timeout allocating' spec time() '\n'msg)
if pos('DATA SET IS ALLOCATED TO ANOTHER', msg) < 1 then
return err('allocating' spec'\n'msg)
say time() 'sleep and retry alloc' spec
call sleep 1, 0
end
endProcedure dsnAllocWait
/*--- alloc a dsn or a dd
spec '-'<ddName>
datasetName? disposition? '.'? attributes? (':' newAtts)?
disp default disposition
dd default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc -----*/
dsnAlloc: procedure expose m.
parse upper arg spec, pDi, pDD, retRc
parse value dsnSpec(spec) with na dd di rest
if na = '-' then
m.dsnAlloc.dsn = ''
else
m.dsnAlloc.dsn = na
if dd == '-' & pDD \== '' then
dd = pDD
if dd == '-' then
dd = 'DD*'
dd = tsoDD(dd, 'a')
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 pos('/', na) > 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 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
c = 'alloc dd('dd')' disp
if na \== '-' then
c = c "DSN('"na"')"
else if disp = 'NEW' and nn \== '' then
c = c dsnCreateAtts(,nn)
call outtrap m.adrTsoAl.
alRc = adrTso(c rest, '*')
call outtrap off
if alRc = 0 then
return 0
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& sysDsn("'"m.dsnAlloc.dsn"'") == 'DATASET NOT FOUND' then do
say 'tsoAlloc creating' c rest ':'nn
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na dd disp rest, retRc)
end
say 'rc='alRc 'for' c rest
call saySt adrTsoal
if retRc = '*' | wordPos(alRc, retRc) > 0 then
return alRc
call err 'tsoAlloc rc' alRc 'for' c rest
endProcedure tsoAlloc
tsoAtts: procedure expose m.
parse arg dsn
rc = listDsi("'"dsn"' SMSINFO")
if rc = 0 then
mv = ''
else if rc = 4 & sysReason = 19 then do
mv = '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
al = 'CAT'
al = ''
if right(sysDsSms, 7) == 'LIBRARY' ,
| abbrev(sysDsSms, 'PDS') then
al = al 'DSNTYPE(LIBRARY)'
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
return al "DSORG("sysDSorg") MGMTCLAS("sysMgmtClass")",
"DATACLAS("sysDataClass")" ,
"RECFM("translate('1 2 3', ' 'sysREcFM, ' 123')")",
"LRECL("SYSLRECL")",
"SPACE("sysPrimary"," sysSeconds")" sysUnits mv
/* "blksize("sysBLkSIZE")" removed 3.4.13: let sms do the magic */
endProcedure tsoAtts
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, forCsm
forCsm = forCsm == 1
aU = ' 'translate(atts)
res = ''
if dsn \== '' then
res = "dataset('"dsnSetMbr(dsn)"')"
if abbrev(atts, '~') then
return res tsoAtts(substr(atts, 2))
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
recfm='f b'
end
else do
if rl = '' then
rl = 32756
recfm = substr(a1, 2, 1) 'b'
end
res = res "recfm("space(recfm, 1-forCsm)") lrecl("rl")"
end
if pos('(', dsn) > 0 & pos(' DSNTYPE(', aU) < 1 ,
& pos(' DSORG(', aU) < 1 then
res = res 'dsntype(library) dsorg(po)'
if pos(' MGMTCLAS(', aU) < 1 then
res = res 'mgmtclas(COM#A091)'
if pos(' SPACE(', aU) < 1 then
res = res 'space(100, 500) cyl' || copies('inder', forCsm)
return res atts
endProcedure dsnCreateAtts
/*--- check if a dataset is archive ------------------------------------
returns 'ok' if dataset on disk
'not' if dataset is not catalogued
'arc' if dataset archived
listDsi errorMsg otherwise ------------------*/
dsnArc: procedure expose m.
parse upper arg dsn
lc = listDsi("'"strip(dsn)"' noRecall")
if lc = 0 then
return 'ok'
else if lc=4 & sysReason = 19 then /* multiple volumes */
return 'ok'
else if lc=16 & sysReason = 5 then
return 'notCat'
else if lc=16 & sysReason = 9 then
return 'arc'
else
return 'listDsi cc='lc', sysReason='sysReason ,
'm2='sysMsgLvl2', m1='sysMsgLvl1
endProcedure dsnArc
/*--- read the dataset specified in ggDsnSpec to stem ggSt -----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
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 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.alfRex = m.ut.Alfa'.0123456789@#$?' /* charset puff mit ¬*/
m.ut.alfRexN1= '.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 ********************************************************/
/* 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 'assertRes =' arg(1)
if assertRes \==1 then
call err 'assert failed' arg(1) '==>' assertRes':' arg(2)
return
endProcedure assert
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg
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 out begin ******************************************************
out interface simple with say or stem m.out only
***********************************************************************/
outIni: procedure expose m.
return outDst()
/*--- output a message to the current destination -------------------*/
out: procedure expose m.
parse arg msg
if m.out.ini \== 1 then
call outDst
if m.out.say then
say msg
if m.out.out then do
ox = m.out.0 + 1
m.out.0 = ox
m.out.ox = msg
end
return 0
endProcedure out
/*--- set a new out destination and return old one ------------------*/
outDst: procedure expose m.
parse arg d
if m.out.ini == 1 then
old = '-' || left('s', m.out.say) || left('o', m.out.out)
else do
m.out.ini = 1
old = '-s'
end
m.out.say = d == '' | pos('s', d) > 0
m.out.out = verify(d, 'o0', 'm') > 0
if pos('0', d) > 0 | \ datatype(m.out.0, 'n') then
m.out.0 = 0
return old
endProcedure outDst
/* return the contents of a string or std input */
inp2str: procedure expose m.
parse arg rdr, opt
return rdr
endProcedure inp2str
/* copy out end *****************************************************/
}¢--- A540769.WK.REXX(REOTST) cre=2010-09-27 mod=2016-06-19-11.32.42 A540769 ---
/* rexx test caller for reoCheck */
call errIni 'hI'
parse upper arg dbSys type fun
if dbSys = '' then /* für online test */
parse upper value 'DP4G TS TEST' with dbSys type fun
/*-------------- Hauptprogramm -----------------------------------*/
if fun = 'TEST' then
call testreoCheck dbSys, type
else if fun = 'T0' then
call testRT0 dbSys type
else
call err 'bad fun' fun 'in Argumenten' arg(1)
exit
testReoCheck: procedure expose m.
parse arg dbSys, type
ldhlq = dbSys
if 0 & dbSys = 'DBAF' then
ldHlq = 'A540769.reoTst'
spx = 1 /* + (dbSys = 'DBAF') */
mbrs = 'QR04412'
mbrs = QR30403
mbrs = 'QR04412 QR03202 QR20801'
mbrs = 'QR49803'
mbrs = QR61001 QR08701 QR06808 QR57303
mbrs = QR57303
mbrs = QR20801 /* mf150a */
mbrs = QR00308
mbrs = QR20801
mbrs = QR57303
mbrs = QR588T2
mbrs = QR00316
mbrs = QR04412
mbrs = QR20803 /* mf150h */
mbrs = QR00201
mbrs = QR65201 QR387051 /* keine objects */
mbrs = QR11802 /* ohne listdef */
mbrs = QR20801 /* mf150a */
mbrs = QR20801 /* mit parts */
mbrs = QR00301 QRTTTTT QR20801 /* nichtLeer / Leer */
mbrs = QR07601 /* mit i0 */
mbrs = QR78901 /* mit i0 */
mbrs = QBLOB00 /* mit i0 */
/* dbaf */
/* mbrs = QR546A1 QR588A1 QR588A2 QR588A3 QR588A4 QR588A5
mbrs = QR546A1
mbrs = QR20803 QR00201
*/ do mx=1 to words(mbrs)
mb = word(mbrs, mx)
say 'member' mb '**********'
call adrTso 'free dd(ddIn1 ddIn2 ddOut1 )', '*'
call dsnAlloc "dd(ddIn1) ~tstReo.sysprint("mb")"
/* call dsnAlloc "dd(ddIn2) '"ldHlq".DBAA.listDef("mb"1)'" */
call dsnAlloc "dd(ddIn2) ~tstReo.listDef("mb"1)"
call dsnAlloc "dd(ddOut1) ~tstReo.reoOut("mb")"
call checkRts dbSys type
call adrTso 'free dd(ddIn1 ddIn2 ddOut1 )', '*'
end
return
endProcedure testreoCheck
testRT0: procedure expose m.
parse arg dbSys type
MBR=QR04412
MBR=QR57303
call adrTso "alloc dd(ddIn1) shr" ,
"dsn('A540769.reoTst.SYSPRINT("MBR")')"
call adrTso "alloc dd(ddIn2) shr" ,
"dsn('"ldHlq".DBAA.LISTDEF("MBR"1)')"
/* "dsn('A540769.reoTst.LISTDEF("MBR"1)')" */
call adrTso "alloc dd(ddOut1) shr" ,
"dsn('A540769.reoTst.OLI"type"NEW("MBR")')"
if 1 then do /* neu */
???? call doreoCheck type, '-ddIn1', '-ddIn2',
, dsn4allocated('ddOUt1')
end
else do /* alt */
call checkRt0 dbSys type
say 'checkRt0 rc' rc
end
call adrTso 'free dd(ddIn1 ddIn2 ddOut1)'
return
endProcedure testRT0
/*--- search the ds Name alloctade to dd dd --------------------------*/
dsn4Allocated: procedure expose m.
parse upper arg dd
/* it would be much easier with listDsi,
unfortuneatly listDsi returns pds name without member*/
dd = ' 'dd' '
oldOut = outtrap(l.)
call adrTso "listAlc st"
xx = outtrap(off)
do i=2 to l.0 while ^abbrev(l.i, dd)
end
if i > l.0 then
return '' /* dd not found */
j = i-1
dsn = word(l.j, 1)
if abbrev(l.j, ' ') | dsn = '' then
call err 'bad dd lines line\n'i l.i'\n'j l.j
return dsn
endProcedure dsn4Allocated
/**** end program begin copies ***************************************/
/* copy adrTso begin *************************************************/
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet ---*/
adrTso:
parse arg ggTsoCmd, ggRet
address tso ggTsoCmd
if rc == 0 then return 0
else if ggRet == '*' then return rc
else if wordPos(rc, ggRet) > 0 then return rc
else
call err 'adrTso rc' rc 'for' ggTsoCmd
return /* end adrTso */
/*--- format dsn from tso format to jcl format -----------------------*/
dsn2jcl: procedure expose m.
parse upper arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
cx = pos('~', dsn)
if cx < 1 & addPrefix == 1 then
return sp'.'dsn
do while cx \== 0
le = left(dsn, cx-1)
ri = substr(dsn, cx+1)
if right(le, 1) == '.' | left(ri, 1) == '.' then
dsn = le || sp || ri
else
dsn = le || left('.', le \== '') || sp ,
|| left('.', ri \== '') || ri
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
parse arg dsn, mbr
bx = pos('(', dsn)
if bx > 0 then
dsn = strip(left(dsn, bx-1))
if mbr <> '' then
dsn = dsn'('strip(mbr)')'
return dsn
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn
lx = pos('(', dsn)
rx = pos(')', dsn, lx+1)
if lx < 1 then
return ''
else if lx < rx then
return substr(dsn, lx+1, rx-lx-1)
else
return strip(substr(dsn,lx+1))
endProcedure dsnGetMbr
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: readDDBegin, readDD*, readDDEnd
write: writeBegin, writeDD*, writeEnd
readDD returns true if data read, false at eof
***********************************************************************/
/*--- prepare reading from a DD --------------------------------------*/
readDDBegin: procedure expose m.
parse upper arg ggDD
call errAddCleanup 'call readDDEnd' ggDD', "*"'
return /* end readDDBegin */
/*--- read from DD ggDD into ggSt, return false at eof ---------------*/
readDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskr' ggDD '(stem' ggSt')', 2
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- finish reading DD ggDD ----------------------------------------*/
readDDEnd: procedure expose m.
parse upper arg ggDD, ggRet
call errRmCleanup 'call readDDEnd' ggDD', "*"'
return adrTso('execio 0 diskr' ggDD '(finis)', ggRet)
endProcedure readDDEnd
/*--- prepare writing to DD ggDD -------------------------------------*/
writeDDBegin: procedure expose m.
parse upper arg ggDD
/* ensure file is erased, if no records are written */
call adrTso 'execio' 0 'diskw' ggDD '(open)'
call errAddCleanup 'call writeDDEnd' ggDD', "*"'
return /* end writeDDBegin */
/*--- write to gg ggDD from stem ggSt, ggCnt records -----------------*/
writeDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt == '' then
ggCnt = value(ggst'0')
call adrTso 'execio' ggCnt 'diskw' ggDD '(stem' ggSt')'
return
endSubroutine writeDD
/*--- end writing to dd ggDD (close) --------------------------------*/
writeDDEnd: procedure expose m.
parse upper arg ggDD, ggRet
call errRmCleanup 'call writeDDEnd' ggDD', "*"'
return adrTso('execio 0 diskw' ggDD '(finis)', ggRet)
endProcedure writeDDEnd
/*--- standardise a dsn spec
word1 dsName or -
word2 dd or -
word3 disp or -
word4 to first : attributes in tso format
after first : attributes for new allocation
----------------------------------------------------------------------*/
dsnSpec: procedure expose m.
parse upper arg spec
rr = '' /* put leading - in separate words */
do sx=1 while words(rr) < 3 & wx \= ''
wx = word(spec, sx)
do while abbrev(wx, '-') & words(rr) < 3
wx = substr(wx, 2)
rr = rr '-'
end
rr = rr wx
end
spec = rr subWord(spec, sx)
na = ''
dd = ''
di = ''
if left(spec, 1) = '&' then /* external spec is handled ok */
spec = strip(substr(spec, 2))
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, '.') | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
di = w
else if w = 'CATALOG' then
di = di w
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
na = strip(substr(w, 5, length(w)-5))
else if na == '' then
na = dsn2jcl(w)
else if dd == '' then
dd = w
else if di == '' then
di = w
else
leave
end
if na == '' then
na = '-'
else if abbrev(na, "'") then
na = substr(na, 2, length(na)-2)
if dd == '' then dd = '-'
if di == '' then di = '-'
re = subword(spec, wx)
if abbrev(re, '.') then
re = substr(re, 2)
return na dd di re
endProcedure dsnSpec
/*--- alloc a dsn with dsnAlloc
if the dsn is inuse wait and retry
until either the allocation is successfull
or the timeout occurs --------------------------------------*/
dsnAllocWait: procedure expose m.
parse upper arg spec, pDi, pDD, timeOut
x = max(1, arg() - 1)
do rt=0
m.adrTsoAl.1 = ''
m.adrTsoAl.2 = ''
m.adrTsoAl.3 = ''
call outtrap m.adrTsoAl.
res = dsnAlloc(spec, pDi, pDD, '*')
call outtrap off
if \ abbrev(res, ' ') then
return res
msg = m.adrTsoAl.1'\n'm.adrTsoAl.2'\n'm.adrTsoAl.3
if rt > timeOut & timeOut \== '' then
return err('timeout allocating' spec time() '\n'msg)
if pos('DATA SET IS ALLOCATED TO ANOTHER', msg) < 1 then
return err('allocating' spec'\n'msg)
say time() 'sleep and retry alloc' spec
call sleep 1, 0
end
endProcedure dsnAllocWait
/*--- alloc a dsn or a dd
spec '-'<ddName>
datasetName? disposition? '.'? attributes? (':' newAtts)?
disp default disposition
dd default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc -----*/
dsnAlloc: procedure expose m.
parse upper arg spec, pDi, pDD, retRc
parse value dsnSpec(spec) with na dd di rest
if na = '-' then
m.dsnAlloc.dsn = ''
else
m.dsnAlloc.dsn = na
if na == '-' & dd \== '-' & di == '-' & rest = '' then
return dd
if dd == '-' & pDD \== '' then
dd = pDD
if dd == '-' then do
if symbol('m.adrTso.ddNum') = 'VAR' then
dd = m.adrTso.ddNum + 1
else
dd = 1
m.adrTso.ddNum = dd
dd = 'DD' || dd
end
if di = '-' & pDi \== '' then
di = pDi
if di = '-' then
di = 'SHR'
else if pos('(', na) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if pos('/', na) > 0 then
return csmAlloc(na dd di rest, retRc)
else
return tsoAlloc(na dd di rest, retRc)
endProcedure dsnAlloc
tsoAlloc: procedure expose m.
parse arg na dd disp rest ':' nn, retRc
c = 'alloc dd('dd')' disp
if na \== '-' then
c = c "DSN('"na"')"
else if disp = 'NEW' and nn \== '' then
c = c dsnCreateAtts(,nn)
call outtrap m.adrTsoAl.
alRc = adrTso(c rest, '*')
call outtrap off
if alRc = 0 then do
call errAddCleanup 'call tsoFree' dd', "*"'
return dd 'call tsoFree' dd';'
end
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& sysDsn("'"m.dsnAlloc.dsn"'") == 'DATASET NOT FOUND' then do
say 'tsoAlloc creating' c rest ':'nn
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na dd disp rest, retRc)
end
do ax=1 to m.adrTsoAl.0
say m.adrTsoal.ax
end
if retRc = '*' | wordPos(alRc, retRc) > 0 then
return ' ' alRc
call err 'tsoAlloc rc' alRc 'for' c rest
endProcedure tsoAlloc
tsoAtts: procedure expose m.
parse arg dsn
rc = listDsi("'"dsn"' SMSINFO")
if rc = 0 then
mv = ''
else if rc = 4 & sysReason = 19 then do
mv = 'UNITCNT(30)'
say 'multi volume' mv
end
else if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
al = 'CAT'
al = ''
if right(sysDsSms, 7) == 'LIBRARY' ,
| abbrev(sysDsSms, 'PDS') then
al = al 'DSNTYPE(LIBRARY)'
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
al = al "DSORG("sysDSorg") MGMTCLAS("sysMgmtClass")",
"DATACLAS("sysDataClass")" ,
"RECFM("translate('1 2 3', ' 'sysREcFM, ' 123')")",
"LRECL("SYSLRECL")",
"blksize("sysBLkSIZE")",
"SPACE("sysPrimary"," sysSeconds")" sysUnits mv
return al
endProcedure tsoAtts
tsoFree: procedure expose m.
parse arg dd, ggRet
call adrTso 'free dd('dd')', ggRet
call errRmCleanup 'call tsoFree' dd', "*"'
return
endProcedure tsoFree
dsnCreateAtts: procedure expose m.
parse arg dsn, atts, forCsm
forCsm = forCsm == 1
aU = ' 'translate(atts)
if abbrev(atts, ':') then do
parse var atts a1 atts
bl = 32760
rl = substr(a1, 3)
if abbrev(a1, ':F') then do
if rl = '' then
rl = 80
recfm='f b'
bl = bl - (bl // rl)
end
else do
if rl = '' then
rl = bl-4
recfm = substr(a1, 2, 1) 'b'
end
if forCsm then
atts = atts "recfm("space(recfm, 0)") lrecl("rl")",
"blkSize("bl")"
else
atts = atts "recfm("recfm") lrecl("rl") block("bl")"
end
if pos('(', dsn) > 0 & pos(' DSNTYPE(', aU) < 1 ,
& pos(' DSORG(', aU) < 1 then
atts = atts 'dsntype(library) dsorg(po)'
if pos(' MGMTCLAS(', aU) < 1 then
atts = atts 'mgmtclas(COM#A091)'
if pos(' SPACE(', aU) < 1 then
if forCsm then
atts = atts 'space(10, 1000) cylinder'
else
atts = atts 'space(10, 1000) cyl'
if dsn == '' then
return atts
return "dataset('"dsnSetMbr(dsn)"')" atts
endProcedure dsnCreateAtts
/*--- read the dataset specified in ggDsnSpec to stem ggSt -----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
interpret subword(ggAlloc, 2)
return
endSubroutine readDsn
/*--- write the dataset specified in ggDsnSpec from stem ggSt
write ggCnt records if not empty otherwise ggst0
if ggSay 1 then say ... records written to ... -------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'open finis)'
interpret subword(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
copyDSN: procedure expose m.
parse arg frSpec, toSpec, ggSay
frDD = dsnAlloc(frSpec, 'SHR', 'FRDD')
toDD = dsnAlloc(toSpec, 'OLD', 'TODD')
call readDDBegin word(frDD, 1)
call writeDDBegin word(toDD, 1)
cnt = 0
do while readDD(word(frDD, 1), r.)
call writeDD word(toDD, 1), r.
cnt = cnt + r.0
end
call readDDEnd word(frDD, 1)
call writeDDEnd word(toDD, 1)
interpret ';' subword(frDD, 2) '; ; ;' subword(toDD, 2)
if ggSay == 1 | m.debug == 1 then
say cnt 'records copied from' frSpec 'to' to toSpec
return
endSubroutine writeDsn
/* copy adrTso end ****************************************************/
/* copy err begin ******************************************************
messages, errorhandling,help
***********************************************************************/
errIni: procedure expose m.
if m.err.ini == 1 then
return
call outIni
m.err.ini = 1
m.err.handler = ''
m.err.cleanup = ';'
m.err.opt = ''
return
endProcedure errIni
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err.opt, m.err.handler
if pos('I', translate(m.err.opt)) > 0 then
if errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
call adrIsp 'control errors return'
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
call errIni
drop err handler cleanup opt call return
if ggOpt == '' & m.err.handler \== '' then do
if 1 then do /* no detection of recursive err call loop
--> will anyway fail by stack overflow */
interpret m.err.handler
end
else do
/* avoid recursive err call loop */
drop call return
if symbol('m.err.call') \== 'VAR' then
m.err.call = 1
else
m.err.call = m.err.call + 1
if m.err.call > 10 then do
say 'errHandler loop:' m.err.handler
end
else do
m.err.return = 1
call errInterpret m.err.handler
m.err.call = m.err.call - 1
if m.err.return then
return result
end
end
end
call outPush
call errSay ggTxt, 'e'
call errCleanup
if ggOpt == '' then
ggOpt = m.err.opt
ggOpt = translate(ggOpt)
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 then do
call errSay 'divide by zero to show stackHistory', 'e'
x = 1 / 0
end
call errSay 'exit(12)', 'e'
exit errSetRc(12)
endSubroutine err
/*--- error routine: user message cleanup exit -----------------------*/
errEx:
parse arg ggTxt
call errIni
call outPush
call errSay ggTxt
call errCleanup
exit 8
endProcedure errEx
errAddCleanup: procedure expose m.
parse arg code
if m.err.ini \== 1 then
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
if m.err.ini \== 1 then
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
cl = m.err.cleanup
if cl = ';' then
return
m.err.cleanup = ';'
call out 'err cleanup begin' cl
call errInterpret cl
call out 'err cleanup end' cl
return
endProcedure errCleanup
errInterpret: procedure expose m.
parse arg code
interpret code
m.err.return = 0
return
endProcedure errInterpret
/*--- assert that the passed rexx expression evaluates to true -------*/
assert:
interpret 'assertRes =' arg(1)
if \ assertRes then
call err 'assert failed' arg(1)':' arg(2)
return
endProcedure assert
/*--- output an errorMessage msg with pref pref
split message in lines at '/n' ---------------------------*/
errSay: procedure expose m.
parse arg msg, pref
parse source . . ggS3 . /* current rexx */
if pref == 'e' then
msg = 'fatal error in' ggS3':' msg
else if pref == 'w' then
msg = 'warning in' ggS3':' msg
else if pref \== '' then
msg = pref':' msg
return outNl(msg)
endProcedure errSay
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg, op
call errSay msg, 'e'
call help
call err msg, op
endProcedure errHelp
/*--- return the Operating System we are running on: TSO or LINUX ---*/
errOS: procedure expose m.
parse source os .
return os
endProcedure errOS
/*--- set rc for ispf: -------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared varible 3IspfRc
back as return code
----------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- output a trace message if m.tr is set -----------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
call out 'debug' msg
return
endProcedure debug
/*--- display the first comment block of the source as help ----------*/
help: procedure expose m.
parse source . . s3 .
call out right(' help for rexx' s3, 79, '*')
do ax=1 to arg()
say ' ' arg(ax)
end
do lx=1 by 1
if pos('/*', sourceLine(lx)) > 0 then
leave
else if lx > 10 then do
call out '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
call out li
end
call out right(' end help for rexx' s3, 79, '*')
return 4
endProcedure help
/*--- output all lines (separated by '\n') of all args --------------*/
outNl: procedure expose m.
do ax=1 to max(1, arg())
msg = arg(ax)
sx = 0
bx = -1
do lx=1 until bx >= length(msg)
ex = pos('\n', msg, bx+2)
if ex < 1 then
ex = length(msg)+1
call out substr(msg, bx+2, ex-bx-2)
bx = ex
end
end
return 0
endProcedure outNl
/* copy err end *****************************************************/
/* copy out begin ******************************************************
out interface with simplistic implementation
***********************************************************************/
outIni: procedure expose m.
parse arg msg
if m.out.ini == 1 then
return
m.out.ini = 1
m.out.dst = ''
return
endProcedure outIni
/*--- output a message to the current destination -------------------*/
out: procedure expose m.
parse arg msg
if m.out.ini \== 1 then
call outIni
if m.out.dst == '' then do
say msg
end
else do
st = m.out.dst
sx = m.st.0 + 1
m.st.0 = sx
m.st.sx = msg
end
return 0
endProcedure out
/*--- push an out destination ---------------------------------------*/
outPush: procedure expose m.
parse arg m.out.dst
return
endProcedure outPush
/* copy out end *****************************************************/
}¢--- A540769.WK.REXX(REOTSTG) cre=2010-10-05 mod=2012-02-13-15.34.02 A540769 ---
$#@
$*( test Generator for checkrts, je nach fun
fun
a = allocate test libraries
d = delete test libraries
pre = preview ==> generate list to ....sysprint
old = checkRts for old version
new = checkRts for new version
all = checkRts for new and old version for ix and ts
rmSy = remove sysPrint Member without listdef member
$*)
$=dbSub = DBTF
$=fun=pre
$=ty=IX
$=steps =- if($fun='all', 50, 200)
pref = dsn2jcl('~REOTST')
tsPref = pref'.OLITS'
ixPref = pref'.OLIIX'
$=FUN =- translate($fun)
$=rZz=- overlay('Z', sysvar('sysnode'), 2)
$=jx=0
if $fun = 'a' | $fun = 'd' then $@¢
lst = ixPref'NEW' 'F' ,
ixPref'OLD' 'F' ,
tsPref'NEW' 'F' ,
tsPref'OLD' 'F' ,
pref'.OPRIXNEW' 'V' ,
pref'.OPRIXOLD' 'V' ,
pref'.OPRTSNEW' 'V' ,
pref'.OPRTSOLD' 'V' ,
pref'.SYSPRINT' 'V124'
do while lst \= ''
parse var lst dsn ii lst
if $fun = 'd' then
call adrTso "delete '"dsn"'", '*'
else do
ff = dsnAlloc(dsn'(A) dd(x) ::'ii)
interpret subword(ff, 2)
end
end
$! else if $fun = 'rmSy' then $@¢
lDf = lmmBegin($dbSub'.DBAA.LISTDEF(QR*)')
l = lmmNext(lDf)
sDsn = pref'.sysprint'
sPr = lmmBegin(sDsn)
s = lmmNext(sPr)
cEq = 0
cL = 0
cS = 0
do while l \== '' & s \== ''
if l << s then do
say 'add lDef' l
l = lmmNext(lDf)
cL = cL + 1
end
else if l >> s then do
del = "delete '"sDsn"("s")'"
say del
call adrTso del
s = lmmNext(sPr)
cS = cS + 1
end
else do
cEq = cEq + 1
s = lmmNext(sPr)
l = lmmNext(lDf)
end
end
do while s \== ''
say '+++ sysP' s
s = lmmNext(sPr)
cS = cS + 1
end
do while l \== ''
say '+++ lDef' l
cL = cL + 1
l = lmmNext(lDf)
end
call lmmEnd lDf
call lmmEnd sPr
say 'equal' cEq', +sysPrint' cS', +listDef' cL
$! else $@¢
$>.fSub() $*(
$<=¢ $** dbof member
QR002011
QR003081
QR003161
QR044121
QR087011
QR208011
QR208031
QR304031
QR387061
QR387071
QR498031
QR573031
QR610011
$!
$<=¢ $** dbaf member
QR208031
QR208011
QR002011
QR546A11
QR588A11
QR588A21
QR588A31
QR588A41
QR588A51
$!
$<=¢ $** dbtf member
QR003011
QRTTTTT1
QR208011
$!
if $fun = 'pre' then
call lmm $dbSub'.DBAA.LISTDEF(QR*)'
else
call lmm 'A540769.REOTST.SYSPRINT(QR*)'
$|
$*)
$<=¢ $** dbtf member
QR003011
QRTTTTT1
QR208011
$!
$@¢
$=sx=0
$@for mbr $@¢
$=sx=-right($sx+1, 4, 0)
$=mbr=-strip($mbr)
if $sx // $steps = 1 then $@=¢
$@{say $sx $mbr'|'}
$= jx =- ($jx+1) // 10
$= jc =- left($ty, 1) || $jx
//YRT$FUN$jc JOB (CP00,KE50),
// MSGCLASS=T,TIME=1440,LINES=(999999,WARNING),
// NOTIFY=&SYSUID
//*MAIN CLASS=LOG
$!
$@step()
$!
$!
$;
$@proc step $@¢
if $fun == 'pre' then $@=¢
//* OBJEKTE AUS LISTDEF AUFLÖSEN für $mbr
//PRE$sx EXEC PGM=DSNUTILB,
// PARM='$dbSub,YRT$FUN$jc.PREVIEW'
//SYSPRINT DD DISP=SHR,DSN=A540769.REOTST.SYSPRINT($mbr)
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=$dbSub.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD DSN=$dbSub.DBAA.LISTDEF(OPTPREV),DISP=SHR
// DD DISP=SHR,DSN=$dbSub.DBAA.LISTDEF($mbr)
$!
else if $fun = 'all' then $@¢
$@doRts-{'new', TS}
$@doRts-{'old', TS}
$@doRts-{'new', IX}
$@doRts-{'old', IX}
$!
else $@¢
$@doRts{$fun, $ty}
$!
$!
$!
$@proc doRts $@¢
parse arg ., fun, type
$=t2=-type
$=f3=-fun
$=F3=-translate($f3)
$=F1=-left($F3, 1)
$=rexxLib=TSO.$rZz.P0.USER.EXEC
$=rexxMbr= REOCHECK
$=rexxMbr= CHECKRTS
if $f3 == 'new???' then $@¢
$=rexxLib=A540769.WK.REXX
$!
else $@¢
$** $=rexxMbr= CHECKRT0
$!
$@=¢
//* rts für $t2 nach $f3
//$F1$t2$sx EXEC PGM=IKJEFT01,
// DYNAMNBR=20
//SYSEXEC DD DISP=SHR,DSN=$rexxLib
//DDIN1 DD DISP=SHR,DSN=A540769.REOTST.SYSPRINT($mbr)
//DDIN2 DD DISP=SHR,DSN=$dbSub.DBAA.LISTDEF($mbr)
//DDOUT1 DD DISP=SHR,DSN=A540769.REOTST.OLI$t2$F3($mbr)
//SYSTSIN DD *
%$rexxMbr $dbSub $t2
//SYSIN DD DUMMY
//SYSTSPRT DD DISP=SHR,DSN=A540769.REOTST.OPR$t2$F3($mbr)
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//PLIDUMP DD SYSOUT=*
$!
$!
$#out 20120213 15:33:33
$#out 20110924 16:48:27
$#out 20110924 16:33:30
$#out 20110924 13:48:21
$#out 20110924 13:48:08
$#out 20110924 13:42:55
}¢--- A540769.WK.REXX(REPA) cre=2010-01-27 mod=2013-02-08-15.38.57 A540769 -----
/***********************************************************************
synopsis: repa optDsn? fun opts
optDsn gibt den DSN der Optionen an, als Editmacro ist das nicht
nötig, da wird der aktuelle editierte DSN genommen
fun n neue Optionen(vorlage) erstellen. Membername max 4 Zeichen.
Table(spaces), DSN's usw. in Variabeln fuellen.
Die Optionen werden als Rexx interpretiert.
m Map Member erstellen zur Zuordnung der alten zu neuen
Partitionen.
Optionen: pN? pO? O
falls pN und pA fehlen wird map aus old und new DDL
abgeleitet. Sie enthält als Info alle Keys.
pN Anzahl neue partitionen
pO Anzahl alte partitionen, Default pN
pN und pO repartitieren linear
O die Option 'O' erzeugt eine Map mit Overlaps,
wenn ein neuer Key = einem alten ist
0 unload limit 0 Job erzeugen. Sie submitten ihn, um das
Punchfile zu erzeugen
j restliche Jobs erstellen
unlo unload alte table
unl2 zweiter Unload als KatastrophenSicherung
load load neue table
reRu Runstats und Rebuild Index (parallel)
rebi Rebind
cnt Count alte Table
Ablauf Repartitionierung:
-sta ro sub unlo, back und cnt (parallel|) entladen, backup, count
drop und create TS ohne Indexe, Primary Key usw.
-sta ut sub load neuen TS laden
und ALLENFALLS gleichzeitig sub rebi (siehe Ausfall)
-sta rw create Indexe (mit DEFER), primary Key usw.
-sta ut sub reRu : Runstats TS und parallel Rebuild Indexe
Count neu (Runstats TB) mit alt (job ....Cnt) vergleichen
sub rebi: Rebind Packages
-sta rw
**** history ***********************************************************
8. 2.2013 W. Keller neue LImit Syntax, vergleich von Hex Werten
******************** end of help */ /***********************************
13. 4.2010 W. Keller Warnung wegen Ausfall
16. 2.2010 W. Keller ManagementClass COM#A011 + space comment
01.12.2008 W. Keller fix map new old
27.11.2008 W. Keller rewrite
***********************************************************************/
parse arg args
m.debug = 0
call errReset 'h'
em = args = ''
if em then
em = adrEdit('macro (args)', '*') = 0
if args = '' | pos('?', args) > 0 then
exit help()
if length(word(args, 1)) = 1 then do
optDsn = ''
funOpts = args
if ^em then
exit errHelp('either use REPA as editMacro or optDsn argument')
end
else do
parse upper var args optDsn funOpts
em = 0
end
/* now, do the work */
call mapIni
call mapReset v
if em then
call doInEditMacro funOpts
else
call doInTso dsn2Jcl(optDsn), funOpts
exit
/*--- do the work in an editMacro ------------------------------------*/
doInEditMacro: procedure expose m.
parse upper arg fun opts
call adrEdit '(zl) = lineNum .zl', 4
call adrEdit '(lib) = dataset'
call adrEdit '(mbr) = member'
if mbr ^== '' then
optDsn = lib'('mbr')'
if fun = 'N' then do
if zl <> 0 then
call err 'fun n only in empty edit'
call adrEdit 'caps off'
m.opt.0 = 0
end
else do
do lx = 1 to zl
call adrEdit '(line) = line' lx
m.opt.lx = strip(line, 't')
end
m.opt.0 = zl
end
call doWork optDsn, fun, opts
if m.opt.0 <> zl then do
do lx= zl+1 to m.opt.0
line = m.opt.lx
if lx = 1 then
call adrEdit 'line_after .zf = (line)'
else
call adrEdit 'line_after .zl = (line)'
end
end
return
endProcedur doInEditMacro
/*--- do the work in tso ---------------------------------------------*/
doInTso: procedure expose m.
parse upper arg optDsn, fun opts
if fun = 'N' then
m.opt.0 = 0
else
call readDsn optDsn, 'M.OPT.'
zl = m.opt.0
call doWork optDsn, fun, opts
if zl ^== m.opt.0 then
call writeDsn optDsn, 'M.OPT.'
return
endProcedure doInTso
/*--- interpret the opts member and do the work ----------------------*/
doWork: procedure expose m.
parse arg optDsn, fun, opts
call setDefaults optDsn
if fun = 'N' then do
if dsnGetMbr(optDsn) = '' then
call err 'edit rsp. optionDsn must be a',
'library member not' optDsn
call newOpt optDsn
return
end
call interStem opt /* interpret options */
m.jobPref = left(space(m.jobPref, 0)'REPA', 4)
call mapPut v, 'pref', m.dsnPref /* prefix for gen. datasets */
if fun = 'M' then do
parse var opts nPa oPa over /* analyse map options */
if nPa = '' then do
end
else if ^datatype(nPa, n) then do
over = nPa
nPa = ''
end
else if ^datatype(oPa, n) then do
over = oPa
oPa = nPa
end
m.prt.0 = 0
if nPa = '' then do /* analyse ddl and merge keys */
m.partKeyType = ''
call partKey m.old.ddl, ok
call partKey m.new.ddl, nk
call merge prt, nk, ok, over
end
else do /* linear map */
call makeParts prt, nPa, oPa, over
end
call writeEdit m.partMap, prt
end
else if fun = 0 then do
call uLi0Job mCut(u0, 0), old
call writeEdit m.uli0Job, u0
end
else if fun = 'J' then do
/* punch file from unload limit 0 job */
call anaPunch pu, new, m.dsnPref'.'m.old.ts'.PUNLIM0'
call readMap mCut(paMa, 0), m.partMap
call unloJob m.unloJob, old, m.paMa.oldFi, m.paMa.oldLa, 'UNLOA'
call mapPut v, 'pref', m.old.sub'.REPABACK'
call unloJob m.backJob, old, m.paMa.oldFi, m.paMa.oldLa, 'BACKU'
call mapPut v, 'pref', m.dsnPref
call loadJob m.loadJob, new, old, pu, paMa
call reRuJob m.reRuJob, new
call rebiJob m.rebiJob, new
call cntJob m.cntJob, old
end
else do
call err 'fun' fun 'not implemented'
end
return
endProcedure doWork
/*--- write dsn from stem st and, if we are in foreground edit it ----*/
writeEdit: procedure expose m.
parse arg dsn, st
doEd = sysVar('sysEnv') == 'FORE' & sysVar('sysIspf') == 'ACTIVE'
if st ^== '' then do
call mStrip st, 't'
call writeDsn dsn, 'M.'st'.', , ^ doEd
end
if doEd then
call adrIsp "Edit dataset('"dsn"')", 4
return
endProcedure writeEdit
/*--- set the defaults value for optDsn ------------------------------*/
setDefaults: procedure expose m.
parse arg optDsn
pref = dsnSetMbr(optDsn)'('strip(left(dsnGetMbr(optDsn), 4))
m.new.sub = 'DB??' /* db2 subsys for new */
m.new.tb = 'OA1?.????' /* new creator.table */
m.new.ts = '????A1?.A???A' /* new db.tablespace */
m.old.sub = m.new.sub /* db2 subsys for old */
m.old.tb = m.new.tb /* old creator.table */
m.old.ts = m.new.ts /* old db.ts */
m.new.ddl = pref'DNEW)' /*ddl new partition keys*/
m.old.ddl = pref'DOLD)' /*ddl old partition keys*/
m.partMap = pref'MAP)' /* load new */
m.uli0Job = pref'ULI0)' /* unload lim0 old */
m.unloJob = pref'UNLO)' /* unload old */
m.backJob = pref'BACK)' /* unload old */
m.loadJob = pref'LOAD)' /* load new */
m.reRuJob = pref'ReRu)' /* rebuild runstats */
m.rebiJob = pref'Rebi)' /* rebind job */
m.cntJob = pref'Cnt)' /* Count job */
m.jobPref = 'YRPA'
m.jobs = 32
m.skels = 'ORG.U0009.B0106.KIDI63.SKELS' /* skeleton library */
m.dsnPref = 'DSN.REPA'
return
endProcedure setDefaults
/*--- write a new opt dsn --------------------------------------------*/
newOpt: procedure expose m.
parse arg optDsn
s1 = left('',9)
s2 = s1 '* '
s3 = s2 ' '
call mAdd opt,
, s1 left('/* option member for REPA repartitionierung ',
, 60,'*'),
, s2 'use REPA ? for help',
, s2 ,
, s1 'Achtung wegen Space Overflow, allenfalls',
, s3 'mgmtClass=COM#A011 (archive heute) auf',
, s3 'mgmtClass=COM#A013 (archive nach 2 Tagen) aendern' ,
, s2 'mit TES oder StorageManagement absprechen,',
, s3 'und falls nötig selber wieder loeschen',
, s2 ,
, s1 'Ausfall von Programmen minimieren,',
, s3 'falls Packages betroffen, die häufig gebraucht werden,' ,
, s3 'aber nur selten auf unsere Tabellen zugreifen:',
, s2 'rebind zusätzlich nach -sta ut und vor sub load',
, s1 right('*/', 60, '*') ,
, ''
call setDefaults optDsn
call newOpt1 new.sub, 'db2 subsystem for new table'
call newOpt1 new.tb, 'new creator.table'
call newOpt1 new.ts, 'new db.tablespace'
call newOpt1 old.sub 'M.NEW.SUB', 'db2 subsystem for old table'
call newOpt1 old.tb 'M.NEW.TB' , 'old creator.table'
call newOpt1 old.ts 'M.NEW.TS' , 'old db.tablespace'
call newOpt1 new.ddl, 'ddl for new partition keys'
call newOpt1 old.ddl, 'ddl for old partition keys'
call mAdd opt, ''
call newOpt1 partMap, 'map old partitions to new'
call mAdd opt, ''
call newOpt1 uli0Job, 'jobName unload limit 0 old'
call newOpt1 unloJob, 'jobName unloads old'
call newOpt1 backJob, 'jobName backup unloads old'
call newOpt1 cntJob, 'jobName count old table'
call newOpt1 loadJob, 'jobName loads new'
call newOpt1 reRuJob, 'jobName rebuild runStats'
call newOpt1 rebiJob, 'jobName rebind packages'
call mAdd opt, ''
call newOpt1 jobPref, 'jobprefix, max 4 characters'
call newOpt1 jobs , 'number of jobs'
return
endProcedure newOpt
/*--- write one opt line for variable name
with value val rsp. m.name and comment com -----------------*/
newOpt1: procedure expose m.
parse arg name val, com
cx = 40
le = 72
li = left('M.'name, 10) '='
if val <> '' then do
li = li val
end
else do
val = m.name
if datatype(val, n) then
li = li val
else
li = li quote(val, "'")
end
if com <> '' then do
com = '/*' com '*/'
if length(li) < cx & length(com) + cx - 1 <= le then
li = left(li, cx-1)com
else if length(li) + length(com) < le then
li = li com
else if length(li) + length(com) <= le then
li = li || com
else if length(com) + cx - 1 <= le then
call mAdd opt, left('', cx-1)com
else
call mAdd opt, right(com, le)
end
call mAdd opt, li
return
endProcedure newOpt1
/*--- create a map for linear repartition ----------------------------*/
makeParts: procedure expose m.
parse arg o, newP, oldP, over
msg = 'linear repartition into' newP 'new from' oldP 'old parts'
if over = 'O' then
msg = msg 'with overlap'
else if over <> '' then
call err 'bad makeParts overlap' over
say msg
call mAdd o, '*' msg
oldX = 1
do newX=1 to newP
li = newX ':' min(oldX, oldP)
do while newX*oldP > oldX*newP
oldX = oldX + 1
end
equal = newX*oldP = oldX*newP
call mAdd o, li '-' min(oldX+(equal & over = 'O'), oldP)
oldX = oldX + (equal & over = '')
end
return
endProcedure makeParts
/*--- interpret the given dsn as rexx --------------------------------*/
interDsn: procedure expose m.
parse arg dsn
call debug 'interpreting' dsn
call readDsn dsn, m.interDsn.
call interStem interDsn
call debug 'interpreted' dsn
return
endProcedure interDsn
/*--- interpret the lines of stem st as rexx -------------------------*/
interStem: procedure expose m.
parse arg st
s = ''
do x=1 to m.st.0
l = strip(m.st.x)
if right(l, 1) == ',' then /* rexx continuation */
s = s left(l, length(l) - 1)
else
s = s l';' /* separate statements */
end
interpret 'drop st s x l;' s
return
endProcedure interStem
/*--- extract partition keys from ddl to stem o ----------------------*/
partKey: procedure expose m.
parse arg ddl, o
call readDsn ddl, ii.
nrLast = 0
do l=1 to ii.0
line = translate(ii.l)
pc = pos('PART', line)
if pc < 1 then
iterate
if pc > 1 then
if pos(substr(ii.l, pc-1, 1), ' ,(') < 1 then
iterate
ly = l + 1
rest = substr(ii.l, pc) ii.ly
if \ abbrev('PARTITION', word(rest, 1)) then
iterate
val = word(rest, 1)
nrAct = word(rest, 2)
if translate(val) = 'USING' | translate(nrAct) = 'BY' then
iterate
bx = wordIndex(rest, 3)
if bx < 1 then
call err 'rest of partition expected' l':' ii.l
kx = pos('(', rest, bx)
if kx <= bx then
call err '( expected' l':' ii.l
ww = space(translate(substr(rest, bx, kx-bx)), 1)
if ww \== 'VALUES' & ww \== 'ENDING AT' then
call err 'USING or ENDING AT expected' l':' ii.l
if nrAct <> nrLast + 1 then
call err 'partition' (nrLast + 1) 'expected not:' line
val = strip(substr(rest, kx+1))
do while pos(right(val, 1), ",)") > 0
val = strip(left(val, length(val)-1))
end
/* we only handle first key | */
ty = left(val, 1)
if datatype(ty, 'n') then
ty = 9
if ty == "'" & substr(val, 12, 1) == "'" ,
& substr(val, 4, 1) == "." ,
& substr(val, 7, 1) == "." ,
& verify(substr(val,2,2)substr(val,5,2)substr(val,8,4),
, '0123456789') == 0 then do
ty = 'd'
val = substr(val,8,4)'-'substr(val,5,2)'-'substr(val,2,2),
|| substr(val, 13)
end
if m.partKeyType == '' then do
m.partKeyType = ty
if ty = 9 then
say 'Achtung numerische Limitkeys funktionieren nur' ,
'wenn alle dieselbe Stellenzahl haben' ,
copies('|', 160)
end
else if m.partKeyType ^== ty then
call err 'partKey start changed from' m.o.nrLast 'to' val
if nrLast > 0 then
if leq(val, m.o.nrLast) then
call err 'limit key' nrAct val,
'not greater than' m.o.nrLast
m.o.nrAct = val
nrLast = nrAct
end
m.o.0 = nrLast
say m.o.0 'keys in ddl' ddl
if 0 then
do x=1 to m.o.0
say right(x,4) m.o.x
end
return
endProcedure partKey
leq: procedure expose m.
parse arg le, ri
lx = abbrev(translate(le), "X'")
if lx <> abbrev(translate(ri), "X'") then
call err 'leq incompatible le='le', ri='ri
if lx then
return x2c(substr(le, 3, length(le)-3)) ,
<<= x2c(substr(ri, 3, length(ri)-3))
else
return le <<= ri then
endProcedure leq
/*--- merge two set of keys,
show all keys (new and old) as comment --------------------*/
merge: procedure expose m.
parse arg out, n, o, over
msg = 'Repa merge Repartionierung'
o1 = over == 'O'
if o1 then
msg = msg 'with overlap'
else if over ^== '' then
call err 'bad merge overlap' over
say msg
call mAdd out, '* ' msg,
, '* new old',
, '* ' right(m.n.0, 5)right(m.o.0,5) 'number of parts',
, '***'
ox = 1
nx = 1
fBeg = 1
do forever
if nx > m.n.0 then do
if ox > m.o.0 then
leave
call mAdd out, '* ' right('', 5)right(ox, 5) m.o.ox
ox = ox + 1
end
else if ox > m.o.0 | \ leq(m.o.ox, m.n.nx) then do
call mAdd out, '* ' right(nx, 5)right('', 5) m.n.nx
if nx < m.n.0 then do
call mAdd out, right(nx, 8) ':' fBeg '-' min(ox, m.o.0)
fBeg = min(ox, m.o.0)
end
nx = nx + 1
end
else if m.o.ox == m.n.nx then do
call mAdd out, '* ' right(nx, 5)right(ox, 5) m.n.nx
if nx < m.n.0 then do
call mAdd out,right(nx,8) ':' fBeg '-' min(ox+o1,m.o.0)
fBeg = min(ox+1-o1, m.o.0)
end
nx = nx + 1
ox = ox + 1
end
else do
call mAdd out, '* ' right('', 5)right(ox, 5) m.o.ox
ox = ox + 1
end
end
call mAdd out, right(m.n.0, 8) ':' fBeg '-' m.o.0
return
endProcedure merge
/*--- read the map in dsn and write it to stem o
for each new partition one entry x
m.o.x : m.o.x.beg m.o.x.end ----------------------------*/
readMap: procedure expose m.
parse arg o, dsn
call readDsn dsn, i.
ox = m.o.0
fi = 999999
la = -1
do ix=1 to i.0
parse var i.ix an ':' vo '-' bi
if bi = '' | abbrev(strip(an), '*') then
iterate
ox = ox + 1
m.o.ox = an + 0
m.o.ox.beg = vo + 0
m.o.ox.end = bi + 0
fi = min(fi, vo, bi)
la = max(la, vo, bi)
end
m.o.0 = ox
m.o.oldFi = fi
m.o.oldLa = la
return
endProcedure readMap
/*--- analyze a punch file generate by unload ------------------------*/
anaPunch: procedure expose m.
parse arg lod, nk, punch
call readDsn punch, pun.
m.lod.1 = 'LOAD DATA LOG NO EBCDIC CCSID(00500,00000,00000)'
m.lod.1 = ' ----------------- part --------------------' /* ??? */
do px=1 by 1 to pun.0 while left(pun.px, 12) ^== ' INTO TABLE '
end
if px > pun.0 | left(pun.px, 12) ^== ' INTO TABLE ' then
call err 'into table not found in punch' punch
m.lod.2 = ' INTO TABLE' m.nk.tb 'PART '
m.lod.3 = ' RESUME NO REPLACE COPYDDN(TCOPYS) INDDN REC'
do px=px by 1 to pun.0 while left(pun.px, 6) ^== ' WHEN('
end
if px > pun.0 then
call err 'when not found in punch' punch
do lx = 4 by 1 while px <= pun.0
m.lod.lx = strip(pun.px, 't')
if pun.px = ' )' then
leave
px = px + 1
end
m.lod.0 = lx
if px > pun.0 then
call err ') ending ) not found in punch' punch
return
endProcedure anaPunch
/*--- generate the unload limit 0 job --------------------------------*/
uli0Job: procedure expose m.
parse arg o, ok
call mapPut v, 'dbSub', m.ok.sub /* db2 subSystem */
call mapPut v, 'tb', m.ok.tb
call mapPut v, 'ts', m.ok.ts
call jobCards mCut(o, 0), 'ULI0'
call expSkel rePaUli0, o
return
endProcedure uli0Job
/*--- generate jobCards and put var jobName --------------------------*/
jobCards: procedure expose m.
parse arg o, jobSuf
call mapPut v, 'jobName', m.jobPref || jobSuf
call expSkel rePaJC, o
return
endProcedure jobCards
/*--- generate unloads -----------------------------------------------*/
unloJob: procedure expose m.
parse arg unloJob, ok, fi, la, jobMid
call mapPut v, 'dbSub', m.ok.sub
call mapPut v, 'tb', m.ok.tb
call mapPut v, 'ts', m.ok.ts
call mCut o, 0
jMax = min(la+1-fi, m.jobs)
pLast = fi-1
do jx=1 to jMax
px = pLast + 1
pLast = trunc(0.5 + (la+1-fi) * jx / jMax)
partNo = right(px, 3, '0')
if px = pLast then
partLast = ''
else
partLast = ':'right(pLast, 3, '0')
/* call mapPut v, 'jobNo', right(jx, 3, '0') */
call mapPut v, 'partNo', partNo
call mapPut v, 'partLast', partLast
call jobCards o, left(jobMid, 1)right(jx, 3, '0')
call expSkel rePaUnlo, o
end /* each job */
call mStrip o, 't'
call writeDsn unloJob, m.o., ,1
return
endProcedure unloJob
/*--- generate loads -------------------------------------------------*/
loadJob: procedure expose m.
parse arg loadJob, new, old, pun, paMa
call mapPut v, 'dbSub', m.new.sub
call mapPut v, 'oldTs', m.old.ts
call mapPut v, 'newTb', m.new.ts
call mCut o, 0
jMax = min(m.paMa.0, m.jobs)
pLast = 0
do jx=1 to jMax
pFirst = pLast + 1
pLast = trunc(0.5 + m.paMa.0*jx/jMax)
call jobCards o, 'L'right(jx, 3, '0')
call expSkel rePaLoJo, o
do px=pFirst to pLast /* for each partition of job */
partNo = right(m.paMa.px, 3, '0')
li = '//REC'partNo
do qx=m.paMa.px.beg to m.paMa.px.end
call mAdd o, left(li,14)'DD DISP=SHR,',
|| 'DSN=&OLDPREF.'right(qx,3,0)'&OLDSUF'
li = '//'
end /* each old partition */
end /* for each partition of job */
call expSkel rePaLoPu, o
do px=pFirst to pLast /* for each partition of job */
partNo = right(m.paMa.px, 3, '0')
qq = m.o.0 + 2
call mAddSt o, pun
m.o.qq = m.o.qq || partNo
qq=qq+1
m.o.qq = m.o.qq || partNo
end /* for each partition of job */
end /* each job */
call mStrip o, 't'
call writeDsn loadJob, m.o., ,1
return
endProcedure loadJob
/*--- generate rebuild and runstats ----------------------------------*/
reRuJob: procedure expose m.
parse arg reRuJob, nd
call mapPut v, 'dbSub', m.new.sub
call mapPut v, 'ts', m.nd.ts
call jobCards mCut(o, 0), 'REBU'
call expSkel rePaRebu, o
call jobCards o, 'RUNS'
call expSkel rePaRuns, o
call mStrip o, 't'
call writeDsn reRuJob, m.o., ,1
return
endProcedure loadJob
/*--- generate rebinds -----------------------------------------------*/
rebiJob: procedure expose m.
parse arg rebiJob, nd
call mapPut v, 'dbSub', m.nd.sub
call jobCards mCut(o, 0), 'REBI'
call expSkel repaRebi, o
parse var m.nd.tb cr '.' nm
call sqlConnect m.nd.sub
call rebindStmts o, strip(cr), strip(nm)
call sqlDisconnect
call mStrip o, 't'
call writeDsn rebiJob, m.o., ,1
return
endProcedure loadJob
/*--- generate count job ---------------------------------------------*/
cntJob: procedure expose m.
parse arg cntJob, nd
call mapPut v, 'dbSub', m.nd.sub
call mapPut v, 'tb', m.nd.tb
call jobCards mCut(o, 0), 'CNT'
call expSkel repaCnt, o
call mStrip o, 't'
call writeDsn cntJob, m.o., ,1
return
endProcedure loadJob
/*--- expand the variables in one skeleton, result to stem o --------*/
expSkel: procedure expose m.
parse arg skl, o
upper skl
if symbol('m.expSkel.skl') <> 'VAR' then
call readDsn m.skels'('skl')', 'M.EXPSKEL.'skl'.'
call mapExpAll v, o, expSkel.skl
return
endProcedure expSkel
/*--- all rebinds ----------------------------------------------------*/
rebindStmts: procedure expose m.
parse arg o, cr, tb
sel = bQualifier '=' quote(cr, "'") and bName '=' quote(tb, "'")
call debug 'sel =' sel
p = ':m.pk.sx.'
call sqlPreOpen 8,
, "select distinct dCollid, dName, dContoken, version, p.type,",
"p.bindTime, p.valid, p.operative",
"from sysibm.sysPackDep d, sysibm.sysPackage p" ,
"where bType in ('T')" ,
"and d.dLocation = p.location" ,
"and d.dCollid = p.collid" ,
"and d.dName = p.name" ,
"and d.dConToken = p.conToken" ,
"and ("sel")" ,
"order by 2, 4, 1"
do sx=1 while sqlFetchInto(8, ':col, :nam, :cTo, :ver, :typ,' ,
':bTi, :val, :ope')
call debug sx col nam c2x(cTo) ver typ bTi 'vo' val ope
st = 'PACKAGE('strip(col)'.'strip(nam)
if typ = 'T' then
st = 'REBIND TRIGGER' st')'
else
st = 'REBIND' st'.('strip(ver)'))'
call mAdd o, st '-'
call mAdd o, ' /* valid='val', op='ope', lastBind='bTi '*/'
end
call sqlClose 8
return sx-1
endProcedure rebindStmts
/* copy sql begin ***************************************************
sql interface
***********************************************************************/
sqlIni: procedure expose m.
m.sqlNull = '---'
return
endProcedure sqlIni
/*--- prepare statement 's'cx from sql src into descriptor desc ------*/
sqlPrepare: procedure expose m.
parse arg cx, src, descOut, descInp
s = ''
if descOut == 1 then
s = 'into :M.SQL.'cx'.D'
call sqlExec 'prepare s'cx s 'from :src'
if descInp == 1 | (descInp == '' & pos('?', src) > 0) then
call sqlExec 'describe input s'cx 'into :M.SQL.'cx'.I'
else
m.sql.cx.i.sqlD = 0
return
endProcedure
/*--- prepare and declare 'c'cx from sql src -------------------------*/
sqlPreDeclare: procedure expose m.
parse arg cx, src, descOut, descInp
call sqlPrepare cx, src, descOut, descInp
call sqlExec 'declare c'cx 'cursor for s'cx
return
endProcedure sqlPreDeclare
/*--- prepare, declare and open 'c'cx from sql src -------------------*/
sqlPreOpen: procedure expose m.
parse arg cx, src, descOut, descInp
call sqlPreDeclare cx, src, descOut, descInp
call sqlOpen cx
return
endProcedure sqlPreOpen
/*--- open cursor 'c'cx using arguments arg(2), arg(3)... ------------*/
sqlOpen: procedure expose m.
parse arg cx
do ix=1 to arg()-1
call sqlDataSet 'SQL.'cx'.I', ix, arg(ix+1)
end
call sqlExec 'open c'cx 'using descriptor :M.SQL.'cx'.I'
return
endProcedure sqlOpen
/*--- close cursor 'c'cx ---------------------------------------------*/
sqlClose: procedure expose m.
parse arg cx, src
return sqlExec('close c'cx)
endProcedure sqlClose
/*--- fetch cursor 'c'cx into variables ggVars -----------------------*/
sqlFetchInto:
parse arg ggCx, ggVars
if ggVars == '' then
ggVars = 'descriptor :M.SQL.'ggCX'.D'
/* accept sqlCodes > 0 except 100 */
return sqlExec('fetch c'ggCx 'into' ggVars, 0 100) <> 100
endProcedure sqlFetchInto
/*--- return sql variable list for stem st and fields the word in vars
if withInd == 1 then with sqlIndicator variables
sqlVars('S', 'A B') --> ':S.A, :S.B'
sqlVars('S', 'A B', 1) --> ':S.A :S.A.SQLIND, :S.B :S.B.SQLIND'
----------------------------------------------------------------------*/
sqlVars: procedure expose m.
parse arg st, vars, withInd
res = ''
if st ^== '' then
st = st'.'
do ix=1 to words(vars)
res = res', :'st || word(vars, ix)
if withInd == 1 then
res = res ':'st || word(vars, ix)'.SQLIND'
end
return substr(res, 3)
endProcedure sqlVars
sqlVarsNull: procedure expose m.
parse arg st, vars
hasNulls = 0
do ix = 1 to words(vars)
fld = word(vars, ix)
if m.st.fld.sqlInd < 0 then do
m.st.fld = m.sqlNull
hasNulls = 1
end
end
return hasNulls
endProcedure sqlVarsNull
sqlDescNull: procedure expose m.
parse arg cx
desc = 'SQL.'ggCX'.D',
hasNulls = 0
do ix=1 to m.desc.SQLD
if m.desc.ix.sqlInd < 0 then do
m.desc.ix.sqlData = m.sqlNull
hasNulls = 1
end
end
return hasNulls
endProcedure sqlDescNull
/*--- open cursor 'c'cx fetch all into variables vars and close
st = passed stem, sx = row number
return number of rows fetched ----------------------------------*/
sqlOpAllCl:
parse arg ggCx, st, ggVars
do ggAx=4 to arg()
call sqlDataSet 'SQL.'ggCx'.I', ggAx-3, arg(ggAx)
end
call sqlOpen ggCx
do sx = 1 while sqlFetchInto(ggCx, ggVars)
end
m.st.0 = sx - 1
call sqlClose ggCx
return m.st.0
endProcedure sqlOpAllCl
sqlDataSet: procedure expose m.
parse arg da, ix, val
m.da.ix.sqlData = val
m.da.ix.sqlInd = - (arg(ix+2) == m.sqlNull)
return
endProcedure sqlDataSet
/*--- prepare, declare open cursor 'c'cx, fetch all and close
return number of rows fetched ----------------------------------*/
sqlPreAllCl:
parse arg ggCx, ggSrc, st, ggVars
call sqlPreDeclare ggCx, ggSrc
return sqlOpAllCl(ggCx, st, ggVars)
endProcedure sqlPreAllCl
/*--- execute statement 's'cx using arguments arg(2), arg(3)... ------*/
sqlExecute:
parse arg ggCx
do ggAx=2 to arg()
call sqlDataSet 'SQL.'ggCx'.I', ggAx-1, arg(ggAx)
end
call sqlExec 'execute s'ggCx 'using descriptor :M.SQL.'ggCx'.I'
return
endProcedure
/*--- execute immediate the sql src ----------------------------------*/
sqlExImm:
parse arg ggSrc, ggRet
return sqlExec('execute immediate :ggSrc', ggRet)
endProcedure sqlExImm
sqlCommit: procedure expose m.
parse arg src
return sqlExec('commit')
endProcedure sqlCommit
/*--- execute sql thru the dsnRexx interface -------------------------*/
sqlExec: /* no procedure, to keep variables sql... */
parse arg ggSqlStmt, ggRet, ggNo
if ggNo <> '1' then
ggSqlStmt = 'execSql' ggSqlStmt
address dsnRexx ggSqlStmt
/* say 'sqlCode' sqlCode 'rc' rc 'for' ggSqlStmt ggNo */
if rc = 0 then
return 0
else if ggRet = '*' | wordPos(sqlCode, ggRet) > 0 then
return sqlCode
else if rc < 0 then
call err sqlmsg()
else if sqlWarn.0 ^== ' ' | sqlCode <> 0 then
call errSay sqlMsg(), ,'w'
return sqlCode
endSubroutine sqlExec
/*--- connect to the db2 subsystem ggSys -----------------------------*/
sqlConnect: procedure expose m.
parse arg ggSys, ggRetCon
call sqlIni
address tso "SUBCOM DSNREXX"
if rc <> 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
if ggSys = '-' then
return 0
return sqlExec("connect" ggSys, ggRetCon ,1)
endProcedure sqlConnect
/*--- diconnect from db2 ---------------------------------------------*/
sqlDisconnect: procedure expose m.
parse arg ggRet
call sqlExec "disconnect ", ggRet, 1
return
endProcedure sqlDisconnect
/*--- issue an sql error message -------------------------------------*/
sqlMsg: /* no procedure, to keep variables sql... */
signal on syntax name sqlMsgOnSyntax
ggRes = 'sqlCode' sqlCodeT(sqlCode, sqlErrMc, sqlwarn.0':' ,
|| sqlwarn.1||sqlwarn.2||sqlwarn.3||sqlwarn.4||sqlwarn.5',',
|| sqlwarn.6||sqlwarn.7||sqlwarn.8||sqlwarn.9||sqlwarn.10)
if 0 then
sqlMsgOnSyntax: do
ggRes = 'sqlCode' sqlCode translate(sqlErrMc, ',', 'ff'x),
'<<rexx sqlCodeT not found or syntax>>\nwarnings'
do ggX=0 to 10
if sqlWarn.ggx <> '' then
ggRes = ggRes ggx'='sqlWarn.ggx
end
end
signal off syntax
ggRes = ggRes'\nstate' sqlState'\nstmt = ' ggSqlStmt
ggPref = '\nwith'
ggXX = pos(':', ggSqlStmt)+1
do 12 while ggXX > 1
ggYY = verify(ggSqlStmt, ' ,:+-*/&%?|()¢!', 'm', ggXX)
if ggYY < 1 then
ggYY = length(ggSqlStmt) + 1
ggVar = substr(ggSqlStmt, ggXX, ggYY - ggXX)
if ggVar <> '' then do
ggRes = ggRes || ggPref ggVar '=' value(ggVar)
ggPref = '\n '
end
ggXX = pos(':', ggSqlStmt, ggYY+1) + 1
end
return ggRes
endSubroutine sqlMsg
/*--- send a command to db2 through the TSO dsn processor ------------*/
sqlDsn: procedure expose m.
parse arg st, sys, cmd, rcOk
x = outtrap('M.'st'.')
push 'END'
push cmd
call address tso 'DSN SYSTEM('sys')'
rr = rc
x = outtrap(off)
if rr = 0 | rcOk = '*' | wordPos(rr, rcOk) > 0 then
return rr
fl = max(1, m.st.0 - 10)
em = 'rc' rr 'for DSN SYSTEM('sys') cmd' cmd,
'\nOuputlines' fl '-' m.st.0':'
do lx=fl to m.st.0
em = em '\n' strip(m.st.lx, 't')
end
call err em
endProcedure sqlDsn
/* copy sql end **************************************************/
/* copy mapExp begin **************************************************/
mapVia: procedure expose m.
parse arg a, ky
sx = pos('*', ky)
if sx < 1 then
return mapGet(a, ky)
via = mapGet(a, left(ky, sx-1))
do while sx <= length(ky)
fx = sx+1
sx = pos('*', ky, fx)
if sx < 1 then
sx = length(ky) + 1
if sx = fx then do
if symbol('m.via') ^== 'VAR' then
call err 'missing m.'via 'at' sx 'in mapVia('a',' ky')'
via = m.via
end
else do
f = substr(ky, fx, sx - fx)
if symbol('m.via.f') ^== 'VAR' then
call err 'missing m.'via'.'f ,
'at' sx 'in mapVia('a',' ky')'
via = m.via.f
end
end
return via
endProcedure mapVia
mapExpAt: procedure expose m.
parse arg a, src, sx
m.map.ExpAt = 0
cx = pos('$', src, sx)
if cx < 1 then
return substr(src, sx)
res = substr(src, sx, cx-sx)
do forever
if substr(src, cx+1, 1) = '{' then do
ex = pos('}', src, cx+2)
if ex < 1 then
call err 'missing } after' substr(src, cx) 'in' src
res = res || mapVia(a, strip(substr(src, cx+2, ex-cx-2)))
ex = ex + 1
end
else do
ex = verify(src, m.mAlfDot, 'n', cx+1)
if ex < 1 then
return res || mapVia(a, substr(src, cx+1))
if ex = cx+1 then do
m.map.ExpAt = cx
return res
end
res = res || mapVia(a, substr(src, cx+1, ex-cx-1))
end
cx = pos('$', src, ex)
if cx < 1 then
return res || substr(src, ex)
res = res || substr(src, ex, cx-ex)
end
endProcedure mapExpAt
mapExp: procedure expose m.
parse arg a, src
res = mapExpAt(a, src, 1)
if m.map.ExpAt ^== 0 then
call err 'mapExp stopped at' substr(src, map.ExpAt) 'in' src
return res
endProcedure mapExp
mapExpAllAt: procedure expose m.
parse arg a, dst, src, sx, cx
do while sx <= m.src.0
li = mapExpAt(a, m.src.sx, cx)
dx = m.map.ExpAt
if (cx=1 & dx = 0) | li ^= '' then
call mAdd dst, li
if dx = 0 then do
cx = 1
sx = sx+1
end
else do
return sx dx
end
end
return ''
endProcedure mapExpAllAt
mapExpAll: procedure expose m.
parse arg a, dst, src
sto = mapExpAllAt(a, dst, src, 1, 1)
if sto == '' then
return
lx = word(sto, 1)
call err 'mapExpAll stopped at' sto':' m.src.lx
endProcedure mapExpAll
/* copy mapExp end ****************************************************/
/* copy map begin ******************************************************
a map stores values at keys
it may also maintain a list of keys
the basic ideas are similar to the java Interface java.util.Map
contrary to stems we also handle keys longer then 250 bytes
***********************************************************************/
/*--- initialize the module ------------------------------------------*/
mapIni: procedure expose m.
if m.map.ini = 1 then
return
m.map.ini = 1
call mIni
m.map.0 = 0
return
endProcedure mapIni
/*--- create a new map ----------------------------------------------*/
mapNew: procedure expose m.
parse arg opt
return mapReset('MAP.'mInc('MAP.0') , opt)
endProcedure mapNew
/*--- make an empty map, if opt <> '' maintain stem of keys
('K' in map.keys, '=' in a else in opt) --------------*/
mapReset: procedure expose m.
parse arg a, opt
if symbol('m.map.keys.a') == 'VAR' then
call mapClear a
upper opt
if opt = '=' then
st = a
else if opt = 'K' then
st = 'MAP.KEYS.'a
else
st = opt
m.map.keys.a = st
if st ^== '' then
m.st.0 = 0
if abbrev(a, 'MAP.') then
m.map.loKy.a.0 = 0
return a
endProcedure
/*--- add a new key value pair to the map ----------------------------*/
mapAdd: procedure expose m.
parse arg a, ky, val
vv = mapValAdr(a, ky, 'a')
m.vv = val
return val
endProcedure mapAdd
/*--- change the value at a key or add key value ---------------------*/
mapPut: procedure expose m.
parse arg a, ky, val
vv = mapValAdr(a, ky, 'p')
m.vv = val
return val
endProcedure mapPut
/*--- return 1 if key ky exists in map a, 0 otherwise ----------------*/
mapHasKey: procedure expose m.
parse arg a, ky
return mapValAdr(a, ky) ^== ''
endProcedure mapHasKey
/*--- return the value of key ky in map a if it exists,
else if called with a third argument return third argument
else issue an error ----------------------------------------*/
mapGet: procedure expose m.
parse arg a, ky
vv = mapValAdr(a, ky)
if vv ^== '' then
return m.vv
else if arg() >= 3 then
return arg(3)
else
call err 'missing key in mapGet('a',' ky')'
endProcedure mapGet
/*--- return a stem of all keys --------------------------------------*/
mapKeys: procedure expose m.
parse arg a
if m.map.keys.a == '' then
call err 'mapKeys('a') with no keys'
return m.map.keys.a
endProcedure mapKeys
/*--- remove a key from the map, do nothing if it is missing ---------*/
mapRemove: procedure expose m.
parse arg a, ky
vv = mapValAdr(a, ky)
if vv == '' then
return ''
if m.map.keys ^== '' then
call err 'not implemented mapRemove('a',' ky')'
val = m.a.vv
drop m.a.ky
return val
endProcedure mapRemove
/*--- remove all entries ---------------------------------------------*/
mapClear: procedure expose m.
parse arg a
st = mapKeys(a)
do kx=1 to m.st.0
k = m.st.kx
if length(k) > 200 then do
k = left(k, 201)
if symbol('m.a.k') == 'VAR' then/* ist noch hier */
call mapClear m.a.k
end
drop m.a.k m.st.kx
end
m.st.0 = 0
return a
endProcedure mapClear
/*--- return the value pointer for a key, '' if non existing
with fun = 'a' add a key, with 'p' put a key ------------*/
mapValAdr: procedure expose m.
parse arg pA, pKy, fun
a = pA
ky = pKy
do forever
if length(ky) <= 200 then do
if symbol('m.a.ky') ^== 'VAR' then
leave
if fun == 'a' then
call err 'duplicate key' pKy 'in map' pA
return a'.'ky
end
k1 = left(ky, 201)
if symbol('m.a.k1') ^== 'VAR' then
leave
a = m.a.k1
ky = substr(ky, 202)
end
if fun == '' then
return ''
opt = left('K', m.map.keys.pA ^== '')
if opt == 'K' then
call mAdd m.map.Keys.pA, pKy
do while length(ky) > 200
k1 = left(ky, 201)
n = mapNew(opt)
m.a.k1 = n
if a ^== pA & opt == 'K' then
call mAdd m.map.keys.a, ky
a = n
ky = substr(ky, 202)
end
return a'.'ky
endProcedure mapValAdr
/* copy map end *******************************************************/
/* copy m begin ********************************************************
we use variables as follows
m. stem m: all global data and object data that must survive
a procedure call (m for memory in Memoria of B5000)
m.<mbr>.** to avoid conflicts: every rexx Module (copy) should
only allocate addresses m.<mbr>.** with <mbr> the name of
the rexx module
we pass parameters around (e.g. a=address, m=memory, st=stem)
and the called function may use m.a or m.a.subField etc.
gg*: local variable in subroutines without procedure
everything else: temporary data within procedure
every subroutine is declared as procedure expose m.
(also if no m. variable is used, because e.g. of error handling)
the few subroutines that cannot use procedure, should use only
variables starting with gg
***********************************************************************/
/*--- increase m.a and return it (fail if undefined) -----------------*/
mInc: procedure expose m.
parse arg a
m.a = m.a + 1
return m.a
endProcedure mInc
/*--- cut stem a to length len ---------------------------------------*/
mCut: procedure expose m.
parse arg a, len
m.a.0 = len
return a
endProcedure mCut
/*--- add one or several arguments to stem m.a -----------------------*/
mAdd: procedure expose m.
parse arg a
ix = m.a.0
do ax = 2 to arg()
ix = ix + 1
m.a.ix = arg(ax)
end
m.a.0 = ix
return a'.'ix
endProcedure mAdd
/*--- add to m.dst.* a (sub)sequence of m.src.* ----------------------*/
mAddSt: procedure expose m.
parse arg dst, src
dx = m.dst.0
do sx = 1 to m.src.0
dx = dx + 1
m.dst.dx = m.src.sx
end
m.dst.0 = dx
return
endProcedure mAddAt
/*--- strip all elements of a stem -----------------------------------*/
mStrip: procedure expose m.
parse arg st, opt
if opt == '' then
opt = 'b'
do x=1 to m.st.0
m.st.x = strip(m.st.x, opt)
end
return st
endProcedure mStrip
/*--- cat all elements of a stem together ----------------------------*/
mCat: procedure expose m.
parse arg st, mid
if m.st.0 < 1 then
return ''
res = m.st.1
do x=2 to m.st.0
res = res || mid || m.st.x
end
return res
endProcedure mCat
mIni: procedure expose m.
if m.m.ini = 1 then
return
m.m.ini = 1
m.mAlfLC = 'abcdefghijklmnopqrstuvwxyz'
m.mAlfUC = translate(m.mAlfLC)
m.mAlfa = m.mAlfLC || m.mAlfUC
m.mAlfNum = m.mAlfa || '0123456789'
m.mAlfDot = m.mAlfNum || '.'
return
endProcedure mIni
/* copy m end *********************************************************/
/* copy adrIsp begin *************************************************/
/**********************************************************************
lmd: catalog read
call sequence: lmdBegin, lmdNext*, lmdEnd
mit lmd service (mit save in file und read,
weil list zu langsam und listcat abstürzt)
1. arg (grp) als group dataset für lmd save
und dd name für file read
***********************************************************************/
lmdBegin: procedure expose m.
parse arg grp, lev
call adrIsp 'lmdinit listid(lmdId) level('lev')'
res = adrIsp('lmdlist listid(&lmdId) option(save) group('grp')', 4)
call adrIsp 'lmdfree listid(&lmdId)'
if res = 0 then do
call trc timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') shr dsn('grp'.datasets)'
end
else do
call trc 'no datasets found' timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') dummy'
end
call readDDBegin grp
return /* end lmdBegin */
lmdNext:
parse arg ggGrp, ggSt, withVolume
if ^ readDD(ggGrp, ggSt) then
return 0
if withVolume ^== 1 then
do ggIx=1 to value(ggSt'0')
x = value(ggSt || ggIx, word(value(ggSt || ggIx), 1))
end
return 1
endSubroutin lmdNext
lmdEnd: procedure expose m.
parse arg grp
call readDDEnd grp
call adrTso 'free dd('grp')'
return /* end lmdEnd */
lmd: procedure expose m.
parse arg lev, withVol
call lmdBegin gg1, lev
do while lmdNext(gg1, q., withVol)
do x=1 to q.0
call jOut q.x
end
end
call lmdEnd gg1
return
endProcedure lmd
/**********************************************************************
member list of a pds:
call sequence x=lmmBegin(dsn) lmmNext(x) * lmmEnd(x)
***********************************************************************/
lmm: procedure expose m.
parse arg dsn
id = lmmBegin(dsn)
do ix=1 by 1
m = lmmNext(id)
if m = '' then
leave
call jOut m
end
call lmmEnd id
return
endProcedure lmm
lmmBegin: procedure expose m.
parse arg dsn
mbr = dsnGetMbr(dsn)
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET('"pds"') ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(INPUT) "
res = lmmId
if mbr <> '' then
res = res 'pattern('mbr')'
return res
endProcedure lmmBegin
lmmEnd: procedure expose m.
parse arg lmmId opt
call adrIsp "LMMLIST DATAID("lmmId") option(free)", 8
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
return
endProcedure lmmEnd
lmmNext: procedure expose m.
parse arg lmmId opt
if adrIsp("LMMLIST DATAID("lmmid")" ,
"OPTION(LIST) MEMBER(Mbr)" opt, 4 8) = 0 then
return strip(mbr)
else
return ''
endProcedure lmmNext
lmmRm: procedure expose m.
parse arg dsn, mbrs
mbrs = dsnGetMbr(dsn) mbrs
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET("pds") ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(OUTPUT) "
err = ''
do wx=1 to words(mbrs)
m1 = word(mbrs, wx)
rr = adrIsp("lmmDel dataid("lmmId") member("m1")", 0 8 12)
if rc = 0 then
say 'removed' m1 'from' pds
else if rc = 8 then
say 'not found' m1 'in' pds
else do
err = 'error deleting' m1 'in' pds 'rc' rr strip(zerrlm)
say err
leave
end
end
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
if err <> '' then
call err err
return
endProcedure lmmRm
/*--- address ispf with error checking -------------------------------*/
adrIsp:
parse arg ggIspCmd, ggRet
address ispexec ggIspCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr ispExec rc' rc 'in' ggIspCmd':' strip(zerrlm)
endSubroutine adrIsp
/*--- address editor with error checking -----------------------------*/
adrEdit:
parse arg ggEditCmd, ggRet
address isrEdit ggEditCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr isrEdit rc' rc 'for' ggEditCmd
endSubroutine adrEdit
/* copy adrIsp end *************************************************/
/* copy adrTso begin *************************************************/
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet ---*/
adrTso:
parse arg ggTsoCmd, ggRet
address tso ggTsoCmd
if rc == 0 then return 0
else if ggRet == '*' then return rc
else if wordPos(rc, ggRet) > 0 then return rc
else
call err 'adrTso rc' rc 'for' ggTsoCmd
return /* end adrTso */
/*--- format dsn from tso format to jcl format -----------------------*/
dsn2jcl: procedure expose m.
parse arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
cx = pos('~', dsn)
if cx < 1 & addPrefix == 1 then
return sp'.'dsn
do while cx ^== 0
le = left(dsn, cx-1)
ri = substr(dsn, cx+1)
if right(le, 1) == '.' | left(ri, 1) == '.' then
dsn = le || sp || ri
else
dsn = le || left('.', le ^== '') || sp ,
|| left('.', ri ^== '') || ri
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
parse arg dsn, mbr
bx = pos('(', dsn)
if bx > 0 then
dsn = strip(left(dsn, bx-1))
if mbr <> '' then
dsn = dsn'('strip(mbr)')'
return dsn
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn
lx = pos('(', dsn)
rx = pos(')', dsn, lx+1)
if lx < 1 then
return ''
else if lx < rx then
return substr(dsn, lx+1, rx-lx-1)
else
return strip(substr(dsn,lx+1))
endProcedure dsnGetMbr
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: readDDBegin, readDD*, readDDEnd
write: writeBegin, writeDD*, writeEnd
readDD returns true if data read, false at eof
***********************************************************************/
/*--- prepare reading from a DD --------------------------------------*/
readDDBegin: procedure expose m.
return /* end readDDBegin */
/*--- read from DD ggDD into ggSt, return false at eof ---------------*/
readDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskr' ggDD '(stem' ggSt')', 2
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- finish reading DD ggDD ----------------------------------------*/
readDDEnd: procedure expose m.
parse arg ggDD
call adrTso 'execio 0 diskr' ggDD '(finis)'
return /* end readDDEnd */
/*--- prepare writing to DD ggDD -------------------------------------*/
writeDDBegin: procedure expose m.
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 expose m.
parse arg ggDD
call adrTso 'execio 0 diskw' ggDD '(finis)'
return /* end writeDDEnd */
/*--- 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, disp, dd, retRc
ds = ''
m.dsnAlloc.dsn = ds
if left(spec, 1) = '-' then
return strip(substr(spec, 2))
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
disp = w
else if w = 'CATALOG' then
disp = disp w
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
ds = strip(substr(w, 5, length(w)-5))
else if ds = '' then
ds = dsn2jcl(w)
else
leave
end
rest = subword(spec, wx)
if abbrev(rest, '.') then
rest = substr(rest, 2)
parse var rest rest ':' nn
if dd <> '' & ds = '' & rest = '' & ^ abbrev(disp, 'SYSO') then
call err "'return" dd"' no longer supported please use -"dd
if dd = '' then do
if symbol('m.adrTso.ddNum') = 'VAR' then
dd = m.adrTso.ddNum + 1
else
dd = 1
m.adrTso.ddNum = dd
dd = 'DD' || dd
end
if disp = '' then
disp = 'SHR'
else if pos('(', ds) < 1 then
nop
else if disp = 'MOD' then
call err 'disp mod for' ds
else
disp = 'SHR'
m.dsnAlloc.dsn = ds
if pos('/', ds) > 0 then
return csmAlloc(dd, disp, ds, rest, nn, retRc)
else
return tsoAlloc(dd, disp, ds, rest, nn, retRc)
endProcedure dsnAlloc
tsoAlloc: procedure expose m.
parse arg dd, disp, dsn, rest, nn, retRc
c = 'alloc dd('dd')' disp
if dsn <> '' then
c = c "DSN('"dsn"')"
if retRc <> '' | nn = '' then do
alRc = adrTso(c rest, retRc)
if alRc <> 0 then
return alRc
return dd 'call adrTso "free dd('dd')";'
end
do retry=0 by 1
alRc = adrTso(c rest, '*')
if alRc = 0 then
return dd 'call adrTso "free dd('dd')";'
if retry > 0 | nn = '' | wordPos(disp, 'OLD SHR') < 1 ,
| sysDsn("'"m.dsnAlloc.dsn"'") ^== 'DATASET NOT FOUND' then
call err 'tsoAlloc rc' alRc 'for' c rest
say 'tsoAlloc rc' alRc 'for' c rest '...trying to create'
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(dsn, nn)
call adrTso 'free dd('dd')'
end
endProcedure tsoAlloc
dsnCreateAtts: procedure expose m.
parse arg dsn, atts, forCsm
bl = 32760
if abbrev(atts, ':') then do
rl = substr(atts, 3)
if abbrev(atts, ':F') then do
if rl = '' then
rl = 80
recfm='f b'
bl = bl - (bl // rl)
end
else do
if rl = '' then
rl = bl-4
recfm = substr(atts, 2, 1) 'B'
end
end
if pos('(', dsn) > 0 then
po = 'dsntype(library) dsorg(po)'
else
po = ''
dsn = dsnSetMbr(dsn)
if forCsm == 1 then
return "dataset('"dsn"')" po,
"recfm("space(recfm, 0)") lrecl("rl") blkSize("bl")" ,
"mgmtclas(COM#A011) space(10, 1000) cylinder"
else
return "dsn('"dsn"')" po,
"recfm("recfm") lrecl("rl") block("bl")" ,
"mgmtclas(COM#A011) space(10, 1000) cyl"
endProcedure dsnCreateAtts
/*--- read the dataset specified in ggDsnSpec to stem ggSt -----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
interpret subword(ggAlloc, 2)
return
endSubroutine readDsn
/*--- write the dataset specified in ggDsnSpec from stem ggSt
write ggCnt records if not empty otherwise ggst0
if ggSay 1 then say ... records written to ... -------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'open finis)'
interpret subword(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
copyDSN: procedure expose m.
parse arg frSpec, toSpec, ggSay
frDD = dsnAlloc(frSpec, 'SHR', 'FRDD')
toDD = dsnAlloc(toSpec, 'OLD', 'TODD')
call readDDBegin word(frDD, 1)
call writeDDBegin word(toDD, 1)
cnt = 0
do while readDD(word(frDD, 1), r.)
call writeDD word(toDD, 1), r.
cnt = cnt + r.0
end
call readDDEnd word(frDD, 1)
call writeDDEnd word(toDD, 1)
interpret ';' subword(frDD, 2) '; ; ;' subword(toDD, 2)
if ggSay == 1 | m.debug == 1 then
say cnt 'records copied from' frSpec 'to' to toSpec
return
endSubroutine writeDsn
/* copy adrTso end ****************************************************/
/* copy err begin ******************************************************
messages, errorhandling,help
***********************************************************************/
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
parse arg oo, ha
if pos('I', translate(oo)) > 0 then
call adrIsp 'control errors return'
m.err.opt = translate(oo, 'h', 'H')
if ha == '' then
drop m.err.handler
else
m.err.handler = ha
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
drop err handler opt
if ggOpt == '' & symbol('m.err.handler') == 'VAR' then
interpret m.err.handler
call errSay ggTxt
parse source . . ggS3 . /* current rexx */
if ggOpt == '' | ggOpt == '*' then
ggOpt = translate(value('m.err.opt'), 'ht', 'HT')
if pos('h', ggOpt) > 0 then do
say 'fatal error in' ggS3': divide by zero to show stackHistory'
x = 1 / 0
end
say 'fatal error in' ggS3': exit(12)'
exit errSetRc(12)
endSubroutine err
/*--- assert that the passed rexx expression evaluates to true -------*/
assert:
interpret 'assertRes =' arg(1)
if ^ assertRes then
call err 'assert failed' arg(1)':' arg(2)
return
endProcedure assert
/*--- say an errorMessage msg with pref pref
split message in lines at '/n'
say addition message in stem st ---------------------------*/
errSay: procedure expose m.
parse arg msg, st, pref
parse source . . ggS3 . /* current rexx */
if pref == 'e' | (pref == '' & st == '') then
msg = 'fatal error:' msg
else if pref == 'w' then
msgf = 'warning:' msg
else if pref == 0 then
nop
else if right(pref, 1) ^== ' ' then
msg = pref':' msg
else
msg = pref || msg
sx = 0
bx = -1
do lx=1 until bx >= length(msg)
ex = pos('\n', msg, bx+2)
if ex < 1 then
ex = length(msg)+1
if st == '' then do
say substr(msg, bx+2, ex-bx-2)
end
else do
sx = sx+1
m.st.sx = substr(msg, bx+2, ex-bx-2)
m.st.0 = sx
end
bx = ex
end
return
endProcedure errSay
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg, op
say 'fatal error:' msg
call help
call err msg, op
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
----------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if sysVar('sysISPF') = 'ACTIVE' then do
address ispExec vput 'zIspfRc' shared
end
return zIspfRc
endProcedure errSetRc
/*--- 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 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
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
say 'debug' msg
return
endProcedure debug
/*--- return current time and cpu usage ------------------------------*/
timing: procedure expose m.
return time() time('E') sysvar('syscpu') /* sysvar('syssrv') */
/--- display the first comment block of the source as help -----------*/
help: procedure expose m.
parse source . . s3 .
say right(' help for rexx' s3, 79, '*')
do 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 *****************************************************/
}¢--- A540769.WK.REXX(RLRSN) cre=2014-12-10 mod=2014-12-11-09.44.58 A540769 ----
/*rexx*/
/******************************************************************/
/* LRSN */
/* */
/* 1 FUNCTION Translate Timestamp <-> LRSN (Todclock) */
/* */
/* 2 SUMMARY */
/* TYPE Rexx TSO/ISPF */
/* HISTORY: */
/* 09.11.2006 V1.0 base version (M.Streit,KITD2) */
/* 01.11.2007 V1.1 added uniq (W.Keller,KIUT23) */
/* */
/* Call: tso lrsn (TSO.RZ1.P0.USER.EXEC) */
/* */
/* 3 USAGE rexx lrsn start-procedure */
/* rexx rlrsn programm */
/* panel plrsn Mainpanel */
/* table tlrsn ISPF table */
/* */
/******************************************************************/
debug = 0 /* 0 oder 1 */
numeric digits 32
/* Check if LogMode 4 used */
lines=SYSVAR(SYSLTERM)
cols =SYSVAR(SYSWTERM)
if lines < 43
then do;
address ISPEXEC;
zmsg000l = "LM4 with 43x80 Chars required"
"setmsg msg(ispz000)"
exit(8);
end ;
say 'walters test version lrsn'
/* Create ISPF table if necessary */
address ispexec
"control errors return" /* ISPF Error -> control back to pgm */
"tbopen tlrsn write" /* try to open table */
NAMES ="(CLRSN CTS CTSUTC CUNIQ JULIAN GMTTIME)"
if RC = 0 then do
address ispexec "tbQuery tlrsn names(tnm)"
if tnm <> names then do
say 'old table tLrsn has bad filed names' tnm
say 'drop and recreate table tLrsn' names
address ispexec 'tbEnd tLrsn'
address ispexec 'tberase tLrsn'
rc = 8
end
end
if rc = 8 then do /* if table not found...*/
address ispexec
"tbcreate tlrsn", /* table create */
"names"names "write replace"
if rc > 4 then do
say "Table create error with RC "rc
exit
end
"tbopen tlrsn write" /* table open */
end
if rc = 12 then do
"tbclose tlrsn "
"tbopen tlrsn write" /* try to open table */
if rc > 0 then do
say "Table open error with RC "rc
end
end
"tbtop tlrsn" /* jump to first row */
/* Display panel until PF3 is pressed */
selrows = "ALL" /* Angaben für Panel */
num1 = 1 /* Linien-Pointer */
c = ''
zc = 'CSR'
sdata = 'N'
ptimest = ''
plrsn = ''
do forever /* solange nicht PF3 */
call timeReadCvt
cLS = trunc(m.time_Leap * m.time_StckUnit)
cTZ = trunc(m.time_Zone * m.time_StckUnit / 3600)
"tbtop tlrsn" /* jump to first row */
"tbdispl tlrsn panel(plrsn)" /* Panel anzeigen bis */
if rc > 4 then leave /* PF3 gedrückt? */
do while rc < 8
if c = 'D' then do
call del_row /* Zeilen löschen */
end
else if c <> ' ' then do
zmsg000s = "Command unknown"
zmsg000l = "Command unknown, only Delete(D) allowed"
"setmsg msg(ispz000)" /* Meldung ausgeben */
leave
end
if ztdSels <= 1 then
leave
"tbdispl tlrsn" /* get next selection */
end
c = ''
if plrsn <> '' then do
eLrsn = left(pLrsn, 12, 0)
call show timeLrsn2LZT(eLrsn), eLrsn
pLrsn = ''
end
if ptimest <> '' then do
rTimeSt = checkTst(pTimeSt)
if rTimeSt \== '' then
call show rTimeSt, timeLZT2Lrsn(rTimeSt)
pTimeSt = ''
end
if pUniq <> '' then do
lrsn = timeUniq2Lrsn(pUniq)
call show timeLrsn2LZT(lrsn), lrsn, pUniq
pUniq = ''
end
end
if sdata='Y' then
"tbclose tlrsn "
else
"tbend tlrsn"
exit
show:
parse arg cTs, cLrsn, cUniq
ctsutc = timeLrsn2Gmt(cLrsn)
gmtTime = substr(ctsutc, 12, 8)
if cUniq == '' then
cUniq = timeLrsn2uniq(cLrsn)
julian = time2jul(cts)
"tbadd tlrsn"
return 0
endSubroutine show
/* expand timestamp and validate it ***********************************/
checkTst: procedure
parse arg pTimeSt
/* ptimest = Timestamp format yyyy-mm-dd-hh.mm.ss.ffffff */
rTimeSt =overlay(ptimest, '1972-01-01-00.00.00.000000')
call timestampParse rTimest
/* check if values in range */
if (\ datatype(yyyy, 'n') | yyyy<1972) | (yyyy>2141) then do
zmsg000s = ""
zmsg000l = "year range: 1972-2041"
address ispExec " setmsg msg(ispz000)" /* Meldung ausgeben */
return ''
end
if (\ datatype(mo, 'n') | mo<1) | (mo>12) then do
zmsg000s = ""
zmsg000l = "month range 1-12"
address ispExec "setmsg msg(ispz000)" /* Meldung ausgeben */
return ''
end
if (dd<1) | (dd>31) then do
zmsg000s = ""
zmsg000l = "day range 1-31"
address ispexec "setmsg msg(ispz000)" /* Meldung ausgeben */
return ''
end
return rTimest
endProckedure checkTst
/* delete current row ***********************************************/
del_row:
address ispexec
rowid_nr=0
"tbget tdbnr rowid(rowid_nr)" /* Curor-Position lesen */
"tbskip tdbnr row("rowid_nr")" /* Cursor auf Row setzen */
"tbdelete tlrsn" /* Zeile löschen */
c = ''
return
/* copy time begin ****************************************************
11.12.14 wk: added lrsn2uniq
11.05.13 wk: numeric digits transparent: in jeder Procedure drin
time2jul, tst externalisiert
**********************************************************************/
/*--- read timeZoneOffset and leapSeconds registers
and set variables for uniq ----------------------------------*/
timeReadCvt: procedure expose m.
parse arg debug
numeric digits 15
/* offsets documented in z/OS Data Areas Vol.1 */
cvtOH = '00000010' /* cvt control block Address */
cvtext2O = x2d('00000560') /* offset to extension 2 */
cvtldtoO = x2d('00000038') /* offset to timezone */
cvtlsoO = x2d('00000050') /* offset to leapSeconds */
/* CVT CB address + extention2 */
cvtExt2A = C2D(STORAGE(cvtOH,4)) + cvtext2O
/* cvtLdto timeZone address +offset */
m.time_Zone = c2d(STORAGE(d2x(cvtext2A+cvtldtoO, 8), 8))
m.time_StckUnit = 1e-6 / 256 / 16
/* cvtLso LeapSecs address +offset */
m.time_Leap = c2d(STORAGE(d2x(cvtext2A+cvtlsoO, 8), 8))
m.time_UQDigits = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ012345678'
/* find lrsn of day 0 */
m.time_UQZero = x2d(timeGmt2Lrsn('2004-12-31-00.00.22.000000')) ,
% 64 * 64 /* 0 out last 6 bits */
if debug == 1 then do
say 'stckUnit =' m.time_StckUnit
say 'timeLeap =' d2x(m.time_Leap,16) '=' m.time_Leap ,
'=' format(m.time_Leap * m.time_StckUnit,9,3) 'secs'
say 'timeZone =' d2x(m.time_Zone,16) '=' m.time_Zone,
'=' format(m.time_Zone * m.time_StckUnit,6,3) 'secs'
say "cvtext2_adr =" d2x(cvtExt2A, 8)
say 'timeUQZero =' m.time_UQZero
say 'timeUQDigis =' ,
length(m.time_UQDigits) 'digits' m.time_UQDigits
end
m.time_ReadCvt = 1
return
endSubroutine timeReadCvt
timestampParse:
parse arg yyyy'-'mo'-'dd'-'hh'.'mm'.'ss'.'ffffff
return
/*--- GMT timestamp yyyy-mm.... -> stck value char(8)
BLSUXTID is described in z/OS V1R7.0 MVS IPCS Customization
BLSUXTID format : mo/dd/yyyy hh:mm:ss.ffffff ---------------*/
timeGmt2Stck: procedure expose m.
parse arg tst
call timestampParse tst
tDate = mo'/'dd'/'yyyy' 'hh':'mm':'ss'.'ffffff
ACC=left('', 8, '00'x)
ADDRESS LINKPGM "BLSUXTID TDATE ACC"
RETURN acc
endProcedure timeGmt2Stck
/*--- GMT timestamp yyyy-mm.... -> stck value in hex(16) ------------*/
timeGmt2LRSN: procedure expose m.
return c2x(left(timeGmt2Stck(arg(1)), 6))
endProcedure timeGmt2LRSN
/*--- LZT (Locale Zurich Tst -> stck value in hex(16) ---------------*/
timeLZT2LRSN: procedure expose m.
parse arg tst
numeric digits 23
if m.time_ReadCvt \== 1 then
call timeReadCvt
return left(d2x(c2d(timeGmt2Stck(tst)) ,
- m.time_Zone + m.time_Leap, 16), 12)
endProcedure timeLZT2LRSN
/*--- conversion from Stck Clock Value to GMT Timestamp
BLSUXTOD is described in z/OS V1R7.0 MVS IPCS Customization
input -> + leapseconds -> output ----------------------------*/
timeStck2Gmt: PROCEDURE expose m.
parse arg stck
stck = left(stck, 8, '00'x)
TDATE = COPIES('0' , 26)
ADDRESS LINKPGM "BLSUXTOD stck TDATE"
/* return format : mo/dd/yyyy hh:mm:ss.ffffff */
/* Timestamp format: yyyy-mm-dd-hh.mm.ss.ffffff */
parse var TDATE mo '/' dd '/' yyyy hh ':' mm ':' ss '.' ffffff
RETURN yyyy'-'mo'-'dd'-'hh'.'mm'.'ss'.'ffffff
endProcedure timeStck2Gmt
/*--- conversion from Lrsn Clock Value to GMT Timestamp -------------*/
timeLrsn2Gmt:
return timeStck2Gmt(x2c(arg(1)))
endProcedure timeLrsn2Gmt
/*--- conversion from Lrsn Clock Value to LZT Local Zurich Time -----*/
timeLrsn2LZT: procedure expose m.
parse arg lrsn
numeric digits 23
if m.time_ReadCvt \== 1 then
call timeReadCvt
return timeStck2Gmt(d2c(x2d(left(lrsn, 16, 0)) ,
+ m.time_Zone-m.time_Leap))
endProcedure timeLrsn2LZT
/*--- timestamp to julian --------------------------------------------*/
time2jul: procedure expose m.
parse arg yyyy '-' mm '-' dd '-'
/* date function cannot convert to julian, only from julian
==> guess a julian <= the correct and
try the next values
*/
j = trunc((mm-1) * 29.5) + dd
yy = right(yyyy, 2)
do j=j by 1
j = right(j, 3, 0)
d = date('s', yy || j, 'j')
if substr(d, 3) = yy || mm || dd then
return yy || j
end
return
endProcedure time2jul
/* convert a lrsn to the uniq variable ********************************/
timeLrsn2uniq: procedure expose uniqZero uniqDigits debug
parse arg lrsn
/* unique are bits 0:41 of the TodClock value
minus 31.12.2004 represented
by base 35 by 'ABC...YZ01..8'
*/
if m.time_ReadCvt \== 1 then
call timeReadCvt
lrsn = left(lrsn, 12, 0)
numeric digits 15
diff = x2d(lrsn) - m.time_UQZero
if diff < 0 then
return'< 2005'
return right(i2q(diff % 64, m.time_UQDigits), 8, 'A')
endProcedure timeLrsn2Uniq
/* convert a uniq variable to lrsn ************************************/
timeUniq2lrsn: procedure expose m.
parse arg uniq
if m.time_ReadCvt \== 1 then
call timeReadCvt
numeric digits 15
u1 = q2i(left(uniq, 8, 'A'), m.time_UQDigits) * 64
lrsn = right(d2x(u1 + m.time_UQZero), 12, 0)
return lrsn
endProcedure uniq2lrsn
/*--- translate a number in q-system to decimal
arg digits givs the digits corresponding to 012.. in the q sysem
q = length(digits) --------------------------------------------*/
q2i: procedure expose m.
parse arg v, digits
b = length(digits)
i = 0
do x = 1 to length(v)
q = substr(v, x, 1)
r = pos(q, digits)
if r < 1 then
call err 'bad digit' q 'in' v 'valid digits' digits
i = i * b + r - 1
end
return i
endProcedure q2i
/*--- translate a decimal number to q-system - inverse of q2i --------*/
i2q: procedure expose m.
parse arg i, digits
if i = 0 then
return left(digits, 1)
b = length(digits)
v = ''
do while i > 0
v = substr(digits, 1 + (i // b), 1) || v
i = i % b
end
return v
endProcedure i2q
/* copy time end -----------------------------------------------------*/
}¢--- A540769.WK.REXX(RMMBR) cre=2009-04-30 mod=2009-04-30-15.54.53 F540769 ----
eins
wr100
wr2
zwei
wr5
drei
$<~wk.rexx(rmmbr)
$@for li $@{
say strip($li)
call adrTso "delete 'A540769.tmp.tst.lib("strip($li)")'", 8
$}
*** run error: adrTso rc 12 for delete 'A540769.tmp.tst.lib($<~wk.rexx(rmmbr))'
$***out 20090430 15:51:11
$***out 20090430 15:49:24
$***out 20090430 15:48:30
$***out 20090430 15:47:47
$***out 20090430 15:47:27
$***out 20090430 15:47:09
$***out 20090430 15:45:18
eins
zwei
$***out 20090430 15:45:02
$***out 20090430 15:44:35
$***out 20090430 15:44:20
$***out 20090430 15:44:09
$***out
}¢--- A540769.WK.REXX(RQ2MATCH) cre=2015-06-23 mod=2015-06-24-09.10.52 A540769 ---
$#@
$<~wk.text(anl0000P)
$<~wk.text(ans0000P)
$for i $@¢
parse value $i with cInc cTs ts cP '--' tb cr .
if cInc cTs == 'INCLUDE TABLESPACE' then $@¢
$** $$- ts cr'.'tb $i
m.an.ts = 1
m.an.tb = 1
$!
$!
$<>
$<~wk.texv(rqqtb)
$for t $@¢
parse value $t with ty oo cTb crTb .
parse var crTb cr '.' tb
if m.an.oo = 1 | m.an.tb = 1 then $@¢
$$ ty'='oo 'tb='tb $t
$$ $t
$!
$!
$#out 20150624 05:52:40
ty'='oo 'tb='tb ts CD01A1P.A041A tb OA1P.TCD041 ...
ts CD01A1P.A041A tb OA1P.TCD041 *dbof
ty'='oo 'tb='tb is CZ03A1P.ICZ432A0 tb OA1P.TCZ432A1 ix ICZ432...
is CZ03A1P.ICZ432A0 tb OA1P.TCZ432A1 ix ICZ432A0 *dbof
ty'='oo 'tb='tb is CT02A1P.ICT206A0 tb OA1P.TCT206A1 ix ICT206...
is CT02A1P.ICT206A0 tb OA1P.TCT206A1 ix ICT206A0 *dbof
ty'='oo 'tb='tb is CT02A1P.ICT206A1 tb OA1P.TCT206A1 ix ICT206...
is CT02A1P.ICT206A1 tb OA1P.TCT206A1 ix ICT206A1 *dbof
ty'='oo 'tb='tb is CD01A1P.ICD2910 tb OA1P.TCD291 ix ICD2910 ...
is CD01A1P.ICD2910 tb OA1P.TCD291 ix ICD2910 *dbof
ty'='oo 'tb='tb is CZ03A1P.ICZ432A1 tb OA1P.TCZ432A1 ix ICZ432...
is CZ03A1P.ICZ432A1 tb OA1P.TCZ432A1 ix ICZ432A1 *dbof
ty'='oo 'tb='tb is CD01A1P.ICD7710 tb OA1P.TCD771 ix ICD7710 ...
is CD01A1P.ICD7710 tb OA1P.TCD771 ix ICD7710 *dbof
ty'='oo 'tb='tb is CD01A1P.ICD1310 tb OA1P.TCD131 ix ICD1310 ...
is CD01A1P.ICD1310 tb OA1P.TCD131 ix ICD1310 *dbof
$#out 20150623 16:34:08
ty'='oo 'tb='tb ts CD03A1P.A100P tb OA1P.TCD100A1 ...
ts CD03A1P.A100P tb OA1P.TCD100A1 *dbof
ty'='oo 'tb='tb ts VP02H1P.A020H tb OA1P.TVP020H1 ...
ts VP02H1P.A020H tb OA1P.TVP020H1 *dbof
ty'='oo 'tb='tb is BE01A1P.IBE01KHB tb OA1P04.TBE010A1 ix IBE0...
is BE01A1P.IBE01KHB tb OA1P04.TBE010A1 ix IBE010A3 *dbof
ty'='oo 'tb='tb is BE01A1P.IBE019AH tb OA1P04.TBE010A1 ix IBE0...
is BE01A1P.IBE019AH tb OA1P04.TBE010A1 ix IBE010A1 *dbof
ty'='oo 'tb='tb is CZ18A1P.ICZ103E0 tb OA1P.TCZ103E1 ix ICZ103...
is CZ18A1P.ICZ103E0 tb OA1P.TCZ103E1 ix ICZ103E0 *dbof
$#out 20150623 16:33:41
ts AV15A1P.A111A tb OA1P.TAV111A1 *dbof
ts AV15A1P.A122A tb OA1P.TAV122A1 *dbof
ts AV15A1P.A135A tb OA1P.TAV135A1 *dbof
ts AV15A1P.A141A tb OA1P.TAV141A1 *dbof
ts AV15A1P.A151C tb OA1P.TAV151C1 *dbof
ts AV15A1P.A153A tb OA1P.TAV153A1 *dbof
ts AV15A1P.A158A tb OA1P.TAV158A1 *dbof
ts AV15A1P.A159A tb OA1P.TAV159A1 *dbof
ts AV15A1P.A183A tb OA1P.TAV183A1 *dbof
ts AV15A1P.A184A tb OA1P.TAV184A1 *dbof
ty'='oo 'tb='tb ts CD03A1P.A100P tb OA1P.TCD100A1 ...
ts CD03A1P.A100P tb OA1P.TCD100A1 *dbof
ts CD03A1P.A117B tb OA1P.TCD117B1 *dbof
ts CK01A1P.A020A tb OA1P.TCK020A1 *dbof
ts CT01G1P.A292A tb OA1P.TCT292G1 *dbof
ts CZ03A1P.A435A tb OA1P.TCZ435A1 *dbof
ts CZ03G1P.A238A tb OA1P.TCZ238G1 *dbof
ts CZ04A1P.A642A tb OA1P.TCZ642A1 *dbof
ts DA540769.AMFNVEXT tb A540769.TMFNVEXT *dbof
ts DB2MAPP.ELS100RP tb S100447.ELS100RP *dbof
ts DB2MAPP1.QR20808P tb S100447.QR20808P *dbof
ts DG01A1P.A121A tb OA1P.TDG121A1 *dbof
ts DG01A1P.A125A tb OA1P.TDG125A1 *dbof
ts DI05A1P.A047A tb OA1P.TDI047A1 *dbof
ts FI04A1P.A027E tb OA1P.TFI027E1 *dbof
ts FI04A1P.A027J tb OA1P.TFI027J1 *dbof
ts GE01A1P.A024A tb OA1P.TGE024A1 *dbof
ts HY01A1P.A161A tb OA1P.THY161A1 *dbof
ts HY01G1P.A193A tb OA1P.THY193G1 *dbof
ts KE01A1P.A892H tb OA1P.TKE892H2 *dbof
ts MI01A1P.A541A tb OA1P.TMI541A1 *dbof
ts NG03A1P.A990A tb OA1P.TNG990A1 *dbof
ts NI03A1P.A250A04 tb OA1P.TNI250A104A *dbof
ts NI04A1P.A300A04 tb OA1P.TNI300A104A *dbof
ts NI04A1P.A360A04 tb OA1P.TNI360A104A *dbof
ts NI10A1P.A703A tb OA1P.TNI703A1 *dbof
ts NI10A1P.A703H tb OA1P.TNI703H1 *dbof
ts NI10A1P.A704H tb OA1P.TNI704H1 *dbof
ts NI10A1P.A706H tb OA1P.TNI706H1 *dbof
ts NI10A1P.A755A tb OA1P.TNI755A1 *dbof
ts NZ01A1P.A207A tb OA1P.TNZ207A1 *dbof
ts NZ06A1P.A243A tb OA1P.TNZ243A1 *dbof
ts PW01A1P.A214A tb OA1P.TPW214A1 *dbof
ts PW01A1P.A314A tb OA1P.TPW314A1 *dbof
ts PW01A1P.A315A tb OA1P.TPW315A1 *dbof
ts RA01A1P.A020A tb OA1P.TRA020A1 *dbof
ts SA02A1P.A243A tb OA1P.TSA243A1 *dbof
ts SN01A1P.A169A tb OA1P.TSN169A1 *dbof
ts TY01A1P.A002A tb OA1P.TTY002A1 *dbof
ty'='oo 'tb='tb ts VP02H1P.A020H tb OA1P.TVP020H1 ...
ts VP02H1P.A020H tb OA1P.TVP020H1 *dbof
ts VV29A1P.VDPS404 tb VDPS2.VTRELATEDEVENT *dbof
ts WB11A1P.A213A tb OA1P.TWB213A1 *dbof
ts WI02A1P.A105H003 tb OA1P.TWI105H1003 *dbof
ts WI02A1P.A109A001 tb OA1P.TWI109A1001 *dbof
ts WI02A1P.A801A001 tb OA1P.TWI801A1001 *dbof
ts WI02A1P.A801A002 tb OA1P.TWI801A1002 *dbof
ts WKDBDOF2.DGT32K02 ty=G, 0 tables||| *dbof
ts WKDBDOF5.DGT4K06 ty=G, 0 tables||| *dbof
ts WKDBDOF7.DGT32K39 ty=G, 0 tables||| *dbof
ts WKDBDOF7.DSN32K38 ty= , 0 tables||| *dbof
ts WKDBDOF7.DSN4K09 ty= , 0 tables||| *dbof
ts WKDBDOF8.DSN32K26 ty= , 0 tables||| *dbof
ts WL01A1P.A007A01J tb OA1P.TWL007A101J *dbof
ts WL07A1P.A702A tb OA1P.TWL702A1 *dbof
ts WP02A1P.A111A01 tb OA1P.TWP111A101 *dbof
ts WP02A1P.A113A02 tb OA1P.TWP113A102 *dbof
ts XC01A1P.A200A00 tb OA1P00.TXC200A1 *dbof
ts XC01A1P.A200A01 tb OA1P01.TXC200A1 *dbof
ts XC01A1P.A200A02 tb OA1P02.TXC200A1 *dbof
ts XC01A1P.A200A03 tb OA1P03.TXC200A1 *dbof
ts XC01A1P.A200A04 tb OA1P04.TXC200A1 *dbof
ts XC01A1P.A200A05 tb OA1P05.TXC200A1 *dbof
ts XC01A1P.A200A06 tb OA1P06.TXC200A1 *dbof
ts XC01A1P.A200A07 tb OA1P07.TXC200A1 *dbof
ts XC01A1P.A200A08 tb OA1P08.TXC200A1 *dbof
ts XC01A1P.A200A09 tb OA1P09.TXC200A1 *dbof
ts XC01A1P.A501A tb OA1P.TXC501A1 *dbof
ts XC01A1P.A510A tb OA1P.TXC510A1 *dbof
ts XC01A1P.A511A tb OA1P.TXC511A1 *dbof
ts XC01A1P.A512A tb OA1P.TXC512A1 *dbof
ts XC01A1P.A513A tb OA1P.TXC513A1 *dbof
ts XC01A1P.A514A tb OA1P.TXC514A1 *dbof
ts XC01A1P.A516A tb OA1P.TXC516A1 *dbof
ts CZ03G1P.A433A tb OA1P.TCZ433G1 *dbof
ts DP06A1P.A063A tb OA1P.TDP063A1 *dbof
ts FI04A1P.A120A tb OA1P.TFI120A1 *dbof
ts NZ06A1P.A247A tb OA1P.TNZ247A1 *dbof
ts NZ06A1P.A262A tb OA1P.TNZ262A1 *dbof
is AV15A1P.IAV105A0 tb OA1P.TAV105A1 ix IAV105A0 *dbof
is AV15A1P.IAV107A0 tb OA1P.TAV107A1 ix IAV107A0 *dbof
is AV15A1P.IAV110A2 tb OA1P.TAV110A1 ix IAV110A2 *dbof
is AV15A1P.IAV111A0 tb OA1P.TAV111A1 ix IAV111A0 *dbof
is AV15A1P.IAV113A1 tb OA1P.TAV113A1 ix IAV113A1 *dbof
is AV15A1P.IAV115A1 tb OA1P.TAV115A1 ix IAV115A1 *dbof
is AV15A1P.IAV120A0 tb OA1P.TAV120A1 ix IAV120A0 *dbof
is AV15A1P.IAV123A0 tb OA1P.TAV123A1 ix IAV123A0 *dbof
is AV15A1P.IAV123A1 tb OA1P.TAV123A1 ix IAV123A1 *dbof
is AV15A1P.IAV135A0 tb OA1P.TAV135A1 ix IAV135A0 *dbof
is AV15A1P.IAV141A0 tb OA1P.TAV141A1 ix IAV141A0 *dbof
is AV15A1P.IAV151A0 tb OA1P.TAV151A1 ix IAV151A0 *dbof
is AV15A1P.IAV154A0 tb OA1P.TAV154A1 ix IAV154A0 *dbof
is AV15A1P.IAV155A0 tb OA1P.TAV155A1 ix IAV155A0 *dbof
is AV15A1P.IAV156A0 tb OA1P.TAV156A1 ix IAV156A0 *dbof
is AV15A1P.IAV157A0 tb OA1P.TAV157A1 ix IAV157A0 *dbof
is AV15A1P.IAV182A0 tb OA1P.TAV182A1 ix IAV182A0 *dbof
is AV15A1P.IAV182B0 tb OA1P.TAV182B1 ix IAV182B0 *dbof
is AV15A1P.IAV182B2 tb OA1P.TAV182B1 ix IAV182B2 *dbof
is AV15A1P.IAV185A0 tb OA1P.TAV185A1 ix IAV185A0 *dbof
is BE01A1P.IBE008A0 tb OA1P.TBE008A1 ix IBE008A0 *dbof
is BE01A1P.IBE01$S1 tb OA1P02.TBE005A1 ix IBE005A0 *dbof
ty'='oo 'tb='tb is BE01A1P.IBE01KHB tb OA1P04.TBE010A1 ix IBE0...
is BE01A1P.IBE01KHB tb OA1P04.TBE010A1 ix IBE010A3 *dbof
ty'='oo 'tb='tb is BE01A1P.IBE019AH tb OA1P04.TBE010A1 ix IBE0...
is BE01A1P.IBE019AH tb OA1P04.TBE010A1 ix IBE010A1 *dbof
is BJ01A1P.IBJ012A0 tb OA1P.TBJ012A1 ix IBJ012A0 *dbof
is CE02A1P.ICE020A1 tb OA1P.TCE020A1 ix ICE020A1 *dbof
is CE02A1P.ICE025A2 tb OA1P.TCE025A1 ix ICE025A2 *dbof
is CZ03A1P.ICZ316A0 tb OA1P.TCZ316A1 ix ICZ316A0 *dbof
is CZ11G1P.ICZ927G0 tb OA1P.TCZ927G1 ix ICZ927G0 *dbof
ty'='oo 'tb='tb is CZ18A1P.ICZ103E0 tb OA1P.TCZ103E1 ix ICZ103...
is CZ18A1P.ICZ103E0 tb OA1P.TCZ103E1 ix ICZ103E0 *dbof
is DB01A1P.IDB200A0 tb OA1P.TDB200A1 ix IDB200A0 *dbof
is DB2MAPP.IXRQ1F6O tb S100447.QR01103P ix IX_QR01103P *dbof
is DG01A1P.IDG123A1 tb OA1P.TDG123A1 ix IDG123A1 *dbof
is DG01A1P.IDG124A1 tb OA1P.TDG124A1 ix IDG124A1 *dbof
is DG02A1P.IDG970A0 tb OA1P.TDG970A0 ix IDG970A0 *dbof
is EQ03A1P.IEQ903A1 tb OA1P.TEQ903A1 ix IEQ903A1 *dbof
is EU99A1P.IEU099A0 tb OA1P.TEU099A1 ix IEU099A0 *dbof
is FI02A1P.IFI610A0 tb OA1P.TFI610A1 ix IFI610A0 *dbof
is FI04A1P.IFI027B1 tb OA1P.TFI027B1 ix IFI027B1 *dbof
is FZ01A1P.IFZ021A2 tb OA1P.TFZ021A1 ix IFZ021A2 *dbof
is GM01A1P.IGM100A4 tb OA1P.TGM100A1 ix IGM100A4 *dbof
is KE01A1P.IKE895H2 tb OA1P.TKE895H2 ix IKE895H2 *dbof
is LW02A1P.ILW211A0 tb OA1P.TLW211A1 ix ILW211A0 *dbof
is MF01A1P.IMF11ZJ2 tb OA1P.TMF150H1 ix IMF150H10 *dbof
is MI01A1P.IMI520A0 tb OA1P.TMI520A1 ix IMI520A0 *dbof
is NI02A1P.INI350A1 tb OA1P.TNI350A103A ix INI350A103A *dbof
is NI03A1P.INI200A1 tb OA1P.TNI200A103A ix INI200A103A *dbof
is NI03A1P.INI21TX8 tb OA1P.TNI250A104A ix INI250A104A *dbof
is NI03A1P.INI216K2 tb OA1P.TNI250A104A ix INI250A204A *dbof
is NI04A1P.INI31G36 tb OA1P.TNI300H104A ix INI300H104A *dbof
is NI04A1P.INI31JK0 tb OA1P.TNI301A104A ix INI301A104A *dbof
is NI05A1P.INI200I1 tb OA1P.TNI200I101A ix INI200I101A *dbof
is NI06A1P.INI21N5F tb OA1P.TNI200K102A ix INI200K102A *dbof
is NI10A1P.INI703H0 tb OA1P.TNI703H1 ix INI703H0 *dbof
is NZ01A1P.INZ107A0 tb OA1P.TNZ107A1 ix INZ107A0 *dbof
is NZ06A1P.INZ241A1 tb OA1P.TNZ241A1 ix INZ241A1 *dbof
is NZ06A1P.INZ260A1 tb OA1P.TNZ260A1 ix INZ260A1 *dbof
is PC13A1P.IPC120A1 tb OA1P03.TPC120A1 ix IPC120A1 *dbof
is PC22A1P.IPC122A1 tb OA1P12.TPC122A1 ix IPC122A1 *dbof
is PW01A1P.IPW203A1 tb OA1P.TPW203A1 ix IPW203A1 *dbof
is PW01A1P.IPW310A4 tb OA1P.TPW310A1 ix IPW310A4 *dbof
is PW01A1P.IPW321A0 tb OA1P.TPW321A1 ix IPW321A0 *dbof
is SN01A1P.ISN169A1 tb OA1P.TSN169A1 ix ISN169A1 *dbof
is SN01A1P.ISN202A0 tb OA1P.TSN202A1 ix ISN202A0 *dbof
is SV02B1P.ISV021B3 tb OA1P.TSV021B1 ix ISV021B3 *dbof
is VV20A1P.IVV719A2 tb OA1P.TVV719A1 ix IVV719A2 *dbof
is VV20A1P.IVV719A3 tb OA1P.TVV719A1 ix IVV719A3 *dbof
is WB11A1P.IWB70413 tb OA1P.TWB704A1 ix IWB70413 *dbof
is WI02A1P.IWI801A2 tb OA1P.TWI801A1001 ix IWI801A2001 *dbof
is WI02A1P.IWI81CCW tb OA1P.TWI801A1003 ix IWI801A1003 *dbof
is WL01A1P.IWL014UG tb OA1P.TWL007A103J ix IWL007A003J *dbof
is WL07A1P.IWL704A0 tb OA1P.TWL704A1 ix IWL704A0 *dbof
is WP04A1P.IWP31BXG tb OA1P.TWP301A129 ix IWP301A229 *dbof
is XC01A1P.IXC21#LO tb OA1P07.TXC200A1 ix IXC200A10 *dbof
is XC01A1P.IXC21ANQ tb OA1P03.TXC200A1 ix IXC200A10 *dbof
is XC01A1P.IXC21NH4 tb OA1P05.TXC200A1 ix IXC200A10 *dbof
is XC01A1P.IXC21SX6 tb OA1P09.TXC200A1 ix IXC200A10 *dbof
is XC01A1P.IXC211CP tb OA1P06.TXC200A1 ix IXC200A10 *dbof
is XC01A1P.IXC500A1 tb OA1P.TXC500A1 ix IXC500A1 *dbof
is XC01A1P.IXC514A0 tb OA1P.TXC514A1 ix IXC514A0 *dbof
is AV15A1P.IAV104A0 tb OA1P.TAV104A1 ix IAV104A0 *dbof
is BE01A1P.IBE003A0 tb OA1P.TBE003A1 ix IBE003A0 *dbof
is CZ03A1P.ICZ443A0 tb OA1P.TCZ443A1 ix ICZ443A0 *dbof
is DB2MAPP1.IXRQ1OC6 tb S100447.QR20810P ix IX_QR20810P *dbof
is DP02A1P.IDP021A4 tb OA1P.TDP021A1 ix IDP021A4 *dbof
is KE01A1P.IKE858H2 tb OA1P.TKE858H1 ix IKE858H2 *dbof
is NZ06A1P.INZ262A1 tb OA1P.TNZ262A1 ix INZ262A1 *dbof
is SAMT2.INDRSRGM tb SAMRELT.RMS ix IND_SRGMEM *dbof
is VV24A1P.VTXI11Z1 tb VDPS2.VTINSTRUMENT ix VTXINSTRUMENT1 *dbof
$#out 20150623 16:15:00
ts=CD03A1P.A100P tb=TCD100A1 ts CD03A1P.A100P tb OA1P.TCD10...
ts=VP02H1P.A020H tb=TVP020H1 ts VP02H1P.A020H tb OA1P.TVP02...
is=BE01A1P.IBE01KHB tb=TBE010A1 is BE01A1P.IBE01KHB tb OA1P04....
is=BE01A1P.IBE019AH tb=TBE010A1 is BE01A1P.IBE019AH tb OA1P04....
is=CZ18A1P.ICZ103E0 tb=TCZ103E1 is CZ18A1P.ICZ103E0 tb OA1P.TC...
$#out 20150623 16:13:02
BE01A1P.A010A01 OA1P01.TBE010A1 INCLUDE TABLESPACE BE01A1P.A010A01 PARTLEV...
BE01A1P.A010A02 OA1P02.TBE010A1 INCLUDE TABLESPACE BE01A1P.A010A02 PARTLEV...
BE01A1P.A010A03 OA1P03.TBE010A1 INCLUDE TABLESPACE BE01A1P.A010A03 PARTLEV...
BE01A1P.A010A04 OA1P04.TBE010A1 INCLUDE TABLESPACE BE01A1P.A010A04 PARTLEV...
RA01A1P.A001A .TRA001A1 INCLUDE TABLESPACE RA01A1P.A001A PARTLEVEL --T...
RA01A1P.A060A .TRA060A1 INCLUDE TABLESPACE RA01A1P.A060A PARTLEVEL --T...
RA01A1P.A080A .TRA080A1 INCLUDE TABLESPACE RA01A1P.A080A PARTLEVEL --T...
RA01A1P.A081A .TRA081A1 INCLUDE TABLESPACE RA01A1P.A081A PARTLEVEL --T...
RA01A1P.A082A .TRA082A1 INCLUDE TABLESPACE RA01A1P.A082A PARTLEVEL --T...
RA01A1P.A083A .TRA083A1 INCLUDE TABLESPACE RA01A1P.A083A PARTLEVEL --T...
BS01A1P.A003A .TBS003A1 INCLUDE TABLESPACE BS01A1P.A003A PARTLEVEL --T...
CD01A1P.A031A .TCD031 INCLUDE TABLESPACE CD01A1P.A031A PARTLEVEL --TCD031
CD01A1P.A041A .TCD041 INCLUDE TABLESPACE CD01A1P.A041A PARTLEVEL --TCD041
CD01A1P.A061A .TCD061 INCLUDE TABLESPACE CD01A1P.A061A PARTLEVEL --TCD061
CD01A1P.A091A .TCD091 INCLUDE TABLESPACE CD01A1P.A091A PARTLEVEL --TCD091
CD01A1P.A111A .TCD111 INCLUDE TABLESPACE CD01A1P.A111A PARTLEVEL --TCD111
CD01A1P.A131A .TCD131 INCLUDE TABLESPACE CD01A1P.A131A PARTLEVEL --TCD131
CD01A1P.A231A .TCD231 INCLUDE TABLESPACE CD01A1P.A231A PARTLEVEL --TCD231
CD01A1P.A251A .TCD251 INCLUDE TABLESPACE CD01A1P.A251A PARTLEVEL --TCD251
CD01A1P.A291A .TCD291 INCLUDE TABLESPACE CD01A1P.A291A PARTLEVEL --TCD291
CD01A1P.A301A .TCD301 INCLUDE TABLESPACE CD01A1P.A301A PARTLEVEL --TCD301
CD01A1P.A341A .TCD341 INCLUDE TABLESPACE CD01A1P.A341A PARTLEVEL --TCD341
CD01A1P.A391A .TCD391 INCLUDE TABLESPACE CD01A1P.A391A PARTLEVEL --TCD391
CD01A1P.A451A .TCD451 INCLUDE TABLESPACE CD01A1P.A451A PARTLEVEL --TCD451
CD01A1P.A771A .TCD771 INCLUDE TABLESPACE CD01A1P.A771A PARTLEVEL --TCD771
CD03A1P.A100P .TCD100A1 INCLUDE TABLESPACE CD03A1P.A100P PARTLEVEL --T...
CD03A1P.A100B .TCD100B1 INCLUDE TABLESPACE CD03A1P.A100B PARTLEVEL --T...
CD03A1P.A140A .TCD140A1 INCLUDE TABLESPACE CD03A1P.A140A PARTLEVEL --T...
CD03A1P.A140H .TCD140H1 INCLUDE TABLESPACE CD03A1P.A140H PARTLEVEL --T...
CD03A1P.A181A .TCD181A1 INCLUDE TABLESPACE CD03A1P.A181A PARTLEVEL --T...
CD03A1P.A181H .TCD181H1 INCLUDE TABLESPACE CD03A1P.A181H PARTLEVEL --T...
CD03A1P.A182A .TCD182A1 INCLUDE TABLESPACE CD03A1P.A182A PARTLEVEL --T...
CD03A1P.A182H .TCD182H1 INCLUDE TABLESPACE CD03A1P.A182H PARTLEVEL --T...
CD01A1P.A306A .TCD306A1 INCLUDE TABLESPACE CD01A1P.A306A PARTLEVEL --T...
CD03A1P.A380A .TCD380A1 INCLUDE TABLESPACE CD03A1P.A380A PARTLEVEL --T...
CD02A1P.A470A .TCD470A1 INCLUDE TABLESPACE CD02A1P.A470A PARTLEVEL --T...
CD02A1P.A616A .TCD616A1 INCLUDE TABLESPACE CD02A1P.A616A PARTLEVEL --T...
CD02A1P.A617A .TCD617A1 INCLUDE TABLESPACE CD02A1P.A617A PARTLEVEL --T...
CD02A1P.A619A .TCD619A1 INCLUDE TABLESPACE CD02A1P.A619A PARTLEVEL --T...
CD03A1P.A630A .TCD630A1 INCLUDE TABLESPACE CD03A1P.A630A PARTLEVEL --T...
CD03A1P.A633A .TCD633A1 INCLUDE TABLESPACE CD03A1P.A633A PARTLEVEL --T...
CD03A1P.A634A .TCD634A1 INCLUDE TABLESPACE CD03A1P.A634A PARTLEVEL --T...
CD03A1P.A635A .TCD635A1 INCLUDE TABLESPACE CD03A1P.A635A PARTLEVEL --T...
CK01A1P.A025A .TCK025A1 INCLUDE TABLESPACE CK01A1P.A025A PARTLEVEL --T...
CK01A1P.A030A .TCK030A1 INCLUDE TABLESPACE CK01A1P.A030A PARTLEVEL --T...
CK01A1P.A031A .TCK031A1 INCLUDE TABLESPACE CK01A1P.A031A PARTLEVEL --T...
CK01A1P.A078A .TCK078A1 INCLUDE TABLESPACE CK01A1P.A078A PARTLEVEL --T...
CK01A1P.A083A .TCK083A1 INCLUDE TABLESPACE CK01A1P.A083A PARTLEVEL --T...
CK01A1P.A085A .TCK085A1 INCLUDE TABLESPACE CK01A1P.A085A PARTLEVEL --T...
CT02A1P.A152A .TCT152A1 INCLUDE TABLESPACE CT02A1P.A152A PARTLEVEL --T...
CT01G1P.A152A .TCT152G1 INCLUDE TABLESPACE CT01G1P.A152A PARTLEVEL --T...
CT02A1P.A153A .TCT153A1 INCLUDE TABLESPACE CT02A1P.A153A PARTLEVEL --T...
CT01G1P.A153A .TCT153G1 INCLUDE TABLESPACE CT01G1P.A153A PARTLEVEL --T...
CT02A1P.A202A .TCT202A1 INCLUDE TABLESPACE CT02A1P.A202A PARTLEVEL --T...
CT01G1P.A202A .TCT202G1 INCLUDE TABLESPACE CT01G1P.A202A PARTLEVEL --T...
CT02A1P.A203A .TCT203A1 INCLUDE TABLESPACE CT02A1P.A203A PARTLEVEL --T...
CT01G1P.A203A .TCT203G1 INCLUDE TABLESPACE CT01G1P.A203A PARTLEVEL --T...
CT02A1P.A206A .TCT206A1 INCLUDE TABLESPACE CT02A1P.A206A PARTLEVEL --T...
CT01G1P.A206A .TCT206G1 INCLUDE TABLESPACE CT01G1P.A206A PARTLEVEL --T...
CT02A1P.A217A .TCT217A1 INCLUDE TABLESPACE CT02A1P.A217A PARTLEVEL --T...
CT01G1P.A217A .TCT217G1 INCLUDE TABLESPACE CT01G1P.A217A PARTLEVEL --T...
CT02A1P.A251A .TCT251A1 INCLUDE TABLESPACE CT02A1P.A251A PARTLEVEL --T...
CT01G1P.A251A .TCT251G1 INCLUDE TABLESPACE CT01G1P.A251A PARTLEVEL --T...
CT02A1P.A253A .TCT253A1 INCLUDE TABLESPACE CT02A1P.A253A PARTLEVEL --T...
CT01G1P.A253A .TCT253G1 INCLUDE TABLESPACE CT01G1P.A253A PARTLEVEL --T...
CT02A1P.A254A .TCT254A1 INCLUDE TABLESPACE CT02A1P.A254A PARTLEVEL --T...
CT01G1P.A254A .TCT254G1 INCLUDE TABLESPACE CT01G1P.A254A PARTLEVEL --T...
CT02A1P.A256A .TCT256A1 INCLUDE TABLESPACE CT02A1P.A256A PARTLEVEL --T...
CT01G1P.A256A .TCT256G1 INCLUDE TABLESPACE CT01G1P.A256A PARTLEVEL --T...
CT02A1P.A257A .TCT257A1 INCLUDE TABLESPACE CT02A1P.A257A PARTLEVEL --T...
CT01G1P.A257A .TCT257G1 INCLUDE TABLESPACE CT01G1P.A257A PARTLEVEL --T...
CT02A1P.A258A .TCT258A1 INCLUDE TABLESPACE CT02A1P.A258A PARTLEVEL --T...
CT01G1P.A258A .TCT258G1 INCLUDE TABLESPACE CT01G1P.A258A PARTLEVEL --T...
CT02A1P.A259A .TCT259A1 INCLUDE TABLESPACE CT02A1P.A259A PARTLEVEL --T...
CT01G1P.A259A .TCT259G1 INCLUDE TABLESPACE CT01G1P.A259A PARTLEVEL --T...
CT02A1P.A261A .TCT261A1 INCLUDE TABLESPACE CT02A1P.A261A PARTLEVEL --T...
CT01G1P.A261A .TCT261G1 INCLUDE TABLESPACE CT01G1P.A261A PARTLEVEL --T...
CT02A1P.A301A .TCT301A1 INCLUDE TABLESPACE CT02A1P.A301A PARTLEVEL --T...
CT01G1P.A301A .TCT301G1 INCLUDE TABLESPACE CT01G1P.A301A PARTLEVEL --T...
CT02A1P.A305A .TCT305A1 INCLUDE TABLESPACE CT02A1P.A305A PARTLEVEL --T...
CT01G1P.A305A .TCT305G1 INCLUDE TABLESPACE CT01G1P.A305A PARTLEVEL --T...
CT02A1P.A306A .TCT306A1 INCLUDE TABLESPACE CT02A1P.A306A PARTLEVEL --T...
CT01G1P.A306A .TCT306G1 INCLUDE TABLESPACE CT01G1P.A306A PARTLEVEL --T...
CT02A1P.A308A .TCT308A1 INCLUDE TABLESPACE CT02A1P.A308A PARTLEVEL --T...
CT01G1P.A308A .TCT308G1 INCLUDE TABLESPACE CT01G1P.A308A PARTLEVEL --T...
CT02A1P.A309A .TCT309A1 INCLUDE TABLESPACE CT02A1P.A309A PARTLEVEL --T...
CT01G1P.A309A .TCT309G1 INCLUDE TABLESPACE CT01G1P.A309A PARTLEVEL --T...
CT02A1P.A353A .TCT353A1 INCLUDE TABLESPACE CT02A1P.A353A PARTLEVEL --T...
CT01G1P.A353A .TCT353G1 INCLUDE TABLESPACE CT01G1P.A353A PARTLEVEL --T...
CT02A1P.A356A .TCT356A1 INCLUDE TABLESPACE CT02A1P.A356A PARTLEVEL --T...
CT01G1P.A356A .TCT356G1 INCLUDE TABLESPACE CT01G1P.A356A PARTLEVEL --T...
CT02A1P.A400A .TCT400A1 INCLUDE TABLESPACE CT02A1P.A400A PARTLEVEL --T...
CT01G1P.A400A .TCT400G1 INCLUDE TABLESPACE CT01G1P.A400A PARTLEVEL --T...
CY02A1P.A056A .TCY056A1 INCLUDE TABLESPACE CY02A1P.A056A PARTLEVEL --T...
CZ08A1P.A025A .TCZ025A1 INCLUDE TABLESPACE CZ08A1P.A025A PARTLEVEL --T...
CZ18A1P.A025A .TCZ025E1 INCLUDE TABLESPACE CZ18A1P.A025A PARTLEVEL --T...
CZ08G1P.A025A .TCZ025G1 INCLUDE TABLESPACE CZ08G1P.A025A PARTLEVEL --T...
CZ08A1P.A100A .TCZ100A1 INCLUDE TABLESPACE CZ08A1P.A100A PARTLEVEL --T...
CZ18A1P.A100A .TCZ100E1 INCLUDE TABLESPACE CZ18A1P.A100A PARTLEVEL --T...
CZ08G1P.A100A .TCZ100G1 INCLUDE TABLESPACE CZ08G1P.A100A PARTLEVEL --T...
CZ08A1P.A101A .TCZ101A1 INCLUDE TABLESPACE CZ08A1P.A101A PARTLEVEL --T...
CZ18A1P.A101A .TCZ101E1 INCLUDE TABLESPACE CZ18A1P.A101A PARTLEVEL --T...
CZ08G1P.A101A .TCZ101G1 INCLUDE TABLESPACE CZ08G1P.A101A PARTLEVEL --T...
CZ08A1P.A103A .TCZ103A1 INCLUDE TABLESPACE CZ08A1P.A103A PARTLEVEL --T...
CZ18A1P.A103A .TCZ103E1 INCLUDE TABLESPACE CZ18A1P.A103A PARTLEVEL --T...
CZ08G1P.A103A .TCZ103G1 INCLUDE TABLESPACE CZ08G1P.A103A PARTLEVEL --T...
CZ08A1P.A106A .TCZ106A1 INCLUDE TABLESPACE CZ08A1P.A106A PARTLEVEL --T...
CZ18A1P.A106A .TCZ106E1 INCLUDE TABLESPACE CZ18A1P.A106A PARTLEVEL --T...
CZ08G1P.A106A .TCZ106G1 INCLUDE TABLESPACE CZ08G1P.A106A PARTLEVEL --T...
CZ07A1P.A191A .TCZ191A1 INCLUDE TABLESPACE CZ07A1P.A191A PARTLEVEL --T...
CZ07G1P.A191A .TCZ191G1 INCLUDE TABLESPACE CZ07G1P.A191A PARTLEVEL --T...
CZ03A1P.A235A .TCZ235A1 INCLUDE TABLESPACE CZ03A1P.A235A PARTLEVEL --T...
CZ03G1P.A235A .TCZ235G1 INCLUDE TABLESPACE CZ03G1P.A235A PARTLEVEL --T...
CZ03A1P.A236A .TCZ236A1 INCLUDE TABLESPACE CZ03A1P.A236A PARTLEVEL --T...
CZ03G1P.A236A .TCZ236G1 INCLUDE TABLESPACE CZ03G1P.A236A PARTLEVEL --T...
CZ14A1P.A250A .TCZ250A1 INCLUDE TABLESPACE CZ14A1P.A250A PARTLEVEL --T...
CZ14G1P.A250A .TCZ250G1 INCLUDE TABLESPACE CZ14G1P.A250A PARTLEVEL --T...
CZ14A1P.A251A .TCZ251A1 INCLUDE TABLESPACE CZ14A1P.A251A PARTLEVEL --T...
CZ14G1P.A251A .TCZ251G1 INCLUDE TABLESPACE CZ14G1P.A251A PARTLEVEL --T...
CZ03A1P.A300A .TCZ300A1 INCLUDE TABLESPACE CZ03A1P.A300A PARTLEVEL --T...
CZ03A1P.A313A .TCZ313A1 INCLUDE TABLESPACE CZ03A1P.A313A PARTLEVEL --T...
CZ03G1P.A313A .TCZ313G1 INCLUDE TABLESPACE CZ03G1P.A313A PARTLEVEL --T...
CZ03A1P.A315A .TCZ315A1 INCLUDE TABLESPACE CZ03A1P.A315A PARTLEVEL --T...
CZ03G1P.A315A .TCZ315G1 INCLUDE TABLESPACE CZ03G1P.A315A PARTLEVEL --T...
CZ03A1P.A319A .TCZ319A1 INCLUDE TABLESPACE CZ03A1P.A319A PARTLEVEL --T...
CZ03G1P.A319A .TCZ319G1 INCLUDE TABLESPACE CZ03G1P.A319A PARTLEVEL --T...
CZ03A1P.A321A .TCZ321A1 INCLUDE TABLESPACE CZ03A1P.A321A PARTLEVEL --T...
CZ03G1P.A321A .TCZ321G1 INCLUDE TABLESPACE CZ03G1P.A321A PARTLEVEL --T...
CZ03A1P.A323A .TCZ323A1 INCLUDE TABLESPACE CZ03A1P.A323A PARTLEVEL --T...
CZ03G1P.A323A .TCZ323G1 INCLUDE TABLESPACE CZ03G1P.A323A PARTLEVEL --T...
CZ03A1P.A327A .TCZ327A1 INCLUDE TABLESPACE CZ03A1P.A327A PARTLEVEL --T...
CZ03G1P.A327A .TCZ327G1 INCLUDE TABLESPACE CZ03G1P.A327A PARTLEVEL --T...
CZ03A1P.A331A .TCZ331A1 INCLUDE TABLESPACE CZ03A1P.A331A PARTLEVEL --T...
CZ03G1P.A331A .TCZ331G1 INCLUDE TABLESPACE CZ03G1P.A331A PARTLEVEL --T...
CZ03A1P.A340A .TCZ340A1 INCLUDE TABLESPACE CZ03A1P.A340A PARTLEVEL --T...
CZ03A1P.A384A .TCZ384A1 INCLUDE TABLESPACE CZ03A1P.A384A PARTLEVEL --T...
CZ03G1P.A384A .TCZ384G1 INCLUDE TABLESPACE CZ03G1P.A384A PARTLEVEL --T...
CZ03A1P.A386A .TCZ386A1 INCLUDE TABLESPACE CZ03A1P.A386A PARTLEVEL --T...
CZ03G1P.A386A .TCZ386G1 INCLUDE TABLESPACE CZ03G1P.A386A PARTLEVEL --T...
CZ03A1P.A421A .TCZ421A1 INCLUDE TABLESPACE CZ03A1P.A421A PARTLEVEL --T...
CZ03G1P.A421A .TCZ421G1 INCLUDE TABLESPACE CZ03G1P.A421A PARTLEVEL --T...
CZ03A1P.A428A .TCZ428A1 INCLUDE TABLESPACE CZ03A1P.A428A PARTLEVEL --T...
CZ03G1P.A428A .TCZ428G1 INCLUDE TABLESPACE CZ03G1P.A428A PARTLEVEL --T...
CZ03A1P.A429A .TCZ429A1 INCLUDE TABLESPACE CZ03A1P.A429A PARTLEVEL --T...
CZ03G1P.A429A .TCZ429G1 INCLUDE TABLESPACE CZ03G1P.A429A PARTLEVEL --T...
CZ03A1P.A432A .TCZ432A1 INCLUDE TABLESPACE CZ03A1P.A432A PARTLEVEL --T...
CZ03A1P.A433A .TCZ433A1 INCLUDE TABLESPACE CZ03A1P.A433A PARTLEVEL --T...
CZ04A1P.A500A .TCZ500A1 INCLUDE TABLESPACE CZ04A1P.A500A PARTLEVEL --T...
CZ04A1P.A513A .TCZ513A1 INCLUDE TABLESPACE CZ04A1P.A513A PARTLEVEL --T...
CZ04A1P.A515A .TCZ515A1 INCLUDE TABLESPACE CZ04A1P.A515A PARTLEVEL --T...
CZ04A1P.A519A .TCZ519A1 INCLUDE TABLESPACE CZ04A1P.A519A PARTLEVEL --T...
CZ04A1P.A521A .TCZ521A1 INCLUDE TABLESPACE CZ04A1P.A521A PARTLEVEL --T...
CZ04A1P.A584A .TCZ584A1 INCLUDE TABLESPACE CZ04A1P.A584A PARTLEVEL --T...
CZ04A1P.A621A .TCZ621A1 INCLUDE TABLESPACE CZ04A1P.A621A PARTLEVEL --T...
CZ13A1P.A707A .TCZ707A1 INCLUDE TABLESPACE CZ13A1P.A707A PARTLEVEL --T...
CZ13A1P.A708A .TCZ708A1 INCLUDE TABLESPACE CZ13A1P.A708A PARTLEVEL --T...
DB01A1P.A201A .TDB201A1 INCLUDE TABLESPACE DB01A1P.A201A PARTLEVEL --T...
DE02A1P.A023A .TDE023A1 INCLUDE TABLESPACE DE02A1P.A023A PARTLEVEL --T...
ED02A1P.A023A .TED023A1 INCLUDE TABLESPACE ED02A1P.A023A PARTLEVEL --T...
FC01A1P.A001A .TFC001A0 INCLUDE TABLESPACE FC01A1P.A001A PARTLEVEL --T...
KC01A1P.A001A .TKC001A1 INCLUDE TABLESPACE KC01A1P.A001A PARTLEVEL --T...
KC01A1P.A002A .TKC002A1 INCLUDE TABLESPACE KC01A1P.A002A PARTLEVEL --T...
KC01A1P.A003A .TKC003A1 INCLUDE TABLESPACE KC01A1P.A003A PARTLEVEL --T...
KC01A1P.A010A .TKC010A1 INCLUDE TABLESPACE KC01A1P.A010A PARTLEVEL --T...
MF03A1P.A009A .TMF009A1 INCLUDE TABLESPACE MF03A1P.A009A PARTLEVEL --T...
MF01A1P.A101A .TMF101A1 INCLUDE TABLESPACE MF01A1P.A101A PARTLEVEL --T...
MF01A1P.A103A .TMF103A1 INCLUDE TABLESPACE MF01A1P.A103A PARTLEVEL --T...
MF01A1P.A104A .TMF104A1 INCLUDE TABLESPACE MF01A1P.A104A PARTLEVEL --T...
NI02A1P.A100A .TNI100A101A INCLUDE TABLESPACE NI02A1P.A100A PARTLEVEL ...
NI02A1P.A609A .TNI609A101A INCLUDE TABLESPACE NI02A1P.A609A PARTLEVEL ...
NZ03A1P.A021A .TNZ021A1 INCLUDE TABLESPACE NZ03A1P.A021A PARTLEVEL --T...
NZ02A1P.A150A .TNZ150A1 INCLUDE TABLESPACE NZ02A1P.A150A PARTLEVEL --T...
NZ02A1P.A151A .TNZ151A1 INCLUDE TABLESPACE NZ02A1P.A151A PARTLEVEL --T...
NZ02A1P.A152A .TNZ152A1 INCLUDE TABLESPACE NZ02A1P.A152A PARTLEVEL --T...
NZ01A1P.A202A .TNZ202A1 INCLUDE TABLESPACE NZ01A1P.A202A PARTLEVEL --T...
NZ01A1P.A204A .TNZ204A1 INCLUDE TABLESPACE NZ01A1P.A204A PARTLEVEL --T...
NZ01A1P.A209A .TNZ209A1 INCLUDE TABLESPACE NZ01A1P.A209A PARTLEVEL --T...
NZ01A1P.A212A .TNZ212A1 INCLUDE TABLESPACE NZ01A1P.A212A PARTLEVEL --T...
NZ01A1P.A252A .TNZ252A1 INCLUDE TABLESPACE NZ01A1P.A252A PARTLEVEL --T...
NZ01A1P.A258A .TNZ258A1 INCLUDE TABLESPACE NZ01A1P.A258A PARTLEVEL --T...
RM01A1P.A003A .TRM003A1 INCLUDE TABLESPACE RM01A1P.A003A PARTLEVEL --T...
RM01A1P.A010A .TRM010A1 INCLUDE TABLESPACE RM01A1P.A010A PARTLEVEL --T...
RM01A1P.A020A .TRM020A1 INCLUDE TABLESPACE RM01A1P.A020A PARTLEVEL --T...
RM01A1P.A021A .TRM021A1 INCLUDE TABLESPACE RM01A1P.A021A PARTLEVEL --T...
RV01A1P.A100A .TRV100A1 INCLUDE TABLESPACE RV01A1P.A100A PARTLEVEL --T...
RV01A1P.A110A .TRV110A1 INCLUDE TABLESPACE RV01A1P.A110A PARTLEVEL --T...
RV01A1P.A120A .TRV120A1 INCLUDE TABLESPACE RV01A1P.A120A PARTLEVEL --T...
RV01A1P.A130A .TRV130A1 INCLUDE TABLESPACE RV01A1P.A130A PARTLEVEL --T...
RV01A1P.A140A .TRV140A1 INCLUDE TABLESPACE RV01A1P.A140A PARTLEVEL --T...
RV01A1P.A221A .TRV221A1 INCLUDE TABLESPACE RV01A1P.A221A PARTLEVEL --T...
RV01A1P.A301A .TRV301A1 INCLUDE TABLESPACE RV01A1P.A301A PARTLEVEL --T...
RV01A1P.A431A .TRV431A1 INCLUDE TABLESPACE RV01A1P.A431A PARTLEVEL --T...
RV01A1P.A451A .TRV451A1 INCLUDE TABLESPACE RV01A1P.A451A PARTLEVEL --T...
RV01A1P.A501A .TRV501A1 INCLUDE TABLESPACE RV01A1P.A501A PARTLEVEL --T...
RV01A1P.A600A .TRV600A1 INCLUDE TABLESPACE RV01A1P.A600A PARTLEVEL --T...
UU02A1P.A130A .TUU130A2 INCLUDE TABLESPACE UU02A1P.A130A PARTLEVEL --T...
VD01A1P.A002A .TVD002A1 INCLUDE TABLESPACE VD01A1P.A002A PARTLEVEL --T...
VP03A1P.A009A .TVP009A1 INCLUDE TABLESPACE VP03A1P.A009A PARTLEVEL --T...
VP02A1P.A020A .TVP020A1 INCLUDE TABLESPACE VP02A1P.A020A PARTLEVEL --T...
VP02H1P.A020H .TVP020H1 INCLUDE TABLESPACE VP02H1P.A020H PARTLEVEL --T...
VP02A1P.A023A .TVP023A1 INCLUDE TABLESPACE VP02A1P.A023A PARTLEVEL --T...
VP02H1P.A023H .TVP023H1 INCLUDE TABLESPACE VP02H1P.A023H PARTLEVEL --T...
VP02A1P.A025A .TVP025A1 INCLUDE TABLESPACE VP02A1P.A025A PARTLEVEL --T...
VP02H1P.A025H .TVP025H1 INCLUDE TABLESPACE VP02H1P.A025H PARTLEVEL --T...
VP02A1P.A036A .TVP036A1 INCLUDE TABLESPACE VP02A1P.A036A PARTLEVEL --T...
VP02H1P.A036H .TVP036H1 INCLUDE TABLESPACE VP02H1P.A036H PARTLEVEL --T...
WF01A1P.A003A .TWF003A1 INCLUDE TABLESPACE WF01A1P.A003A PARTLEVEL --T...
WF01A1P.A032A .TWF032A1 INCLUDE TABLESPACE WF01A1P.A032A PARTLEVEL --T...
WF01A1P.A034A .TWF034A1 INCLUDE TABLESPACE WF01A1P.A034A PARTLEVEL --T...
WF01A1P.A035A .TWF035A1 INCLUDE TABLESPACE WF01A1P.A035A PARTLEVEL --T...
WF01A1P.A051A .TWF051A1 INCLUDE TABLESPACE WF01A1P.A051A PARTLEVEL --T...
WF01A1P.A052A .TWF052A1 INCLUDE TABLESPACE WF01A1P.A052A PARTLEVEL --T...
WF01A1P.A073A .TWF073A1 INCLUDE TABLESPACE WF01A1P.A073A PARTLEVEL --T...
WF01A1P.A076A .TWF076A1 INCLUDE TABLESPACE WF01A1P.A076A PARTLEVEL --T...
WF01A1P.A080A .TWF080A1 INCLUDE TABLESPACE WF01A1P.A080A PARTLEVEL --T...
WF01A1P.A082A .TWF082A1 INCLUDE TABLESPACE WF01A1P.A082A PARTLEVEL --T...
WF01A1P.A083A .TWF083A1 INCLUDE TABLESPACE WF01A1P.A083A PARTLEVEL --T...
WF01A1P.A086A .TWF086A1 INCLUDE TABLESPACE WF01A1P.A086A PARTLEVEL --T...
WF01A1P.A088A .TWF088A1 INCLUDE TABLESPACE WF01A1P.A088A PARTLEVEL --T...
WF01A1P.A090A .TWF090A1 INCLUDE TABLESPACE WF01A1P.A090A PARTLEVEL --T...
WF01A1P.A091A .TWF091A1 INCLUDE TABLESPACE WF01A1P.A091A PARTLEVEL --T...
WG01A1P.A100A .TWG100A1 INCLUDE TABLESPACE WG01A1P.A100A PARTLEVEL --T...
WG01A1P.A101A .TWG101A1 INCLUDE TABLESPACE WG01A1P.A101A PARTLEVEL --T...
WG01A1P.A200A .TWG200A1 INCLUDE TABLESPACE WG01A1P.A200A PARTLEVEL --T...
WG01A1P.A400A .TWG400A1 INCLUDE TABLESPACE WG01A1P.A400A PARTLEVEL --T...
WG01A1P.A410A .TWG410A1 INCLUDE TABLESPACE WG01A1P.A410A PARTLEVEL --T...
WL09A1P.A901A .TWL901A1 INCLUDE TABLESPACE WL09A1P.A901A PARTLEVEL --T...
WM01A1P.A005A .TWM005A1 INCLUDE TABLESPACE WM01A1P.A005A PARTLEVEL --T...
WR01A1P.A002A .TWR002A1 INCLUDE TABLESPACE WR01A1P.A002A PARTLEVEL --T...
ts=CD03A1P.A100P tb=TCD100A1 ts CD03A1P.A100P tb OA1P.TCD10...
ts=VP02H1P.A020H tb=TVP020H1 ts VP02H1P.A020H tb OA1P.TVP02...
is=BE01A1P.IBE01KHB tb=TBE010A1 is BE01A1P.IBE01KHB tb OA1P04....
is=BE01A1P.IBE019AH tb=TBE010A1 is BE01A1P.IBE019AH tb OA1P04....
is=CZ18A1P.ICZ103E0 tb=TCZ103E1 is CZ18A1P.ICZ103E0 tb OA1P.TC...
$#out 20150623 16:06:00
BE01A1P.A010A01 OA1P01.TBE010A1 INCLUDE TABLESPACE BE01A1P.A010A01 PARTLEV...
BE01A1P.A010A02 OA1P02.TBE010A1 INCLUDE TABLESPACE BE01A1P.A010A02 PARTLEV...
BE01A1P.A010A03 OA1P03.TBE010A1 INCLUDE TABLESPACE BE01A1P.A010A03 PARTLEV...
BE01A1P.A010A04 OA1P04.TBE010A1 INCLUDE TABLESPACE BE01A1P.A010A04 PARTLEV...
RA01A1P.A001A .TRA001A1 INCLUDE TABLESPACE RA01A1P.A001A PARTLEVEL --T...
RA01A1P.A060A .TRA060A1 INCLUDE TABLESPACE RA01A1P.A060A PARTLEVEL --T...
RA01A1P.A080A .TRA080A1 INCLUDE TABLESPACE RA01A1P.A080A PARTLEVEL --T...
RA01A1P.A081A .TRA081A1 INCLUDE TABLESPACE RA01A1P.A081A PARTLEVEL --T...
RA01A1P.A082A .TRA082A1 INCLUDE TABLESPACE RA01A1P.A082A PARTLEVEL --T...
RA01A1P.A083A .TRA083A1 INCLUDE TABLESPACE RA01A1P.A083A PARTLEVEL --T...
BS01A1P.A003A .TBS003A1 INCLUDE TABLESPACE BS01A1P.A003A PARTLEVEL --T...
CD01A1P.A031A .TCD031 INCLUDE TABLESPACE CD01A1P.A031A PARTLEVEL --TCD031
CD01A1P.A041A .TCD041 INCLUDE TABLESPACE CD01A1P.A041A PARTLEVEL --TCD041
CD01A1P.A061A .TCD061 INCLUDE TABLESPACE CD01A1P.A061A PARTLEVEL --TCD061
CD01A1P.A091A .TCD091 INCLUDE TABLESPACE CD01A1P.A091A PARTLEVEL --TCD091
CD01A1P.A111A .TCD111 INCLUDE TABLESPACE CD01A1P.A111A PARTLEVEL --TCD111
CD01A1P.A131A .TCD131 INCLUDE TABLESPACE CD01A1P.A131A PARTLEVEL --TCD131
CD01A1P.A231A .TCD231 INCLUDE TABLESPACE CD01A1P.A231A PARTLEVEL --TCD231
CD01A1P.A251A .TCD251 INCLUDE TABLESPACE CD01A1P.A251A PARTLEVEL --TCD251
CD01A1P.A291A .TCD291 INCLUDE TABLESPACE CD01A1P.A291A PARTLEVEL --TCD291
CD01A1P.A301A .TCD301 INCLUDE TABLESPACE CD01A1P.A301A PARTLEVEL --TCD301
CD01A1P.A341A .TCD341 INCLUDE TABLESPACE CD01A1P.A341A PARTLEVEL --TCD341
CD01A1P.A391A .TCD391 INCLUDE TABLESPACE CD01A1P.A391A PARTLEVEL --TCD391
CD01A1P.A451A .TCD451 INCLUDE TABLESPACE CD01A1P.A451A PARTLEVEL --TCD451
CD01A1P.A771A .TCD771 INCLUDE TABLESPACE CD01A1P.A771A PARTLEVEL --TCD771
CD03A1P.A100P .TCD100A1 INCLUDE TABLESPACE CD03A1P.A100P PARTLEVEL --T...
CD03A1P.A100B .TCD100B1 INCLUDE TABLESPACE CD03A1P.A100B PARTLEVEL --T...
CD03A1P.A140A .TCD140A1 INCLUDE TABLESPACE CD03A1P.A140A PARTLEVEL --T...
CD03A1P.A140H .TCD140H1 INCLUDE TABLESPACE CD03A1P.A140H PARTLEVEL --T...
CD03A1P.A181A .TCD181A1 INCLUDE TABLESPACE CD03A1P.A181A PARTLEVEL --T...
CD03A1P.A181H .TCD181H1 INCLUDE TABLESPACE CD03A1P.A181H PARTLEVEL --T...
CD03A1P.A182A .TCD182A1 INCLUDE TABLESPACE CD03A1P.A182A PARTLEVEL --T...
CD03A1P.A182H .TCD182H1 INCLUDE TABLESPACE CD03A1P.A182H PARTLEVEL --T...
CD01A1P.A306A .TCD306A1 INCLUDE TABLESPACE CD01A1P.A306A PARTLEVEL --T...
CD03A1P.A380A .TCD380A1 INCLUDE TABLESPACE CD03A1P.A380A PARTLEVEL --T...
CD02A1P.A470A .TCD470A1 INCLUDE TABLESPACE CD02A1P.A470A PARTLEVEL --T...
CD02A1P.A616A .TCD616A1 INCLUDE TABLESPACE CD02A1P.A616A PARTLEVEL --T...
CD02A1P.A617A .TCD617A1 INCLUDE TABLESPACE CD02A1P.A617A PARTLEVEL --T...
CD02A1P.A619A .TCD619A1 INCLUDE TABLESPACE CD02A1P.A619A PARTLEVEL --T...
CD03A1P.A630A .TCD630A1 INCLUDE TABLESPACE CD03A1P.A630A PARTLEVEL --T...
CD03A1P.A633A .TCD633A1 INCLUDE TABLESPACE CD03A1P.A633A PARTLEVEL --T...
CD03A1P.A634A .TCD634A1 INCLUDE TABLESPACE CD03A1P.A634A PARTLEVEL --T...
CD03A1P.A635A .TCD635A1 INCLUDE TABLESPACE CD03A1P.A635A PARTLEVEL --T...
CK01A1P.A025A .TCK025A1 INCLUDE TABLESPACE CK01A1P.A025A PARTLEVEL --T...
CK01A1P.A030A .TCK030A1 INCLUDE TABLESPACE CK01A1P.A030A PARTLEVEL --T...
CK01A1P.A031A .TCK031A1 INCLUDE TABLESPACE CK01A1P.A031A PARTLEVEL --T...
CK01A1P.A078A .TCK078A1 INCLUDE TABLESPACE CK01A1P.A078A PARTLEVEL --T...
CK01A1P.A083A .TCK083A1 INCLUDE TABLESPACE CK01A1P.A083A PARTLEVEL --T...
CK01A1P.A085A .TCK085A1 INCLUDE TABLESPACE CK01A1P.A085A PARTLEVEL --T...
CT02A1P.A152A .TCT152A1 INCLUDE TABLESPACE CT02A1P.A152A PARTLEVEL --T...
CT01G1P.A152A .TCT152G1 INCLUDE TABLESPACE CT01G1P.A152A PARTLEVEL --T...
CT02A1P.A153A .TCT153A1 INCLUDE TABLESPACE CT02A1P.A153A PARTLEVEL --T...
CT01G1P.A153A .TCT153G1 INCLUDE TABLESPACE CT01G1P.A153A PARTLEVEL --T...
CT02A1P.A202A .TCT202A1 INCLUDE TABLESPACE CT02A1P.A202A PARTLEVEL --T...
CT01G1P.A202A .TCT202G1 INCLUDE TABLESPACE CT01G1P.A202A PARTLEVEL --T...
CT02A1P.A203A .TCT203A1 INCLUDE TABLESPACE CT02A1P.A203A PARTLEVEL --T...
CT01G1P.A203A .TCT203G1 INCLUDE TABLESPACE CT01G1P.A203A PARTLEVEL --T...
CT02A1P.A206A .TCT206A1 INCLUDE TABLESPACE CT02A1P.A206A PARTLEVEL --T...
CT01G1P.A206A .TCT206G1 INCLUDE TABLESPACE CT01G1P.A206A PARTLEVEL --T...
CT02A1P.A217A .TCT217A1 INCLUDE TABLESPACE CT02A1P.A217A PARTLEVEL --T...
CT01G1P.A217A .TCT217G1 INCLUDE TABLESPACE CT01G1P.A217A PARTLEVEL --T...
CT02A1P.A251A .TCT251A1 INCLUDE TABLESPACE CT02A1P.A251A PARTLEVEL --T...
CT01G1P.A251A .TCT251G1 INCLUDE TABLESPACE CT01G1P.A251A PARTLEVEL --T...
CT02A1P.A253A .TCT253A1 INCLUDE TABLESPACE CT02A1P.A253A PARTLEVEL --T...
CT01G1P.A253A .TCT253G1 INCLUDE TABLESPACE CT01G1P.A253A PARTLEVEL --T...
CT02A1P.A254A .TCT254A1 INCLUDE TABLESPACE CT02A1P.A254A PARTLEVEL --T...
CT01G1P.A254A .TCT254G1 INCLUDE TABLESPACE CT01G1P.A254A PARTLEVEL --T...
CT02A1P.A256A .TCT256A1 INCLUDE TABLESPACE CT02A1P.A256A PARTLEVEL --T...
CT01G1P.A256A .TCT256G1 INCLUDE TABLESPACE CT01G1P.A256A PARTLEVEL --T...
CT02A1P.A257A .TCT257A1 INCLUDE TABLESPACE CT02A1P.A257A PARTLEVEL --T...
CT01G1P.A257A .TCT257G1 INCLUDE TABLESPACE CT01G1P.A257A PARTLEVEL --T...
CT02A1P.A258A .TCT258A1 INCLUDE TABLESPACE CT02A1P.A258A PARTLEVEL --T...
CT01G1P.A258A .TCT258G1 INCLUDE TABLESPACE CT01G1P.A258A PARTLEVEL --T...
CT02A1P.A259A .TCT259A1 INCLUDE TABLESPACE CT02A1P.A259A PARTLEVEL --T...
CT01G1P.A259A .TCT259G1 INCLUDE TABLESPACE CT01G1P.A259A PARTLEVEL --T...
CT02A1P.A261A .TCT261A1 INCLUDE TABLESPACE CT02A1P.A261A PARTLEVEL --T...
CT01G1P.A261A .TCT261G1 INCLUDE TABLESPACE CT01G1P.A261A PARTLEVEL --T...
CT02A1P.A301A .TCT301A1 INCLUDE TABLESPACE CT02A1P.A301A PARTLEVEL --T...
CT01G1P.A301A .TCT301G1 INCLUDE TABLESPACE CT01G1P.A301A PARTLEVEL --T...
CT02A1P.A305A .TCT305A1 INCLUDE TABLESPACE CT02A1P.A305A PARTLEVEL --T...
CT01G1P.A305A .TCT305G1 INCLUDE TABLESPACE CT01G1P.A305A PARTLEVEL --T...
CT02A1P.A306A .TCT306A1 INCLUDE TABLESPACE CT02A1P.A306A PARTLEVEL --T...
CT01G1P.A306A .TCT306G1 INCLUDE TABLESPACE CT01G1P.A306A PARTLEVEL --T...
CT02A1P.A308A .TCT308A1 INCLUDE TABLESPACE CT02A1P.A308A PARTLEVEL --T...
CT01G1P.A308A .TCT308G1 INCLUDE TABLESPACE CT01G1P.A308A PARTLEVEL --T...
CT02A1P.A309A .TCT309A1 INCLUDE TABLESPACE CT02A1P.A309A PARTLEVEL --T...
CT01G1P.A309A .TCT309G1 INCLUDE TABLESPACE CT01G1P.A309A PARTLEVEL --T...
CT02A1P.A353A .TCT353A1 INCLUDE TABLESPACE CT02A1P.A353A PARTLEVEL --T...
CT01G1P.A353A .TCT353G1 INCLUDE TABLESPACE CT01G1P.A353A PARTLEVEL --T...
CT02A1P.A356A .TCT356A1 INCLUDE TABLESPACE CT02A1P.A356A PARTLEVEL --T...
CT01G1P.A356A .TCT356G1 INCLUDE TABLESPACE CT01G1P.A356A PARTLEVEL --T...
CT02A1P.A400A .TCT400A1 INCLUDE TABLESPACE CT02A1P.A400A PARTLEVEL --T...
CT01G1P.A400A .TCT400G1 INCLUDE TABLESPACE CT01G1P.A400A PARTLEVEL --T...
CY02A1P.A056A .TCY056A1 INCLUDE TABLESPACE CY02A1P.A056A PARTLEVEL --T...
CZ08A1P.A025A .TCZ025A1 INCLUDE TABLESPACE CZ08A1P.A025A PARTLEVEL --T...
CZ18A1P.A025A .TCZ025E1 INCLUDE TABLESPACE CZ18A1P.A025A PARTLEVEL --T...
CZ08G1P.A025A .TCZ025G1 INCLUDE TABLESPACE CZ08G1P.A025A PARTLEVEL --T...
CZ08A1P.A100A .TCZ100A1 INCLUDE TABLESPACE CZ08A1P.A100A PARTLEVEL --T...
CZ18A1P.A100A .TCZ100E1 INCLUDE TABLESPACE CZ18A1P.A100A PARTLEVEL --T...
CZ08G1P.A100A .TCZ100G1 INCLUDE TABLESPACE CZ08G1P.A100A PARTLEVEL --T...
CZ08A1P.A101A .TCZ101A1 INCLUDE TABLESPACE CZ08A1P.A101A PARTLEVEL --T...
CZ18A1P.A101A .TCZ101E1 INCLUDE TABLESPACE CZ18A1P.A101A PARTLEVEL --T...
CZ08G1P.A101A .TCZ101G1 INCLUDE TABLESPACE CZ08G1P.A101A PARTLEVEL --T...
CZ08A1P.A103A .TCZ103A1 INCLUDE TABLESPACE CZ08A1P.A103A PARTLEVEL --T...
CZ18A1P.A103A .TCZ103E1 INCLUDE TABLESPACE CZ18A1P.A103A PARTLEVEL --T...
CZ08G1P.A103A .TCZ103G1 INCLUDE TABLESPACE CZ08G1P.A103A PARTLEVEL --T...
CZ08A1P.A106A .TCZ106A1 INCLUDE TABLESPACE CZ08A1P.A106A PARTLEVEL --T...
CZ18A1P.A106A .TCZ106E1 INCLUDE TABLESPACE CZ18A1P.A106A PARTLEVEL --T...
CZ08G1P.A106A .TCZ106G1 INCLUDE TABLESPACE CZ08G1P.A106A PARTLEVEL --T...
CZ07A1P.A191A .TCZ191A1 INCLUDE TABLESPACE CZ07A1P.A191A PARTLEVEL --T...
CZ07G1P.A191A .TCZ191G1 INCLUDE TABLESPACE CZ07G1P.A191A PARTLEVEL --T...
CZ03A1P.A235A .TCZ235A1 INCLUDE TABLESPACE CZ03A1P.A235A PARTLEVEL --T...
CZ03G1P.A235A .TCZ235G1 INCLUDE TABLESPACE CZ03G1P.A235A PARTLEVEL --T...
CZ03A1P.A236A .TCZ236A1 INCLUDE TABLESPACE CZ03A1P.A236A PARTLEVEL --T...
CZ03G1P.A236A .TCZ236G1 INCLUDE TABLESPACE CZ03G1P.A236A PARTLEVEL --T...
CZ14A1P.A250A .TCZ250A1 INCLUDE TABLESPACE CZ14A1P.A250A PARTLEVEL --T...
CZ14G1P.A250A .TCZ250G1 INCLUDE TABLESPACE CZ14G1P.A250A PARTLEVEL --T...
CZ14A1P.A251A .TCZ251A1 INCLUDE TABLESPACE CZ14A1P.A251A PARTLEVEL --T...
CZ14G1P.A251A .TCZ251G1 INCLUDE TABLESPACE CZ14G1P.A251A PARTLEVEL --T...
CZ03A1P.A300A .TCZ300A1 INCLUDE TABLESPACE CZ03A1P.A300A PARTLEVEL --T...
CZ03A1P.A313A .TCZ313A1 INCLUDE TABLESPACE CZ03A1P.A313A PARTLEVEL --T...
CZ03G1P.A313A .TCZ313G1 INCLUDE TABLESPACE CZ03G1P.A313A PARTLEVEL --T...
CZ03A1P.A315A .TCZ315A1 INCLUDE TABLESPACE CZ03A1P.A315A PARTLEVEL --T...
CZ03G1P.A315A .TCZ315G1 INCLUDE TABLESPACE CZ03G1P.A315A PARTLEVEL --T...
CZ03A1P.A319A .TCZ319A1 INCLUDE TABLESPACE CZ03A1P.A319A PARTLEVEL --T...
CZ03G1P.A319A .TCZ319G1 INCLUDE TABLESPACE CZ03G1P.A319A PARTLEVEL --T...
CZ03A1P.A321A .TCZ321A1 INCLUDE TABLESPACE CZ03A1P.A321A PARTLEVEL --T...
CZ03G1P.A321A .TCZ321G1 INCLUDE TABLESPACE CZ03G1P.A321A PARTLEVEL --T...
CZ03A1P.A323A .TCZ323A1 INCLUDE TABLESPACE CZ03A1P.A323A PARTLEVEL --T...
CZ03G1P.A323A .TCZ323G1 INCLUDE TABLESPACE CZ03G1P.A323A PARTLEVEL --T...
CZ03A1P.A327A .TCZ327A1 INCLUDE TABLESPACE CZ03A1P.A327A PARTLEVEL --T...
CZ03G1P.A327A .TCZ327G1 INCLUDE TABLESPACE CZ03G1P.A327A PARTLEVEL --T...
CZ03A1P.A331A .TCZ331A1 INCLUDE TABLESPACE CZ03A1P.A331A PARTLEVEL --T...
CZ03G1P.A331A .TCZ331G1 INCLUDE TABLESPACE CZ03G1P.A331A PARTLEVEL --T...
CZ03A1P.A340A .TCZ340A1 INCLUDE TABLESPACE CZ03A1P.A340A PARTLEVEL --T...
CZ03A1P.A384A .TCZ384A1 INCLUDE TABLESPACE CZ03A1P.A384A PARTLEVEL --T...
CZ03G1P.A384A .TCZ384G1 INCLUDE TABLESPACE CZ03G1P.A384A PARTLEVEL --T...
CZ03A1P.A386A .TCZ386A1 INCLUDE TABLESPACE CZ03A1P.A386A PARTLEVEL --T...
CZ03G1P.A386A .TCZ386G1 INCLUDE TABLESPACE CZ03G1P.A386A PARTLEVEL --T...
CZ03A1P.A421A .TCZ421A1 INCLUDE TABLESPACE CZ03A1P.A421A PARTLEVEL --T...
CZ03G1P.A421A .TCZ421G1 INCLUDE TABLESPACE CZ03G1P.A421A PARTLEVEL --T...
CZ03A1P.A428A .TCZ428A1 INCLUDE TABLESPACE CZ03A1P.A428A PARTLEVEL --T...
CZ03G1P.A428A .TCZ428G1 INCLUDE TABLESPACE CZ03G1P.A428A PARTLEVEL --T...
CZ03A1P.A429A .TCZ429A1 INCLUDE TABLESPACE CZ03A1P.A429A PARTLEVEL --T...
CZ03G1P.A429A .TCZ429G1 INCLUDE TABLESPACE CZ03G1P.A429A PARTLEVEL --T...
CZ03A1P.A432A .TCZ432A1 INCLUDE TABLESPACE CZ03A1P.A432A PARTLEVEL --T...
CZ03A1P.A433A .TCZ433A1 INCLUDE TABLESPACE CZ03A1P.A433A PARTLEVEL --T...
CZ04A1P.A500A .TCZ500A1 INCLUDE TABLESPACE CZ04A1P.A500A PARTLEVEL --T...
CZ04A1P.A513A .TCZ513A1 INCLUDE TABLESPACE CZ04A1P.A513A PARTLEVEL --T...
CZ04A1P.A515A .TCZ515A1 INCLUDE TABLESPACE CZ04A1P.A515A PARTLEVEL --T...
CZ04A1P.A519A .TCZ519A1 INCLUDE TABLESPACE CZ04A1P.A519A PARTLEVEL --T...
CZ04A1P.A521A .TCZ521A1 INCLUDE TABLESPACE CZ04A1P.A521A PARTLEVEL --T...
CZ04A1P.A584A .TCZ584A1 INCLUDE TABLESPACE CZ04A1P.A584A PARTLEVEL --T...
CZ04A1P.A621A .TCZ621A1 INCLUDE TABLESPACE CZ04A1P.A621A PARTLEVEL --T...
CZ13A1P.A707A .TCZ707A1 INCLUDE TABLESPACE CZ13A1P.A707A PARTLEVEL --T...
CZ13A1P.A708A .TCZ708A1 INCLUDE TABLESPACE CZ13A1P.A708A PARTLEVEL --T...
DB01A1P.A201A .TDB201A1 INCLUDE TABLESPACE DB01A1P.A201A PARTLEVEL --T...
DE02A1P.A023A .TDE023A1 INCLUDE TABLESPACE DE02A1P.A023A PARTLEVEL --T...
ED02A1P.A023A .TED023A1 INCLUDE TABLESPACE ED02A1P.A023A PARTLEVEL --T...
FC01A1P.A001A .TFC001A0 INCLUDE TABLESPACE FC01A1P.A001A PARTLEVEL --T...
KC01A1P.A001A .TKC001A1 INCLUDE TABLESPACE KC01A1P.A001A PARTLEVEL --T...
KC01A1P.A002A .TKC002A1 INCLUDE TABLESPACE KC01A1P.A002A PARTLEVEL --T...
KC01A1P.A003A .TKC003A1 INCLUDE TABLESPACE KC01A1P.A003A PARTLEVEL --T...
KC01A1P.A010A .TKC010A1 INCLUDE TABLESPACE KC01A1P.A010A PARTLEVEL --T...
MF03A1P.A009A .TMF009A1 INCLUDE TABLESPACE MF03A1P.A009A PARTLEVEL --T...
MF01A1P.A101A .TMF101A1 INCLUDE TABLESPACE MF01A1P.A101A PARTLEVEL --T...
MF01A1P.A103A .TMF103A1 INCLUDE TABLESPACE MF01A1P.A103A PARTLEVEL --T...
MF01A1P.A104A .TMF104A1 INCLUDE TABLESPACE MF01A1P.A104A PARTLEVEL --T...
NI02A1P.A100A .TNI100A101A INCLUDE TABLESPACE NI02A1P.A100A PARTLEVEL ...
NI02A1P.A609A .TNI609A101A INCLUDE TABLESPACE NI02A1P.A609A PARTLEVEL ...
NZ03A1P.A021A .TNZ021A1 INCLUDE TABLESPACE NZ03A1P.A021A PARTLEVEL --T...
NZ02A1P.A150A .TNZ150A1 INCLUDE TABLESPACE NZ02A1P.A150A PARTLEVEL --T...
NZ02A1P.A151A .TNZ151A1 INCLUDE TABLESPACE NZ02A1P.A151A PARTLEVEL --T...
NZ02A1P.A152A .TNZ152A1 INCLUDE TABLESPACE NZ02A1P.A152A PARTLEVEL --T...
NZ01A1P.A202A .TNZ202A1 INCLUDE TABLESPACE NZ01A1P.A202A PARTLEVEL --T...
NZ01A1P.A204A .TNZ204A1 INCLUDE TABLESPACE NZ01A1P.A204A PARTLEVEL --T...
NZ01A1P.A209A .TNZ209A1 INCLUDE TABLESPACE NZ01A1P.A209A PARTLEVEL --T...
NZ01A1P.A212A .TNZ212A1 INCLUDE TABLESPACE NZ01A1P.A212A PARTLEVEL --T...
NZ01A1P.A252A .TNZ252A1 INCLUDE TABLESPACE NZ01A1P.A252A PARTLEVEL --T...
NZ01A1P.A258A .TNZ258A1 INCLUDE TABLESPACE NZ01A1P.A258A PARTLEVEL --T...
RM01A1P.A003A .TRM003A1 INCLUDE TABLESPACE RM01A1P.A003A PARTLEVEL --T...
RM01A1P.A010A .TRM010A1 INCLUDE TABLESPACE RM01A1P.A010A PARTLEVEL --T...
RM01A1P.A020A .TRM020A1 INCLUDE TABLESPACE RM01A1P.A020A PARTLEVEL --T...
RM01A1P.A021A .TRM021A1 INCLUDE TABLESPACE RM01A1P.A021A PARTLEVEL --T...
RV01A1P.A100A .TRV100A1 INCLUDE TABLESPACE RV01A1P.A100A PARTLEVEL --T...
RV01A1P.A110A .TRV110A1 INCLUDE TABLESPACE RV01A1P.A110A PARTLEVEL --T...
RV01A1P.A120A .TRV120A1 INCLUDE TABLESPACE RV01A1P.A120A PARTLEVEL --T...
RV01A1P.A130A .TRV130A1 INCLUDE TABLESPACE RV01A1P.A130A PARTLEVEL --T...
RV01A1P.A140A .TRV140A1 INCLUDE TABLESPACE RV01A1P.A140A PARTLEVEL --T...
RV01A1P.A221A .TRV221A1 INCLUDE TABLESPACE RV01A1P.A221A PARTLEVEL --T...
RV01A1P.A301A .TRV301A1 INCLUDE TABLESPACE RV01A1P.A301A PARTLEVEL --T...
RV01A1P.A431A .TRV431A1 INCLUDE TABLESPACE RV01A1P.A431A PARTLEVEL --T...
RV01A1P.A451A .TRV451A1 INCLUDE TABLESPACE RV01A1P.A451A PARTLEVEL --T...
RV01A1P.A501A .TRV501A1 INCLUDE TABLESPACE RV01A1P.A501A PARTLEVEL --T...
RV01A1P.A600A .TRV600A1 INCLUDE TABLESPACE RV01A1P.A600A PARTLEVEL --T...
UU02A1P.A130A .TUU130A2 INCLUDE TABLESPACE UU02A1P.A130A PARTLEVEL --T...
VD01A1P.A002A .TVD002A1 INCLUDE TABLESPACE VD01A1P.A002A PARTLEVEL --T...
VP03A1P.A009A .TVP009A1 INCLUDE TABLESPACE VP03A1P.A009A PARTLEVEL --T...
VP02A1P.A020A .TVP020A1 INCLUDE TABLESPACE VP02A1P.A020A PARTLEVEL --T...
VP02H1P.A020H .TVP020H1 INCLUDE TABLESPACE VP02H1P.A020H PARTLEVEL --T...
VP02A1P.A023A .TVP023A1 INCLUDE TABLESPACE VP02A1P.A023A PARTLEVEL --T...
VP02H1P.A023H .TVP023H1 INCLUDE TABLESPACE VP02H1P.A023H PARTLEVEL --T...
VP02A1P.A025A .TVP025A1 INCLUDE TABLESPACE VP02A1P.A025A PARTLEVEL --T...
VP02H1P.A025H .TVP025H1 INCLUDE TABLESPACE VP02H1P.A025H PARTLEVEL --T...
VP02A1P.A036A .TVP036A1 INCLUDE TABLESPACE VP02A1P.A036A PARTLEVEL --T...
VP02H1P.A036H .TVP036H1 INCLUDE TABLESPACE VP02H1P.A036H PARTLEVEL --T...
WF01A1P.A003A .TWF003A1 INCLUDE TABLESPACE WF01A1P.A003A PARTLEVEL --T...
WF01A1P.A032A .TWF032A1 INCLUDE TABLESPACE WF01A1P.A032A PARTLEVEL --T...
WF01A1P.A034A .TWF034A1 INCLUDE TABLESPACE WF01A1P.A034A PARTLEVEL --T...
WF01A1P.A035A .TWF035A1 INCLUDE TABLESPACE WF01A1P.A035A PARTLEVEL --T...
WF01A1P.A051A .TWF051A1 INCLUDE TABLESPACE WF01A1P.A051A PARTLEVEL --T...
WF01A1P.A052A .TWF052A1 INCLUDE TABLESPACE WF01A1P.A052A PARTLEVEL --T...
WF01A1P.A073A .TWF073A1 INCLUDE TABLESPACE WF01A1P.A073A PARTLEVEL --T...
WF01A1P.A076A .TWF076A1 INCLUDE TABLESPACE WF01A1P.A076A PARTLEVEL --T...
WF01A1P.A080A .TWF080A1 INCLUDE TABLESPACE WF01A1P.A080A PARTLEVEL --T...
WF01A1P.A082A .TWF082A1 INCLUDE TABLESPACE WF01A1P.A082A PARTLEVEL --T...
WF01A1P.A083A .TWF083A1 INCLUDE TABLESPACE WF01A1P.A083A PARTLEVEL --T...
WF01A1P.A086A .TWF086A1 INCLUDE TABLESPACE WF01A1P.A086A PARTLEVEL --T...
WF01A1P.A088A .TWF088A1 INCLUDE TABLESPACE WF01A1P.A088A PARTLEVEL --T...
WF01A1P.A090A .TWF090A1 INCLUDE TABLESPACE WF01A1P.A090A PARTLEVEL --T...
WF01A1P.A091A .TWF091A1 INCLUDE TABLESPACE WF01A1P.A091A PARTLEVEL --T...
WG01A1P.A100A .TWG100A1 INCLUDE TABLESPACE WG01A1P.A100A PARTLEVEL --T...
WG01A1P.A101A .TWG101A1 INCLUDE TABLESPACE WG01A1P.A101A PARTLEVEL --T...
WG01A1P.A200A .TWG200A1 INCLUDE TABLESPACE WG01A1P.A200A PARTLEVEL --T...
WG01A1P.A400A .TWG400A1 INCLUDE TABLESPACE WG01A1P.A400A PARTLEVEL --T...
WG01A1P.A410A .TWG410A1 INCLUDE TABLESPACE WG01A1P.A410A PARTLEVEL --T...
WL09A1P.A901A .TWL901A1 INCLUDE TABLESPACE WL09A1P.A901A PARTLEVEL --T...
WM01A1P.A005A .TWM005A1 INCLUDE TABLESPACE WM01A1P.A005A PARTLEVEL --T...
WR01A1P.A002A .TWR002A1 INCLUDE TABLESPACE WR01A1P.A002A PARTLEVEL --T...
ts=AV15A1P tb=A111A tb OA1P.TAV111A1 *dbof ts ...
ts=AV15A1P tb=A122A tb OA1P.TAV122A1 *dbof ts ...
ts=AV15A1P tb=A135A tb OA1P.TAV135A1 *dbof ts ...
ts=AV15A1P tb=A141A tb OA1P.TAV141A1 *dbof ts ...
ts=AV15A1P tb=A151C tb OA1P.TAV151C1 *dbof ts ...
ts=AV15A1P tb=A153A tb OA1P.TAV153A1 *dbof ts ...
ts=AV15A1P tb=A158A tb OA1P.TAV158A1 *dbof ts ...
ts=AV15A1P tb=A159A tb OA1P.TAV159A1 *dbof ts ...
ts=AV15A1P tb=A183A tb OA1P.TAV183A1 *dbof ts ...
ts=AV15A1P tb=A184A tb OA1P.TAV184A1 *dbof ts ...
ts=CD03A1P tb=A100P tb OA1P.TCD100A1 *dbof ts ...
ts=CD03A1P tb=A117B tb OA1P.TCD117B1 *dbof ts ...
ts=CK01A1P tb=A020A tb OA1P.TCK020A1 *dbof ts ...
ts=CT01G1P tb=A292A tb OA1P.TCT292G1 *dbof ts ...
ts=CZ03A1P tb=A435A tb OA1P.TCZ435A1 *dbof ts ...
ts=CZ03G1P tb=A238A tb OA1P.TCZ238G1 *dbof ts ...
ts=CZ04A1P tb=A642A tb OA1P.TCZ642A1 *dbof ts ...
ts=DA540769 tb=AMFNVEXT tb A540769.TMFNVEXT *dbof ts ...
ts=DB2MAPP tb=ELS100RP tb S100447.ELS100RP *dbof ts ...
ts=DB2MAPP1 tb=QR20808P tb S100447.QR20808P *dbof ts ...
ts=DG01A1P tb=A121A tb OA1P.TDG121A1 *dbof ts ...
ts=DG01A1P tb=A125A tb OA1P.TDG125A1 *dbof ts ...
ts=DI05A1P tb=A047A tb OA1P.TDI047A1 *dbof ts ...
ts=FI04A1P tb=A027E tb OA1P.TFI027E1 *dbof ts ...
ts=FI04A1P tb=A027J tb OA1P.TFI027J1 *dbof ts ...
ts=GE01A1P tb=A024A tb OA1P.TGE024A1 *dbof ts ...
ts=HY01A1P tb=A161A tb OA1P.THY161A1 *dbof ts ...
ts=HY01G1P tb=A193A tb OA1P.THY193G1 *dbof ts ...
ts=KE01A1P tb=A892H tb OA1P.TKE892H2 *dbof ts ...
ts=MI01A1P tb=A541A tb OA1P.TMI541A1 *dbof ts ...
ts=NG03A1P tb=A990A tb OA1P.TNG990A1 *dbof ts ...
ts=NI03A1P tb=A250A04 tb OA1P.TNI250A104A *dbof ts ...
ts=NI04A1P tb=A300A04 tb OA1P.TNI300A104A *dbof ts ...
ts=NI04A1P tb=A360A04 tb OA1P.TNI360A104A *dbof ts ...
ts=NI10A1P tb=A703A tb OA1P.TNI703A1 *dbof ts ...
ts=NI10A1P tb=A703H tb OA1P.TNI703H1 *dbof ts ...
ts=NI10A1P tb=A704H tb OA1P.TNI704H1 *dbof ts ...
ts=NI10A1P tb=A706H tb OA1P.TNI706H1 *dbof ts ...
ts=NI10A1P tb=A755A tb OA1P.TNI755A1 *dbof ts ...
ts=NZ01A1P tb=A207A tb OA1P.TNZ207A1 *dbof ts ...
ts=NZ06A1P tb=A243A tb OA1P.TNZ243A1 *dbof ts ...
ts=PW01A1P tb=A214A tb OA1P.TPW214A1 *dbof ts ...
ts=PW01A1P tb=A314A tb OA1P.TPW314A1 *dbof ts ...
ts=PW01A1P tb=A315A tb OA1P.TPW315A1 *dbof ts ...
ts=RA01A1P tb=A020A tb OA1P.TRA020A1 *dbof ts ...
ts=SA02A1P tb=A243A tb OA1P.TSA243A1 *dbof ts ...
ts=SN01A1P tb=A169A tb OA1P.TSN169A1 *dbof ts ...
ts=TY01A1P tb=A002A tb OA1P.TTY002A1 *dbof ts ...
ts=VP02H1P tb=A020H tb OA1P.TVP020H1 *dbof ts ...
ts=VV29A1P tb=VDPS404 tb VDPS2.VTRELATEDEVENT *dbof ts ...
ts=WB11A1P tb=A213A tb OA1P.TWB213A1 *dbof ts ...
ts=WI02A1P tb=A105H003 tb OA1P.TWI105H1003 *dbof ts ...
ts=WI02A1P tb=A109A001 tb OA1P.TWI109A1001 *dbof ts ...
ts=WI02A1P tb=A801A001 tb OA1P.TWI801A1001 *dbof ts ...
ts=WI02A1P tb=A801A002 tb OA1P.TWI801A1002 *dbof ts ...
ts=WKDBDOF2 tb=DGT32K02 ty=G, 0 tables||| *dbof ts ...
ts=WKDBDOF5 tb=DGT4K06 ty=G, 0 tables||| *dbof ts ...
ts=WKDBDOF7 tb=DGT32K39 ty=G, 0 tables||| *dbof ts ...
ts=WKDBDOF7 tb=DSN32K38 ty= , 0 tables||| *dbof ts ...
ts=WKDBDOF7 tb=DSN4K09 ty= , 0 tables||| *dbof ts ...
ts=WKDBDOF8 tb=DSN32K26 ty= , 0 tables||| *dbof ts ...
ts=WL01A1P tb=A007A01J tb OA1P.TWL007A101J *dbof ts ...
ts=WL07A1P tb=A702A tb OA1P.TWL702A1 *dbof ts ...
ts=WP02A1P tb=A111A01 tb OA1P.TWP111A101 *dbof ts ...
ts=WP02A1P tb=A113A02 tb OA1P.TWP113A102 *dbof ts ...
ts=XC01A1P tb=A200A00 tb OA1P00.TXC200A1 *dbof ts ...
ts=XC01A1P tb=A200A01 tb OA1P01.TXC200A1 *dbof ts ...
ts=XC01A1P tb=A200A02 tb OA1P02.TXC200A1 *dbof ts ...
ts=XC01A1P tb=A200A03 tb OA1P03.TXC200A1 *dbof ts ...
ts=XC01A1P tb=A200A04 tb OA1P04.TXC200A1 *dbof ts ...
ts=XC01A1P tb=A200A05 tb OA1P05.TXC200A1 *dbof ts ...
ts=XC01A1P tb=A200A06 tb OA1P06.TXC200A1 *dbof ts ...
ts=XC01A1P tb=A200A07 tb OA1P07.TXC200A1 *dbof ts ...
ts=XC01A1P tb=A200A08 tb OA1P08.TXC200A1 *dbof ts ...
ts=XC01A1P tb=A200A09 tb OA1P09.TXC200A1 *dbof ts ...
ts=XC01A1P tb=A501A tb OA1P.TXC501A1 *dbof ts ...
ts=XC01A1P tb=A510A tb OA1P.TXC510A1 *dbof ts ...
ts=XC01A1P tb=A511A tb OA1P.TXC511A1 *dbof ts ...
ts=XC01A1P tb=A512A tb OA1P.TXC512A1 *dbof ts ...
ts=XC01A1P tb=A513A tb OA1P.TXC513A1 *dbof ts ...
ts=XC01A1P tb=A514A tb OA1P.TXC514A1 *dbof ts ...
ts=XC01A1P tb=A516A tb OA1P.TXC516A1 *dbof ts ...
ts=CZ03G1P tb=A433A tb OA1P.TCZ433G1 *dbof ts ...
ts=DP06A1P tb=A063A tb OA1P.TDP063A1 *dbof ts ...
ts=FI04A1P tb=A120A tb OA1P.TFI120A1 *dbof ts ...
ts=NZ06A1P tb=A247A tb OA1P.TNZ247A1 *dbof ts ...
ts=NZ06A1P tb=A262A tb OA1P.TNZ262A1 *dbof ts ...
is=AV15A1P tb=IAV105A0 tb OA1P.TAV105A1 ix IAV105A0 *dbof is ...
is=AV15A1P tb=IAV107A0 tb OA1P.TAV107A1 ix IAV107A0 *dbof is ...
is=AV15A1P tb=IAV110A2 tb OA1P.TAV110A1 ix IAV110A2 *dbof is ...
is=AV15A1P tb=IAV111A0 tb OA1P.TAV111A1 ix IAV111A0 *dbof is ...
is=AV15A1P tb=IAV113A1 tb OA1P.TAV113A1 ix IAV113A1 *dbof is ...
is=AV15A1P tb=IAV115A1 tb OA1P.TAV115A1 ix IAV115A1 *dbof is ...
is=AV15A1P tb=IAV120A0 tb OA1P.TAV120A1 ix IAV120A0 *dbof is ...
is=AV15A1P tb=IAV123A0 tb OA1P.TAV123A1 ix IAV123A0 *dbof is ...
is=AV15A1P tb=IAV123A1 tb OA1P.TAV123A1 ix IAV123A1 *dbof is ...
is=AV15A1P tb=IAV135A0 tb OA1P.TAV135A1 ix IAV135A0 *dbof is ...
is=AV15A1P tb=IAV141A0 tb OA1P.TAV141A1 ix IAV141A0 *dbof is ...
is=AV15A1P tb=IAV151A0 tb OA1P.TAV151A1 ix IAV151A0 *dbof is ...
is=AV15A1P tb=IAV154A0 tb OA1P.TAV154A1 ix IAV154A0 *dbof is ...
is=AV15A1P tb=IAV155A0 tb OA1P.TAV155A1 ix IAV155A0 *dbof is ...
is=AV15A1P tb=IAV156A0 tb OA1P.TAV156A1 ix IAV156A0 *dbof is ...
is=AV15A1P tb=IAV157A0 tb OA1P.TAV157A1 ix IAV157A0 *dbof is ...
is=AV15A1P tb=IAV182A0 tb OA1P.TAV182A1 ix IAV182A0 *dbof is ...
is=AV15A1P tb=IAV182B0 tb OA1P.TAV182B1 ix IAV182B0 *dbof is ...
is=AV15A1P tb=IAV182B2 tb OA1P.TAV182B1 ix IAV182B2 *dbof is ...
is=AV15A1P tb=IAV185A0 tb OA1P.TAV185A1 ix IAV185A0 *dbof is ...
is=BE01A1P tb=IBE008A0 tb OA1P.TBE008A1 ix IBE008A0 *dbof is ...
is=BE01A1P tb=IBE01$S1 tb OA1P02.TBE005A1 ix IBE005A0 *dbof is ...
is=BE01A1P tb=IBE01KHB tb OA1P04.TBE010A1 ix IBE010A3 *dbof is ...
is=BE01A1P tb=IBE019AH tb OA1P04.TBE010A1 ix IBE010A1 *dbof is ...
is=BJ01A1P tb=IBJ012A0 tb OA1P.TBJ012A1 ix IBJ012A0 *dbof is ...
is=CE02A1P tb=ICE020A1 tb OA1P.TCE020A1 ix ICE020A1 *dbof is ...
is=CE02A1P tb=ICE025A2 tb OA1P.TCE025A1 ix ICE025A2 *dbof is ...
is=CZ03A1P tb=ICZ316A0 tb OA1P.TCZ316A1 ix ICZ316A0 *dbof is ...
is=CZ11G1P tb=ICZ927G0 tb OA1P.TCZ927G1 ix ICZ927G0 *dbof is ...
is=CZ18A1P tb=ICZ103E0 tb OA1P.TCZ103E1 ix ICZ103E0 *dbof is ...
is=DB01A1P tb=IDB200A0 tb OA1P.TDB200A1 ix IDB200A0 *dbof is ...
is=DB2MAPP tb=IXRQ1F6O tb S100447.QR01103P ix IX_QR01103P *dbof...
is=DG01A1P tb=IDG123A1 tb OA1P.TDG123A1 ix IDG123A1 *dbof is ...
is=DG01A1P tb=IDG124A1 tb OA1P.TDG124A1 ix IDG124A1 *dbof is ...
is=DG02A1P tb=IDG970A0 tb OA1P.TDG970A0 ix IDG970A0 *dbof is ...
is=EQ03A1P tb=IEQ903A1 tb OA1P.TEQ903A1 ix IEQ903A1 *dbof is ...
is=EU99A1P tb=IEU099A0 tb OA1P.TEU099A1 ix IEU099A0 *dbof is ...
is=FI02A1P tb=IFI610A0 tb OA1P.TFI610A1 ix IFI610A0 *dbof is ...
is=FI04A1P tb=IFI027B1 tb OA1P.TFI027B1 ix IFI027B1 *dbof is ...
is=FZ01A1P tb=IFZ021A2 tb OA1P.TFZ021A1 ix IFZ021A2 *dbof is ...
is=GM01A1P tb=IGM100A4 tb OA1P.TGM100A1 ix IGM100A4 *dbof is ...
is=KE01A1P tb=IKE895H2 tb OA1P.TKE895H2 ix IKE895H2 *dbof is ...
is=LW02A1P tb=ILW211A0 tb OA1P.TLW211A1 ix ILW211A0 *dbof is ...
is=MF01A1P tb=IMF11ZJ2 tb OA1P.TMF150H1 ix IMF150H10 *dbof is ...
is=MI01A1P tb=IMI520A0 tb OA1P.TMI520A1 ix IMI520A0 *dbof is ...
is=NI02A1P tb=INI350A1 tb OA1P.TNI350A103A ix INI350A103A *dbof...
is=NI03A1P tb=INI200A1 tb OA1P.TNI200A103A ix INI200A103A *dbof...
is=NI03A1P tb=INI21TX8 tb OA1P.TNI250A104A ix INI250A104A *dbof...
is=NI03A1P tb=INI216K2 tb OA1P.TNI250A104A ix INI250A204A *dbof...
is=NI04A1P tb=INI31G36 tb OA1P.TNI300H104A ix INI300H104A *dbof...
is=NI04A1P tb=INI31JK0 tb OA1P.TNI301A104A ix INI301A104A *dbof...
is=NI05A1P tb=INI200I1 tb OA1P.TNI200I101A ix INI200I101A *dbof...
is=NI06A1P tb=INI21N5F tb OA1P.TNI200K102A ix INI200K102A *dbof...
is=NI10A1P tb=INI703H0 tb OA1P.TNI703H1 ix INI703H0 *dbof is ...
is=NZ01A1P tb=INZ107A0 tb OA1P.TNZ107A1 ix INZ107A0 *dbof is ...
is=NZ06A1P tb=INZ241A1 tb OA1P.TNZ241A1 ix INZ241A1 *dbof is ...
is=NZ06A1P tb=INZ260A1 tb OA1P.TNZ260A1 ix INZ260A1 *dbof is ...
is=PC13A1P tb=IPC120A1 tb OA1P03.TPC120A1 ix IPC120A1 *dbof is ...
is=PC22A1P tb=IPC122A1 tb OA1P12.TPC122A1 ix IPC122A1 *dbof is ...
is=PW01A1P tb=IPW203A1 tb OA1P.TPW203A1 ix IPW203A1 *dbof is ...
is=PW01A1P tb=IPW310A4 tb OA1P.TPW310A1 ix IPW310A4 *dbof is ...
is=PW01A1P tb=IPW321A0 tb OA1P.TPW321A1 ix IPW321A0 *dbof is ...
is=SN01A1P tb=ISN169A1 tb OA1P.TSN169A1 ix ISN169A1 *dbof is ...
is=SN01A1P tb=ISN202A0 tb OA1P.TSN202A1 ix ISN202A0 *dbof is ...
is=SV02B1P tb=ISV021B3 tb OA1P.TSV021B1 ix ISV021B3 *dbof is ...
is=VV20A1P tb=IVV719A2 tb OA1P.TVV719A1 ix IVV719A2 *dbof is ...
is=VV20A1P tb=IVV719A3 tb OA1P.TVV719A1 ix IVV719A3 *dbof is ...
is=WB11A1P tb=IWB70413 tb OA1P.TWB704A1 ix IWB70413 *dbof is ...
is=WI02A1P tb=IWI801A2 tb OA1P.TWI801A1001 ix IWI801A2001 *dbof...
is=WI02A1P tb=IWI81CCW tb OA1P.TWI801A1003 ix IWI801A1003 *dbof...
is=WL01A1P tb=IWL014UG tb OA1P.TWL007A103J ix IWL007A003J *dbof...
is=WL07A1P tb=IWL704A0 tb OA1P.TWL704A1 ix IWL704A0 *dbof is ...
is=WP04A1P tb=IWP31BXG tb OA1P.TWP301A129 ix IWP301A229 *dbof i...
is=XC01A1P tb=IXC21#LO tb OA1P07.TXC200A1 ix IXC200A10 *dbof is...
is=XC01A1P tb=IXC21ANQ tb OA1P03.TXC200A1 ix IXC200A10 *dbof is...
is=XC01A1P tb=IXC21NH4 tb OA1P05.TXC200A1 ix IXC200A10 *dbof is...
is=XC01A1P tb=IXC21SX6 tb OA1P09.TXC200A1 ix IXC200A10 *dbof is...
is=XC01A1P tb=IXC211CP tb OA1P06.TXC200A1 ix IXC200A10 *dbof is...
is=XC01A1P tb=IXC500A1 tb OA1P.TXC500A1 ix IXC500A1 *dbof is ...
is=XC01A1P tb=IXC514A0 tb OA1P.TXC514A1 ix IXC514A0 *dbof is ...
is=AV15A1P tb=IAV104A0 tb OA1P.TAV104A1 ix IAV104A0 *dbof is ...
is=BE01A1P tb=IBE003A0 tb OA1P.TBE003A1 ix IBE003A0 *dbof is ...
is=CZ03A1P tb=ICZ443A0 tb OA1P.TCZ443A1 ix ICZ443A0 *dbof is ...
is=DB2MAPP1 tb=IXRQ1OC6 tb S100447.QR20810P ix IX_QR20810P *dbof...
is=DP02A1P tb=IDP021A4 tb OA1P.TDP021A1 ix IDP021A4 *dbof is ...
is=KE01A1P tb=IKE858H2 tb OA1P.TKE858H1 ix IKE858H2 *dbof is ...
is=NZ06A1P tb=INZ262A1 tb OA1P.TNZ262A1 ix INZ262A1 *dbof is ...
is=SAMT2 tb=INDRSRGM tb SAMRELT.RMS ix IND_SRGMEM *dbof is ...
is=VV24A1P tb=VTXI11Z1 tb VDPS2.VTINSTRUMENT ix VTXINSTRUMENT1 ...
$#out 20150623 16:02:32
BE01A1P.A010A01 OA1P01.TBE010A1 INCLUDE TABLESPACE BE01A1P.A010A01 PARTLEV...
BE01A1P.A010A02 OA1P02.TBE010A1 INCLUDE TABLESPACE BE01A1P.A010A02 PARTLEV...
BE01A1P.A010A03 OA1P03.TBE010A1 INCLUDE TABLESPACE BE01A1P.A010A03 PARTLEV...
BE01A1P.A010A04 OA1P04.TBE010A1 INCLUDE TABLESPACE BE01A1P.A010A04 PARTLEV...
RA01A1P.A001A .TRA001A1 INCLUDE TABLESPACE RA01A1P.A001A PARTLEVEL --T...
RA01A1P.A060A .TRA060A1 INCLUDE TABLESPACE RA01A1P.A060A PARTLEVEL --T...
RA01A1P.A080A .TRA080A1 INCLUDE TABLESPACE RA01A1P.A080A PARTLEVEL --T...
RA01A1P.A081A .TRA081A1 INCLUDE TABLESPACE RA01A1P.A081A PARTLEVEL --T...
RA01A1P.A082A .TRA082A1 INCLUDE TABLESPACE RA01A1P.A082A PARTLEVEL --T...
RA01A1P.A083A .TRA083A1 INCLUDE TABLESPACE RA01A1P.A083A PARTLEVEL --T...
BS01A1P.A003A .TBS003A1 INCLUDE TABLESPACE BS01A1P.A003A PARTLEVEL --T...
CD01A1P.A031A .TCD031 INCLUDE TABLESPACE CD01A1P.A031A PARTLEVEL --TCD031
CD01A1P.A041A .TCD041 INCLUDE TABLESPACE CD01A1P.A041A PARTLEVEL --TCD041
CD01A1P.A061A .TCD061 INCLUDE TABLESPACE CD01A1P.A061A PARTLEVEL --TCD061
CD01A1P.A091A .TCD091 INCLUDE TABLESPACE CD01A1P.A091A PARTLEVEL --TCD091
CD01A1P.A111A .TCD111 INCLUDE TABLESPACE CD01A1P.A111A PARTLEVEL --TCD111
CD01A1P.A131A .TCD131 INCLUDE TABLESPACE CD01A1P.A131A PARTLEVEL --TCD131
CD01A1P.A231A .TCD231 INCLUDE TABLESPACE CD01A1P.A231A PARTLEVEL --TCD231
CD01A1P.A251A .TCD251 INCLUDE TABLESPACE CD01A1P.A251A PARTLEVEL --TCD251
CD01A1P.A291A .TCD291 INCLUDE TABLESPACE CD01A1P.A291A PARTLEVEL --TCD291
CD01A1P.A301A .TCD301 INCLUDE TABLESPACE CD01A1P.A301A PARTLEVEL --TCD301
CD01A1P.A341A .TCD341 INCLUDE TABLESPACE CD01A1P.A341A PARTLEVEL --TCD341
CD01A1P.A391A .TCD391 INCLUDE TABLESPACE CD01A1P.A391A PARTLEVEL --TCD391
CD01A1P.A451A .TCD451 INCLUDE TABLESPACE CD01A1P.A451A PARTLEVEL --TCD451
CD01A1P.A771A .TCD771 INCLUDE TABLESPACE CD01A1P.A771A PARTLEVEL --TCD771
CD03A1P.A100P .TCD100A1 INCLUDE TABLESPACE CD03A1P.A100P PARTLEVEL --T...
CD03A1P.A100B .TCD100B1 INCLUDE TABLESPACE CD03A1P.A100B PARTLEVEL --T...
CD03A1P.A140A .TCD140A1 INCLUDE TABLESPACE CD03A1P.A140A PARTLEVEL --T...
CD03A1P.A140H .TCD140H1 INCLUDE TABLESPACE CD03A1P.A140H PARTLEVEL --T...
CD03A1P.A181A .TCD181A1 INCLUDE TABLESPACE CD03A1P.A181A PARTLEVEL --T...
CD03A1P.A181H .TCD181H1 INCLUDE TABLESPACE CD03A1P.A181H PARTLEVEL --T...
CD03A1P.A182A .TCD182A1 INCLUDE TABLESPACE CD03A1P.A182A PARTLEVEL --T...
CD03A1P.A182H .TCD182H1 INCLUDE TABLESPACE CD03A1P.A182H PARTLEVEL --T...
CD01A1P.A306A .TCD306A1 INCLUDE TABLESPACE CD01A1P.A306A PARTLEVEL --T...
CD03A1P.A380A .TCD380A1 INCLUDE TABLESPACE CD03A1P.A380A PARTLEVEL --T...
CD02A1P.A470A .TCD470A1 INCLUDE TABLESPACE CD02A1P.A470A PARTLEVEL --T...
CD02A1P.A616A .TCD616A1 INCLUDE TABLESPACE CD02A1P.A616A PARTLEVEL --T...
CD02A1P.A617A .TCD617A1 INCLUDE TABLESPACE CD02A1P.A617A PARTLEVEL --T...
CD02A1P.A619A .TCD619A1 INCLUDE TABLESPACE CD02A1P.A619A PARTLEVEL --T...
CD03A1P.A630A .TCD630A1 INCLUDE TABLESPACE CD03A1P.A630A PARTLEVEL --T...
CD03A1P.A633A .TCD633A1 INCLUDE TABLESPACE CD03A1P.A633A PARTLEVEL --T...
CD03A1P.A634A .TCD634A1 INCLUDE TABLESPACE CD03A1P.A634A PARTLEVEL --T...
CD03A1P.A635A .TCD635A1 INCLUDE TABLESPACE CD03A1P.A635A PARTLEVEL --T...
CK01A1P.A025A .TCK025A1 INCLUDE TABLESPACE CK01A1P.A025A PARTLEVEL --T...
CK01A1P.A030A .TCK030A1 INCLUDE TABLESPACE CK01A1P.A030A PARTLEVEL --T...
CK01A1P.A031A .TCK031A1 INCLUDE TABLESPACE CK01A1P.A031A PARTLEVEL --T...
CK01A1P.A078A .TCK078A1 INCLUDE TABLESPACE CK01A1P.A078A PARTLEVEL --T...
CK01A1P.A083A .TCK083A1 INCLUDE TABLESPACE CK01A1P.A083A PARTLEVEL --T...
CK01A1P.A085A .TCK085A1 INCLUDE TABLESPACE CK01A1P.A085A PARTLEVEL --T...
CT02A1P.A152A .TCT152A1 INCLUDE TABLESPACE CT02A1P.A152A PARTLEVEL --T...
CT01G1P.A152A .TCT152G1 INCLUDE TABLESPACE CT01G1P.A152A PARTLEVEL --T...
CT02A1P.A153A .TCT153A1 INCLUDE TABLESPACE CT02A1P.A153A PARTLEVEL --T...
CT01G1P.A153A .TCT153G1 INCLUDE TABLESPACE CT01G1P.A153A PARTLEVEL --T...
CT02A1P.A202A .TCT202A1 INCLUDE TABLESPACE CT02A1P.A202A PARTLEVEL --T...
CT01G1P.A202A .TCT202G1 INCLUDE TABLESPACE CT01G1P.A202A PARTLEVEL --T...
CT02A1P.A203A .TCT203A1 INCLUDE TABLESPACE CT02A1P.A203A PARTLEVEL --T...
CT01G1P.A203A .TCT203G1 INCLUDE TABLESPACE CT01G1P.A203A PARTLEVEL --T...
CT02A1P.A206A .TCT206A1 INCLUDE TABLESPACE CT02A1P.A206A PARTLEVEL --T...
CT01G1P.A206A .TCT206G1 INCLUDE TABLESPACE CT01G1P.A206A PARTLEVEL --T...
CT02A1P.A217A .TCT217A1 INCLUDE TABLESPACE CT02A1P.A217A PARTLEVEL --T...
CT01G1P.A217A .TCT217G1 INCLUDE TABLESPACE CT01G1P.A217A PARTLEVEL --T...
CT02A1P.A251A .TCT251A1 INCLUDE TABLESPACE CT02A1P.A251A PARTLEVEL --T...
CT01G1P.A251A .TCT251G1 INCLUDE TABLESPACE CT01G1P.A251A PARTLEVEL --T...
CT02A1P.A253A .TCT253A1 INCLUDE TABLESPACE CT02A1P.A253A PARTLEVEL --T...
CT01G1P.A253A .TCT253G1 INCLUDE TABLESPACE CT01G1P.A253A PARTLEVEL --T...
CT02A1P.A254A .TCT254A1 INCLUDE TABLESPACE CT02A1P.A254A PARTLEVEL --T...
CT01G1P.A254A .TCT254G1 INCLUDE TABLESPACE CT01G1P.A254A PARTLEVEL --T...
CT02A1P.A256A .TCT256A1 INCLUDE TABLESPACE CT02A1P.A256A PARTLEVEL --T...
CT01G1P.A256A .TCT256G1 INCLUDE TABLESPACE CT01G1P.A256A PARTLEVEL --T...
CT02A1P.A257A .TCT257A1 INCLUDE TABLESPACE CT02A1P.A257A PARTLEVEL --T...
CT01G1P.A257A .TCT257G1 INCLUDE TABLESPACE CT01G1P.A257A PARTLEVEL --T...
CT02A1P.A258A .TCT258A1 INCLUDE TABLESPACE CT02A1P.A258A PARTLEVEL --T...
CT01G1P.A258A .TCT258G1 INCLUDE TABLESPACE CT01G1P.A258A PARTLEVEL --T...
CT02A1P.A259A .TCT259A1 INCLUDE TABLESPACE CT02A1P.A259A PARTLEVEL --T...
CT01G1P.A259A .TCT259G1 INCLUDE TABLESPACE CT01G1P.A259A PARTLEVEL --T...
CT02A1P.A261A .TCT261A1 INCLUDE TABLESPACE CT02A1P.A261A PARTLEVEL --T...
CT01G1P.A261A .TCT261G1 INCLUDE TABLESPACE CT01G1P.A261A PARTLEVEL --T...
CT02A1P.A301A .TCT301A1 INCLUDE TABLESPACE CT02A1P.A301A PARTLEVEL --T...
CT01G1P.A301A .TCT301G1 INCLUDE TABLESPACE CT01G1P.A301A PARTLEVEL --T...
CT02A1P.A305A .TCT305A1 INCLUDE TABLESPACE CT02A1P.A305A PARTLEVEL --T...
CT01G1P.A305A .TCT305G1 INCLUDE TABLESPACE CT01G1P.A305A PARTLEVEL --T...
CT02A1P.A306A .TCT306A1 INCLUDE TABLESPACE CT02A1P.A306A PARTLEVEL --T...
CT01G1P.A306A .TCT306G1 INCLUDE TABLESPACE CT01G1P.A306A PARTLEVEL --T...
CT02A1P.A308A .TCT308A1 INCLUDE TABLESPACE CT02A1P.A308A PARTLEVEL --T...
CT01G1P.A308A .TCT308G1 INCLUDE TABLESPACE CT01G1P.A308A PARTLEVEL --T...
CT02A1P.A309A .TCT309A1 INCLUDE TABLESPACE CT02A1P.A309A PARTLEVEL --T...
CT01G1P.A309A .TCT309G1 INCLUDE TABLESPACE CT01G1P.A309A PARTLEVEL --T...
CT02A1P.A353A .TCT353A1 INCLUDE TABLESPACE CT02A1P.A353A PARTLEVEL --T...
CT01G1P.A353A .TCT353G1 INCLUDE TABLESPACE CT01G1P.A353A PARTLEVEL --T...
CT02A1P.A356A .TCT356A1 INCLUDE TABLESPACE CT02A1P.A356A PARTLEVEL --T...
CT01G1P.A356A .TCT356G1 INCLUDE TABLESPACE CT01G1P.A356A PARTLEVEL --T...
CT02A1P.A400A .TCT400A1 INCLUDE TABLESPACE CT02A1P.A400A PARTLEVEL --T...
CT01G1P.A400A .TCT400G1 INCLUDE TABLESPACE CT01G1P.A400A PARTLEVEL --T...
CY02A1P.A056A .TCY056A1 INCLUDE TABLESPACE CY02A1P.A056A PARTLEVEL --T...
CZ08A1P.A025A .TCZ025A1 INCLUDE TABLESPACE CZ08A1P.A025A PARTLEVEL --T...
CZ18A1P.A025A .TCZ025E1 INCLUDE TABLESPACE CZ18A1P.A025A PARTLEVEL --T...
CZ08G1P.A025A .TCZ025G1 INCLUDE TABLESPACE CZ08G1P.A025A PARTLEVEL --T...
CZ08A1P.A100A .TCZ100A1 INCLUDE TABLESPACE CZ08A1P.A100A PARTLEVEL --T...
CZ18A1P.A100A .TCZ100E1 INCLUDE TABLESPACE CZ18A1P.A100A PARTLEVEL --T...
CZ08G1P.A100A .TCZ100G1 INCLUDE TABLESPACE CZ08G1P.A100A PARTLEVEL --T...
CZ08A1P.A101A .TCZ101A1 INCLUDE TABLESPACE CZ08A1P.A101A PARTLEVEL --T...
CZ18A1P.A101A .TCZ101E1 INCLUDE TABLESPACE CZ18A1P.A101A PARTLEVEL --T...
CZ08G1P.A101A .TCZ101G1 INCLUDE TABLESPACE CZ08G1P.A101A PARTLEVEL --T...
CZ08A1P.A103A .TCZ103A1 INCLUDE TABLESPACE CZ08A1P.A103A PARTLEVEL --T...
CZ18A1P.A103A .TCZ103E1 INCLUDE TABLESPACE CZ18A1P.A103A PARTLEVEL --T...
CZ08G1P.A103A .TCZ103G1 INCLUDE TABLESPACE CZ08G1P.A103A PARTLEVEL --T...
CZ08A1P.A106A .TCZ106A1 INCLUDE TABLESPACE CZ08A1P.A106A PARTLEVEL --T...
CZ18A1P.A106A .TCZ106E1 INCLUDE TABLESPACE CZ18A1P.A106A PARTLEVEL --T...
CZ08G1P.A106A .TCZ106G1 INCLUDE TABLESPACE CZ08G1P.A106A PARTLEVEL --T...
CZ07A1P.A191A .TCZ191A1 INCLUDE TABLESPACE CZ07A1P.A191A PARTLEVEL --T...
CZ07G1P.A191A .TCZ191G1 INCLUDE TABLESPACE CZ07G1P.A191A PARTLEVEL --T...
CZ03A1P.A235A .TCZ235A1 INCLUDE TABLESPACE CZ03A1P.A235A PARTLEVEL --T...
CZ03G1P.A235A .TCZ235G1 INCLUDE TABLESPACE CZ03G1P.A235A PARTLEVEL --T...
CZ03A1P.A236A .TCZ236A1 INCLUDE TABLESPACE CZ03A1P.A236A PARTLEVEL --T...
CZ03G1P.A236A .TCZ236G1 INCLUDE TABLESPACE CZ03G1P.A236A PARTLEVEL --T...
CZ14A1P.A250A .TCZ250A1 INCLUDE TABLESPACE CZ14A1P.A250A PARTLEVEL --T...
CZ14G1P.A250A .TCZ250G1 INCLUDE TABLESPACE CZ14G1P.A250A PARTLEVEL --T...
CZ14A1P.A251A .TCZ251A1 INCLUDE TABLESPACE CZ14A1P.A251A PARTLEVEL --T...
CZ14G1P.A251A .TCZ251G1 INCLUDE TABLESPACE CZ14G1P.A251A PARTLEVEL --T...
CZ03A1P.A300A .TCZ300A1 INCLUDE TABLESPACE CZ03A1P.A300A PARTLEVEL --T...
CZ03A1P.A313A .TCZ313A1 INCLUDE TABLESPACE CZ03A1P.A313A PARTLEVEL --T...
CZ03G1P.A313A .TCZ313G1 INCLUDE TABLESPACE CZ03G1P.A313A PARTLEVEL --T...
CZ03A1P.A315A .TCZ315A1 INCLUDE TABLESPACE CZ03A1P.A315A PARTLEVEL --T...
CZ03G1P.A315A .TCZ315G1 INCLUDE TABLESPACE CZ03G1P.A315A PARTLEVEL --T...
CZ03A1P.A319A .TCZ319A1 INCLUDE TABLESPACE CZ03A1P.A319A PARTLEVEL --T...
CZ03G1P.A319A .TCZ319G1 INCLUDE TABLESPACE CZ03G1P.A319A PARTLEVEL --T...
CZ03A1P.A321A .TCZ321A1 INCLUDE TABLESPACE CZ03A1P.A321A PARTLEVEL --T...
CZ03G1P.A321A .TCZ321G1 INCLUDE TABLESPACE CZ03G1P.A321A PARTLEVEL --T...
CZ03A1P.A323A .TCZ323A1 INCLUDE TABLESPACE CZ03A1P.A323A PARTLEVEL --T...
CZ03G1P.A323A .TCZ323G1 INCLUDE TABLESPACE CZ03G1P.A323A PARTLEVEL --T...
CZ03A1P.A327A .TCZ327A1 INCLUDE TABLESPACE CZ03A1P.A327A PARTLEVEL --T...
CZ03G1P.A327A .TCZ327G1 INCLUDE TABLESPACE CZ03G1P.A327A PARTLEVEL --T...
CZ03A1P.A331A .TCZ331A1 INCLUDE TABLESPACE CZ03A1P.A331A PARTLEVEL --T...
CZ03G1P.A331A .TCZ331G1 INCLUDE TABLESPACE CZ03G1P.A331A PARTLEVEL --T...
CZ03A1P.A340A .TCZ340A1 INCLUDE TABLESPACE CZ03A1P.A340A PARTLEVEL --T...
CZ03A1P.A384A .TCZ384A1 INCLUDE TABLESPACE CZ03A1P.A384A PARTLEVEL --T...
CZ03G1P.A384A .TCZ384G1 INCLUDE TABLESPACE CZ03G1P.A384A PARTLEVEL --T...
CZ03A1P.A386A .TCZ386A1 INCLUDE TABLESPACE CZ03A1P.A386A PARTLEVEL --T...
CZ03G1P.A386A .TCZ386G1 INCLUDE TABLESPACE CZ03G1P.A386A PARTLEVEL --T...
CZ03A1P.A421A .TCZ421A1 INCLUDE TABLESPACE CZ03A1P.A421A PARTLEVEL --T...
CZ03G1P.A421A .TCZ421G1 INCLUDE TABLESPACE CZ03G1P.A421A PARTLEVEL --T...
CZ03A1P.A428A .TCZ428A1 INCLUDE TABLESPACE CZ03A1P.A428A PARTLEVEL --T...
CZ03G1P.A428A .TCZ428G1 INCLUDE TABLESPACE CZ03G1P.A428A PARTLEVEL --T...
CZ03A1P.A429A .TCZ429A1 INCLUDE TABLESPACE CZ03A1P.A429A PARTLEVEL --T...
CZ03G1P.A429A .TCZ429G1 INCLUDE TABLESPACE CZ03G1P.A429A PARTLEVEL --T...
CZ03A1P.A432A .TCZ432A1 INCLUDE TABLESPACE CZ03A1P.A432A PARTLEVEL --T...
CZ03A1P.A433A .TCZ433A1 INCLUDE TABLESPACE CZ03A1P.A433A PARTLEVEL --T...
CZ04A1P.A500A .TCZ500A1 INCLUDE TABLESPACE CZ04A1P.A500A PARTLEVEL --T...
CZ04A1P.A513A .TCZ513A1 INCLUDE TABLESPACE CZ04A1P.A513A PARTLEVEL --T...
CZ04A1P.A515A .TCZ515A1 INCLUDE TABLESPACE CZ04A1P.A515A PARTLEVEL --T...
CZ04A1P.A519A .TCZ519A1 INCLUDE TABLESPACE CZ04A1P.A519A PARTLEVEL --T...
CZ04A1P.A521A .TCZ521A1 INCLUDE TABLESPACE CZ04A1P.A521A PARTLEVEL --T...
CZ04A1P.A584A .TCZ584A1 INCLUDE TABLESPACE CZ04A1P.A584A PARTLEVEL --T...
CZ04A1P.A621A .TCZ621A1 INCLUDE TABLESPACE CZ04A1P.A621A PARTLEVEL --T...
CZ13A1P.A707A .TCZ707A1 INCLUDE TABLESPACE CZ13A1P.A707A PARTLEVEL --T...
CZ13A1P.A708A .TCZ708A1 INCLUDE TABLESPACE CZ13A1P.A708A PARTLEVEL --T...
DB01A1P.A201A .TDB201A1 INCLUDE TABLESPACE DB01A1P.A201A PARTLEVEL --T...
DE02A1P.A023A .TDE023A1 INCLUDE TABLESPACE DE02A1P.A023A PARTLEVEL --T...
ED02A1P.A023A .TED023A1 INCLUDE TABLESPACE ED02A1P.A023A PARTLEVEL --T...
FC01A1P.A001A .TFC001A0 INCLUDE TABLESPACE FC01A1P.A001A PARTLEVEL --T...
KC01A1P.A001A .TKC001A1 INCLUDE TABLESPACE KC01A1P.A001A PARTLEVEL --T...
KC01A1P.A002A .TKC002A1 INCLUDE TABLESPACE KC01A1P.A002A PARTLEVEL --T...
KC01A1P.A003A .TKC003A1 INCLUDE TABLESPACE KC01A1P.A003A PARTLEVEL --T...
KC01A1P.A010A .TKC010A1 INCLUDE TABLESPACE KC01A1P.A010A PARTLEVEL --T...
MF03A1P.A009A .TMF009A1 INCLUDE TABLESPACE MF03A1P.A009A PARTLEVEL --T...
MF01A1P.A101A .TMF101A1 INCLUDE TABLESPACE MF01A1P.A101A PARTLEVEL --T...
MF01A1P.A103A .TMF103A1 INCLUDE TABLESPACE MF01A1P.A103A PARTLEVEL --T...
MF01A1P.A104A .TMF104A1 INCLUDE TABLESPACE MF01A1P.A104A PARTLEVEL --T...
NI02A1P.A100A .TNI100A101A INCLUDE TABLESPACE NI02A1P.A100A PARTLEVEL ...
NI02A1P.A609A .TNI609A101A INCLUDE TABLESPACE NI02A1P.A609A PARTLEVEL ...
NZ03A1P.A021A .TNZ021A1 INCLUDE TABLESPACE NZ03A1P.A021A PARTLEVEL --T...
NZ02A1P.A150A .TNZ150A1 INCLUDE TABLESPACE NZ02A1P.A150A PARTLEVEL --T...
NZ02A1P.A151A .TNZ151A1 INCLUDE TABLESPACE NZ02A1P.A151A PARTLEVEL --T...
NZ02A1P.A152A .TNZ152A1 INCLUDE TABLESPACE NZ02A1P.A152A PARTLEVEL --T...
NZ01A1P.A202A .TNZ202A1 INCLUDE TABLESPACE NZ01A1P.A202A PARTLEVEL --T...
NZ01A1P.A204A .TNZ204A1 INCLUDE TABLESPACE NZ01A1P.A204A PARTLEVEL --T...
NZ01A1P.A209A .TNZ209A1 INCLUDE TABLESPACE NZ01A1P.A209A PARTLEVEL --T...
NZ01A1P.A212A .TNZ212A1 INCLUDE TABLESPACE NZ01A1P.A212A PARTLEVEL --T...
NZ01A1P.A252A .TNZ252A1 INCLUDE TABLESPACE NZ01A1P.A252A PARTLEVEL --T...
NZ01A1P.A258A .TNZ258A1 INCLUDE TABLESPACE NZ01A1P.A258A PARTLEVEL --T...
RM01A1P.A003A .TRM003A1 INCLUDE TABLESPACE RM01A1P.A003A PARTLEVEL --T...
RM01A1P.A010A .TRM010A1 INCLUDE TABLESPACE RM01A1P.A010A PARTLEVEL --T...
RM01A1P.A020A .TRM020A1 INCLUDE TABLESPACE RM01A1P.A020A PARTLEVEL --T...
RM01A1P.A021A .TRM021A1 INCLUDE TABLESPACE RM01A1P.A021A PARTLEVEL --T...
RV01A1P.A100A .TRV100A1 INCLUDE TABLESPACE RV01A1P.A100A PARTLEVEL --T...
RV01A1P.A110A .TRV110A1 INCLUDE TABLESPACE RV01A1P.A110A PARTLEVEL --T...
RV01A1P.A120A .TRV120A1 INCLUDE TABLESPACE RV01A1P.A120A PARTLEVEL --T...
RV01A1P.A130A .TRV130A1 INCLUDE TABLESPACE RV01A1P.A130A PARTLEVEL --T...
RV01A1P.A140A .TRV140A1 INCLUDE TABLESPACE RV01A1P.A140A PARTLEVEL --T...
RV01A1P.A221A .TRV221A1 INCLUDE TABLESPACE RV01A1P.A221A PARTLEVEL --T...
RV01A1P.A301A .TRV301A1 INCLUDE TABLESPACE RV01A1P.A301A PARTLEVEL --T...
RV01A1P.A431A .TRV431A1 INCLUDE TABLESPACE RV01A1P.A431A PARTLEVEL --T...
RV01A1P.A451A .TRV451A1 INCLUDE TABLESPACE RV01A1P.A451A PARTLEVEL --T...
RV01A1P.A501A .TRV501A1 INCLUDE TABLESPACE RV01A1P.A501A PARTLEVEL --T...
RV01A1P.A600A .TRV600A1 INCLUDE TABLESPACE RV01A1P.A600A PARTLEVEL --T...
UU02A1P.A130A .TUU130A2 INCLUDE TABLESPACE UU02A1P.A130A PARTLEVEL --T...
VD01A1P.A002A .TVD002A1 INCLUDE TABLESPACE VD01A1P.A002A PARTLEVEL --T...
VP03A1P.A009A .TVP009A1 INCLUDE TABLESPACE VP03A1P.A009A PARTLEVEL --T...
VP02A1P.A020A .TVP020A1 INCLUDE TABLESPACE VP02A1P.A020A PARTLEVEL --T...
VP02H1P.A020H .TVP020H1 INCLUDE TABLESPACE VP02H1P.A020H PARTLEVEL --T...
VP02A1P.A023A .TVP023A1 INCLUDE TABLESPACE VP02A1P.A023A PARTLEVEL --T...
VP02H1P.A023H .TVP023H1 INCLUDE TABLESPACE VP02H1P.A023H PARTLEVEL --T...
VP02A1P.A025A .TVP025A1 INCLUDE TABLESPACE VP02A1P.A025A PARTLEVEL --T...
VP02H1P.A025H .TVP025H1 INCLUDE TABLESPACE VP02H1P.A025H PARTLEVEL --T...
VP02A1P.A036A .TVP036A1 INCLUDE TABLESPACE VP02A1P.A036A PARTLEVEL --T...
VP02H1P.A036H .TVP036H1 INCLUDE TABLESPACE VP02H1P.A036H PARTLEVEL --T...
WF01A1P.A003A .TWF003A1 INCLUDE TABLESPACE WF01A1P.A003A PARTLEVEL --T...
WF01A1P.A032A .TWF032A1 INCLUDE TABLESPACE WF01A1P.A032A PARTLEVEL --T...
WF01A1P.A034A .TWF034A1 INCLUDE TABLESPACE WF01A1P.A034A PARTLEVEL --T...
WF01A1P.A035A .TWF035A1 INCLUDE TABLESPACE WF01A1P.A035A PARTLEVEL --T...
WF01A1P.A051A .TWF051A1 INCLUDE TABLESPACE WF01A1P.A051A PARTLEVEL --T...
WF01A1P.A052A .TWF052A1 INCLUDE TABLESPACE WF01A1P.A052A PARTLEVEL --T...
WF01A1P.A073A .TWF073A1 INCLUDE TABLESPACE WF01A1P.A073A PARTLEVEL --T...
WF01A1P.A076A .TWF076A1 INCLUDE TABLESPACE WF01A1P.A076A PARTLEVEL --T...
WF01A1P.A080A .TWF080A1 INCLUDE TABLESPACE WF01A1P.A080A PARTLEVEL --T...
WF01A1P.A082A .TWF082A1 INCLUDE TABLESPACE WF01A1P.A082A PARTLEVEL --T...
WF01A1P.A083A .TWF083A1 INCLUDE TABLESPACE WF01A1P.A083A PARTLEVEL --T...
WF01A1P.A086A .TWF086A1 INCLUDE TABLESPACE WF01A1P.A086A PARTLEVEL --T...
WF01A1P.A088A .TWF088A1 INCLUDE TABLESPACE WF01A1P.A088A PARTLEVEL --T...
WF01A1P.A090A .TWF090A1 INCLUDE TABLESPACE WF01A1P.A090A PARTLEVEL --T...
WF01A1P.A091A .TWF091A1 INCLUDE TABLESPACE WF01A1P.A091A PARTLEVEL --T...
WG01A1P.A100A .TWG100A1 INCLUDE TABLESPACE WG01A1P.A100A PARTLEVEL --T...
WG01A1P.A101A .TWG101A1 INCLUDE TABLESPACE WG01A1P.A101A PARTLEVEL --T...
WG01A1P.A200A .TWG200A1 INCLUDE TABLESPACE WG01A1P.A200A PARTLEVEL --T...
WG01A1P.A400A .TWG400A1 INCLUDE TABLESPACE WG01A1P.A400A PARTLEVEL --T...
WG01A1P.A410A .TWG410A1 INCLUDE TABLESPACE WG01A1P.A410A PARTLEVEL --T...
WL09A1P.A901A .TWL901A1 INCLUDE TABLESPACE WL09A1P.A901A PARTLEVEL --T...
WM01A1P.A005A .TWM005A1 INCLUDE TABLESPACE WM01A1P.A005A PARTLEVEL --T...
WR01A1P.A002A .TWR002A1 INCLUDE TABLESPACE WR01A1P.A002A PARTLEVEL --T...
$#out 20150623 16:01:16
BE01A1P.A010A01 OA1P01.TBE010A1 INCLUDE TABLESPACE BE01A1P.A010A01 PARTLEV...
BE01A1P.A010A02 OA1P02.TBE010A1 INCLUDE TABLESPACE BE01A1P.A010A02 PARTLEV...
BE01A1P.A010A03 OA1P03.TBE010A1 INCLUDE TABLESPACE BE01A1P.A010A03 PARTLEV...
BE01A1P.A010A04 OA1P04.TBE010A1 INCLUDE TABLESPACE BE01A1P.A010A04 PARTLEV...
RA01A1P.A001A .TRA001A1 INCLUDE TABLESPACE RA01A1P.A001A PARTLEVEL --T...
RA01A1P.A060A .TRA060A1 INCLUDE TABLESPACE RA01A1P.A060A PARTLEVEL --T...
RA01A1P.A080A .TRA080A1 INCLUDE TABLESPACE RA01A1P.A080A PARTLEVEL --T...
RA01A1P.A081A .TRA081A1 INCLUDE TABLESPACE RA01A1P.A081A PARTLEVEL --T...
RA01A1P.A082A .TRA082A1 INCLUDE TABLESPACE RA01A1P.A082A PARTLEVEL --T...
RA01A1P.A083A .TRA083A1 INCLUDE TABLESPACE RA01A1P.A083A PARTLEVEL --T...
BS01A1P.A003A .TBS003A1 INCLUDE TABLESPACE BS01A1P.A003A PARTLEVEL --T...
CD01A1P.A031A .TCD031 INCLUDE TABLESPACE CD01A1P.A031A PARTLEVEL --TCD031
CD01A1P.A041A .TCD041 INCLUDE TABLESPACE CD01A1P.A041A PARTLEVEL --TCD041
CD01A1P.A061A .TCD061 INCLUDE TABLESPACE CD01A1P.A061A PARTLEVEL --TCD061
CD01A1P.A091A .TCD091 INCLUDE TABLESPACE CD01A1P.A091A PARTLEVEL --TCD091
CD01A1P.A111A .TCD111 INCLUDE TABLESPACE CD01A1P.A111A PARTLEVEL --TCD111
CD01A1P.A131A .TCD131 INCLUDE TABLESPACE CD01A1P.A131A PARTLEVEL --TCD131
CD01A1P.A231A .TCD231 INCLUDE TABLESPACE CD01A1P.A231A PARTLEVEL --TCD231
CD01A1P.A251A .TCD251 INCLUDE TABLESPACE CD01A1P.A251A PARTLEVEL --TCD251
CD01A1P.A291A .TCD291 INCLUDE TABLESPACE CD01A1P.A291A PARTLEVEL --TCD291
CD01A1P.A301A .TCD301 INCLUDE TABLESPACE CD01A1P.A301A PARTLEVEL --TCD301
CD01A1P.A341A .TCD341 INCLUDE TABLESPACE CD01A1P.A341A PARTLEVEL --TCD341
CD01A1P.A391A .TCD391 INCLUDE TABLESPACE CD01A1P.A391A PARTLEVEL --TCD391
CD01A1P.A451A .TCD451 INCLUDE TABLESPACE CD01A1P.A451A PARTLEVEL --TCD451
CD01A1P.A771A .TCD771 INCLUDE TABLESPACE CD01A1P.A771A PARTLEVEL --TCD771
CD03A1P.A100P .TCD100A1 INCLUDE TABLESPACE CD03A1P.A100P PARTLEVEL --T...
CD03A1P.A100B .TCD100B1 INCLUDE TABLESPACE CD03A1P.A100B PARTLEVEL --T...
CD03A1P.A140A .TCD140A1 INCLUDE TABLESPACE CD03A1P.A140A PARTLEVEL --T...
CD03A1P.A140H .TCD140H1 INCLUDE TABLESPACE CD03A1P.A140H PARTLEVEL --T...
CD03A1P.A181A .TCD181A1 INCLUDE TABLESPACE CD03A1P.A181A PARTLEVEL --T...
CD03A1P.A181H .TCD181H1 INCLUDE TABLESPACE CD03A1P.A181H PARTLEVEL --T...
CD03A1P.A182A .TCD182A1 INCLUDE TABLESPACE CD03A1P.A182A PARTLEVEL --T...
CD03A1P.A182H .TCD182H1 INCLUDE TABLESPACE CD03A1P.A182H PARTLEVEL --T...
CD01A1P.A306A .TCD306A1 INCLUDE TABLESPACE CD01A1P.A306A PARTLEVEL --T...
CD03A1P.A380A .TCD380A1 INCLUDE TABLESPACE CD03A1P.A380A PARTLEVEL --T...
CD02A1P.A470A .TCD470A1 INCLUDE TABLESPACE CD02A1P.A470A PARTLEVEL --T...
CD02A1P.A616A .TCD616A1 INCLUDE TABLESPACE CD02A1P.A616A PARTLEVEL --T...
CD02A1P.A617A .TCD617A1 INCLUDE TABLESPACE CD02A1P.A617A PARTLEVEL --T...
CD02A1P.A619A .TCD619A1 INCLUDE TABLESPACE CD02A1P.A619A PARTLEVEL --T...
CD03A1P.A630A .TCD630A1 INCLUDE TABLESPACE CD03A1P.A630A PARTLEVEL --T...
CD03A1P.A633A .TCD633A1 INCLUDE TABLESPACE CD03A1P.A633A PARTLEVEL --T...
CD03A1P.A634A .TCD634A1 INCLUDE TABLESPACE CD03A1P.A634A PARTLEVEL --T...
CD03A1P.A635A .TCD635A1 INCLUDE TABLESPACE CD03A1P.A635A PARTLEVEL --T...
CK01A1P.A025A .TCK025A1 INCLUDE TABLESPACE CK01A1P.A025A PARTLEVEL --T...
CK01A1P.A030A .TCK030A1 INCLUDE TABLESPACE CK01A1P.A030A PARTLEVEL --T...
CK01A1P.A031A .TCK031A1 INCLUDE TABLESPACE CK01A1P.A031A PARTLEVEL --T...
CK01A1P.A078A .TCK078A1 INCLUDE TABLESPACE CK01A1P.A078A PARTLEVEL --T...
CK01A1P.A083A .TCK083A1 INCLUDE TABLESPACE CK01A1P.A083A PARTLEVEL --T...
CK01A1P.A085A .TCK085A1 INCLUDE TABLESPACE CK01A1P.A085A PARTLEVEL --T...
CT02A1P.A152A .TCT152A1 INCLUDE TABLESPACE CT02A1P.A152A PARTLEVEL --T...
CT01G1P.A152A .TCT152G1 INCLUDE TABLESPACE CT01G1P.A152A PARTLEVEL --T...
CT02A1P.A153A .TCT153A1 INCLUDE TABLESPACE CT02A1P.A153A PARTLEVEL --T...
CT01G1P.A153A .TCT153G1 INCLUDE TABLESPACE CT01G1P.A153A PARTLEVEL --T...
CT02A1P.A202A .TCT202A1 INCLUDE TABLESPACE CT02A1P.A202A PARTLEVEL --T...
CT01G1P.A202A .TCT202G1 INCLUDE TABLESPACE CT01G1P.A202A PARTLEVEL --T...
CT02A1P.A203A .TCT203A1 INCLUDE TABLESPACE CT02A1P.A203A PARTLEVEL --T...
CT01G1P.A203A .TCT203G1 INCLUDE TABLESPACE CT01G1P.A203A PARTLEVEL --T...
CT02A1P.A206A .TCT206A1 INCLUDE TABLESPACE CT02A1P.A206A PARTLEVEL --T...
CT01G1P.A206A .TCT206G1 INCLUDE TABLESPACE CT01G1P.A206A PARTLEVEL --T...
CT02A1P.A217A .TCT217A1 INCLUDE TABLESPACE CT02A1P.A217A PARTLEVEL --T...
CT01G1P.A217A .TCT217G1 INCLUDE TABLESPACE CT01G1P.A217A PARTLEVEL --T...
CT02A1P.A251A .TCT251A1 INCLUDE TABLESPACE CT02A1P.A251A PARTLEVEL --T...
CT01G1P.A251A .TCT251G1 INCLUDE TABLESPACE CT01G1P.A251A PARTLEVEL --T...
CT02A1P.A253A .TCT253A1 INCLUDE TABLESPACE CT02A1P.A253A PARTLEVEL --T...
CT01G1P.A253A .TCT253G1 INCLUDE TABLESPACE CT01G1P.A253A PARTLEVEL --T...
CT02A1P.A254A .TCT254A1 INCLUDE TABLESPACE CT02A1P.A254A PARTLEVEL --T...
CT01G1P.A254A .TCT254G1 INCLUDE TABLESPACE CT01G1P.A254A PARTLEVEL --T...
CT02A1P.A256A .TCT256A1 INCLUDE TABLESPACE CT02A1P.A256A PARTLEVEL --T...
CT01G1P.A256A .TCT256G1 INCLUDE TABLESPACE CT01G1P.A256A PARTLEVEL --T...
CT02A1P.A257A .TCT257A1 INCLUDE TABLESPACE CT02A1P.A257A PARTLEVEL --T...
CT01G1P.A257A .TCT257G1 INCLUDE TABLESPACE CT01G1P.A257A PARTLEVEL --T...
CT02A1P.A258A .TCT258A1 INCLUDE TABLESPACE CT02A1P.A258A PARTLEVEL --T...
CT01G1P.A258A .TCT258G1 INCLUDE TABLESPACE CT01G1P.A258A PARTLEVEL --T...
CT02A1P.A259A .TCT259A1 INCLUDE TABLESPACE CT02A1P.A259A PARTLEVEL --T...
CT01G1P.A259A .TCT259G1 INCLUDE TABLESPACE CT01G1P.A259A PARTLEVEL --T...
CT02A1P.A261A .TCT261A1 INCLUDE TABLESPACE CT02A1P.A261A PARTLEVEL --T...
CT01G1P.A261A .TCT261G1 INCLUDE TABLESPACE CT01G1P.A261A PARTLEVEL --T...
CT02A1P.A301A .TCT301A1 INCLUDE TABLESPACE CT02A1P.A301A PARTLEVEL --T...
CT01G1P.A301A .TCT301G1 INCLUDE TABLESPACE CT01G1P.A301A PARTLEVEL --T...
CT02A1P.A305A .TCT305A1 INCLUDE TABLESPACE CT02A1P.A305A PARTLEVEL --T...
CT01G1P.A305A .TCT305G1 INCLUDE TABLESPACE CT01G1P.A305A PARTLEVEL --T...
CT02A1P.A306A .TCT306A1 INCLUDE TABLESPACE CT02A1P.A306A PARTLEVEL --T...
CT01G1P.A306A .TCT306G1 INCLUDE TABLESPACE CT01G1P.A306A PARTLEVEL --T...
CT02A1P.A308A .TCT308A1 INCLUDE TABLESPACE CT02A1P.A308A PARTLEVEL --T...
CT01G1P.A308A .TCT308G1 INCLUDE TABLESPACE CT01G1P.A308A PARTLEVEL --T...
CT02A1P.A309A .TCT309A1 INCLUDE TABLESPACE CT02A1P.A309A PARTLEVEL --T...
CT01G1P.A309A .TCT309G1 INCLUDE TABLESPACE CT01G1P.A309A PARTLEVEL --T...
CT02A1P.A353A .TCT353A1 INCLUDE TABLESPACE CT02A1P.A353A PARTLEVEL --T...
CT01G1P.A353A .TCT353G1 INCLUDE TABLESPACE CT01G1P.A353A PARTLEVEL --T...
CT02A1P.A356A .TCT356A1 INCLUDE TABLESPACE CT02A1P.A356A PARTLEVEL --T...
CT01G1P.A356A .TCT356G1 INCLUDE TABLESPACE CT01G1P.A356A PARTLEVEL --T...
CT02A1P.A400A .TCT400A1 INCLUDE TABLESPACE CT02A1P.A400A PARTLEVEL --T...
CT01G1P.A400A .TCT400G1 INCLUDE TABLESPACE CT01G1P.A400A PARTLEVEL --T...
CY02A1P.A056A .TCY056A1 INCLUDE TABLESPACE CY02A1P.A056A PARTLEVEL --T...
CZ08A1P.A025A .TCZ025A1 INCLUDE TABLESPACE CZ08A1P.A025A PARTLEVEL --T...
CZ18A1P.A025A .TCZ025E1 INCLUDE TABLESPACE CZ18A1P.A025A PARTLEVEL --T...
CZ08G1P.A025A .TCZ025G1 INCLUDE TABLESPACE CZ08G1P.A025A PARTLEVEL --T...
CZ08A1P.A100A .TCZ100A1 INCLUDE TABLESPACE CZ08A1P.A100A PARTLEVEL --T...
CZ18A1P.A100A .TCZ100E1 INCLUDE TABLESPACE CZ18A1P.A100A PARTLEVEL --T...
CZ08G1P.A100A .TCZ100G1 INCLUDE TABLESPACE CZ08G1P.A100A PARTLEVEL --T...
CZ08A1P.A101A .TCZ101A1 INCLUDE TABLESPACE CZ08A1P.A101A PARTLEVEL --T...
CZ18A1P.A101A .TCZ101E1 INCLUDE TABLESPACE CZ18A1P.A101A PARTLEVEL --T...
CZ08G1P.A101A .TCZ101G1 INCLUDE TABLESPACE CZ08G1P.A101A PARTLEVEL --T...
CZ08A1P.A103A .TCZ103A1 INCLUDE TABLESPACE CZ08A1P.A103A PARTLEVEL --T...
CZ18A1P.A103A .TCZ103E1 INCLUDE TABLESPACE CZ18A1P.A103A PARTLEVEL --T...
CZ08G1P.A103A .TCZ103G1 INCLUDE TABLESPACE CZ08G1P.A103A PARTLEVEL --T...
CZ08A1P.A106A .TCZ106A1 INCLUDE TABLESPACE CZ08A1P.A106A PARTLEVEL --T...
CZ18A1P.A106A .TCZ106E1 INCLUDE TABLESPACE CZ18A1P.A106A PARTLEVEL --T...
CZ08G1P.A106A .TCZ106G1 INCLUDE TABLESPACE CZ08G1P.A106A PARTLEVEL --T...
CZ07A1P.A191A .TCZ191A1 INCLUDE TABLESPACE CZ07A1P.A191A PARTLEVEL --T...
CZ07G1P.A191A .TCZ191G1 INCLUDE TABLESPACE CZ07G1P.A191A PARTLEVEL --T...
CZ03A1P.A235A .TCZ235A1 INCLUDE TABLESPACE CZ03A1P.A235A PARTLEVEL --T...
CZ03G1P.A235A .TCZ235G1 INCLUDE TABLESPACE CZ03G1P.A235A PARTLEVEL --T...
CZ03A1P.A236A .TCZ236A1 INCLUDE TABLESPACE CZ03A1P.A236A PARTLEVEL --T...
CZ03G1P.A236A .TCZ236G1 INCLUDE TABLESPACE CZ03G1P.A236A PARTLEVEL --T...
CZ14A1P.A250A .TCZ250A1 INCLUDE TABLESPACE CZ14A1P.A250A PARTLEVEL --T...
CZ14G1P.A250A .TCZ250G1 INCLUDE TABLESPACE CZ14G1P.A250A PARTLEVEL --T...
CZ14A1P.A251A .TCZ251A1 INCLUDE TABLESPACE CZ14A1P.A251A PARTLEVEL --T...
CZ14G1P.A251A .TCZ251G1 INCLUDE TABLESPACE CZ14G1P.A251A PARTLEVEL --T...
CZ03A1P.A300A .TCZ300A1 INCLUDE TABLESPACE CZ03A1P.A300A PARTLEVEL --T...
CZ03A1P.A313A .TCZ313A1 INCLUDE TABLESPACE CZ03A1P.A313A PARTLEVEL --T...
CZ03G1P.A313A .TCZ313G1 INCLUDE TABLESPACE CZ03G1P.A313A PARTLEVEL --T...
CZ03A1P.A315A .TCZ315A1 INCLUDE TABLESPACE CZ03A1P.A315A PARTLEVEL --T...
CZ03G1P.A315A .TCZ315G1 INCLUDE TABLESPACE CZ03G1P.A315A PARTLEVEL --T...
CZ03A1P.A319A .TCZ319A1 INCLUDE TABLESPACE CZ03A1P.A319A PARTLEVEL --T...
CZ03G1P.A319A .TCZ319G1 INCLUDE TABLESPACE CZ03G1P.A319A PARTLEVEL --T...
CZ03A1P.A321A .TCZ321A1 INCLUDE TABLESPACE CZ03A1P.A321A PARTLEVEL --T...
CZ03G1P.A321A .TCZ321G1 INCLUDE TABLESPACE CZ03G1P.A321A PARTLEVEL --T...
CZ03A1P.A323A .TCZ323A1 INCLUDE TABLESPACE CZ03A1P.A323A PARTLEVEL --T...
CZ03G1P.A323A .TCZ323G1 INCLUDE TABLESPACE CZ03G1P.A323A PARTLEVEL --T...
CZ03A1P.A327A .TCZ327A1 INCLUDE TABLESPACE CZ03A1P.A327A PARTLEVEL --T...
CZ03G1P.A327A .TCZ327G1 INCLUDE TABLESPACE CZ03G1P.A327A PARTLEVEL --T...
CZ03A1P.A331A .TCZ331A1 INCLUDE TABLESPACE CZ03A1P.A331A PARTLEVEL --T...
CZ03G1P.A331A .TCZ331G1 INCLUDE TABLESPACE CZ03G1P.A331A PARTLEVEL --T...
CZ03A1P.A340A .TCZ340A1 INCLUDE TABLESPACE CZ03A1P.A340A PARTLEVEL --T...
CZ03A1P.A384A .TCZ384A1 INCLUDE TABLESPACE CZ03A1P.A384A PARTLEVEL --T...
CZ03G1P.A384A .TCZ384G1 INCLUDE TABLESPACE CZ03G1P.A384A PARTLEVEL --T...
CZ03A1P.A386A .TCZ386A1 INCLUDE TABLESPACE CZ03A1P.A386A PARTLEVEL --T...
CZ03G1P.A386A .TCZ386G1 INCLUDE TABLESPACE CZ03G1P.A386A PARTLEVEL --T...
CZ03A1P.A421A .TCZ421A1 INCLUDE TABLESPACE CZ03A1P.A421A PARTLEVEL --T...
CZ03G1P.A421A .TCZ421G1 INCLUDE TABLESPACE CZ03G1P.A421A PARTLEVEL --T...
CZ03A1P.A428A .TCZ428A1 INCLUDE TABLESPACE CZ03A1P.A428A PARTLEVEL --T...
CZ03G1P.A428A .TCZ428G1 INCLUDE TABLESPACE CZ03G1P.A428A PARTLEVEL --T...
CZ03A1P.A429A .TCZ429A1 INCLUDE TABLESPACE CZ03A1P.A429A PARTLEVEL --T...
CZ03G1P.A429A .TCZ429G1 INCLUDE TABLESPACE CZ03G1P.A429A PARTLEVEL --T...
CZ03A1P.A432A .TCZ432A1 INCLUDE TABLESPACE CZ03A1P.A432A PARTLEVEL --T...
CZ03A1P.A433A .TCZ433A1 INCLUDE TABLESPACE CZ03A1P.A433A PARTLEVEL --T...
CZ04A1P.A500A .TCZ500A1 INCLUDE TABLESPACE CZ04A1P.A500A PARTLEVEL --T...
CZ04A1P.A513A .TCZ513A1 INCLUDE TABLESPACE CZ04A1P.A513A PARTLEVEL --T...
CZ04A1P.A515A .TCZ515A1 INCLUDE TABLESPACE CZ04A1P.A515A PARTLEVEL --T...
CZ04A1P.A519A .TCZ519A1 INCLUDE TABLESPACE CZ04A1P.A519A PARTLEVEL --T...
CZ04A1P.A521A .TCZ521A1 INCLUDE TABLESPACE CZ04A1P.A521A PARTLEVEL --T...
CZ04A1P.A584A .TCZ584A1 INCLUDE TABLESPACE CZ04A1P.A584A PARTLEVEL --T...
CZ04A1P.A621A .TCZ621A1 INCLUDE TABLESPACE CZ04A1P.A621A PARTLEVEL --T...
CZ13A1P.A707A .TCZ707A1 INCLUDE TABLESPACE CZ13A1P.A707A PARTLEVEL --T...
CZ13A1P.A708A .TCZ708A1 INCLUDE TABLESPACE CZ13A1P.A708A PARTLEVEL --T...
DB01A1P.A201A .TDB201A1 INCLUDE TABLESPACE DB01A1P.A201A PARTLEVEL --T...
DE02A1P.A023A .TDE023A1 INCLUDE TABLESPACE DE02A1P.A023A PARTLEVEL --T...
ED02A1P.A023A .TED023A1 INCLUDE TABLESPACE ED02A1P.A023A PARTLEVEL --T...
FC01A1P.A001A .TFC001A0 INCLUDE TABLESPACE FC01A1P.A001A PARTLEVEL --T...
KC01A1P.A001A .TKC001A1 INCLUDE TABLESPACE KC01A1P.A001A PARTLEVEL --T...
KC01A1P.A002A .TKC002A1 INCLUDE TABLESPACE KC01A1P.A002A PARTLEVEL --T...
KC01A1P.A003A .TKC003A1 INCLUDE TABLESPACE KC01A1P.A003A PARTLEVEL --T...
KC01A1P.A010A .TKC010A1 INCLUDE TABLESPACE KC01A1P.A010A PARTLEVEL --T...
MF03A1P.A009A .TMF009A1 INCLUDE TABLESPACE MF03A1P.A009A PARTLEVEL --T...
MF01A1P.A101A .TMF101A1 INCLUDE TABLESPACE MF01A1P.A101A PARTLEVEL --T...
MF01A1P.A103A .TMF103A1 INCLUDE TABLESPACE MF01A1P.A103A PARTLEVEL --T...
MF01A1P.A104A .TMF104A1 INCLUDE TABLESPACE MF01A1P.A104A PARTLEVEL --T...
NI02A1P.A100A .TNI100A101A INCLUDE TABLESPACE NI02A1P.A100A PARTLEVEL ...
NI02A1P.A609A .TNI609A101A INCLUDE TABLESPACE NI02A1P.A609A PARTLEVEL ...
NZ03A1P.A021A .TNZ021A1 INCLUDE TABLESPACE NZ03A1P.A021A PARTLEVEL --T...
NZ02A1P.A150A .TNZ150A1 INCLUDE TABLESPACE NZ02A1P.A150A PARTLEVEL --T...
NZ02A1P.A151A .TNZ151A1 INCLUDE TABLESPACE NZ02A1P.A151A PARTLEVEL --T...
NZ02A1P.A152A .TNZ152A1 INCLUDE TABLESPACE NZ02A1P.A152A PARTLEVEL --T...
NZ01A1P.A202A .TNZ202A1 INCLUDE TABLESPACE NZ01A1P.A202A PARTLEVEL --T...
NZ01A1P.A204A .TNZ204A1 INCLUDE TABLESPACE NZ01A1P.A204A PARTLEVEL --T...
NZ01A1P.A209A .TNZ209A1 INCLUDE TABLESPACE NZ01A1P.A209A PARTLEVEL --T...
NZ01A1P.A212A .TNZ212A1 INCLUDE TABLESPACE NZ01A1P.A212A PARTLEVEL --T...
NZ01A1P.A252A .TNZ252A1 INCLUDE TABLESPACE NZ01A1P.A252A PARTLEVEL --T...
NZ01A1P.A258A .TNZ258A1 INCLUDE TABLESPACE NZ01A1P.A258A PARTLEVEL --T...
RM01A1P.A003A .TRM003A1 INCLUDE TABLESPACE RM01A1P.A003A PARTLEVEL --T...
RM01A1P.A010A .TRM010A1 INCLUDE TABLESPACE RM01A1P.A010A PARTLEVEL --T...
RM01A1P.A020A .TRM020A1 INCLUDE TABLESPACE RM01A1P.A020A PARTLEVEL --T...
RM01A1P.A021A .TRM021A1 INCLUDE TABLESPACE RM01A1P.A021A PARTLEVEL --T...
RV01A1P.A100A .TRV100A1 INCLUDE TABLESPACE RV01A1P.A100A PARTLEVEL --T...
RV01A1P.A110A .TRV110A1 INCLUDE TABLESPACE RV01A1P.A110A PARTLEVEL --T...
RV01A1P.A120A .TRV120A1 INCLUDE TABLESPACE RV01A1P.A120A PARTLEVEL --T...
RV01A1P.A130A .TRV130A1 INCLUDE TABLESPACE RV01A1P.A130A PARTLEVEL --T...
RV01A1P.A140A .TRV140A1 INCLUDE TABLESPACE RV01A1P.A140A PARTLEVEL --T...
RV01A1P.A221A .TRV221A1 INCLUDE TABLESPACE RV01A1P.A221A PARTLEVEL --T...
RV01A1P.A301A .TRV301A1 INCLUDE TABLESPACE RV01A1P.A301A PARTLEVEL --T...
RV01A1P.A431A .TRV431A1 INCLUDE TABLESPACE RV01A1P.A431A PARTLEVEL --T...
RV01A1P.A451A .TRV451A1 INCLUDE TABLESPACE RV01A1P.A451A PARTLEVEL --T...
RV01A1P.A501A .TRV501A1 INCLUDE TABLESPACE RV01A1P.A501A PARTLEVEL --T...
RV01A1P.A600A .TRV600A1 INCLUDE TABLESPACE RV01A1P.A600A PARTLEVEL --T...
UU02A1P.A130A .TUU130A2 INCLUDE TABLESPACE UU02A1P.A130A PARTLEVEL --T...
VD01A1P.A002A .TVD002A1 INCLUDE TABLESPACE VD01A1P.A002A PARTLEVEL --T...
VP03A1P.A009A .TVP009A1 INCLUDE TABLESPACE VP03A1P.A009A PARTLEVEL --T...
VP02A1P.A020A .TVP020A1 INCLUDE TABLESPACE VP02A1P.A020A PARTLEVEL --T...
VP02H1P.A020H .TVP020H1 INCLUDE TABLESPACE VP02H1P.A020H PARTLEVEL --T...
VP02A1P.A023A .TVP023A1 INCLUDE TABLESPACE VP02A1P.A023A PARTLEVEL --T...
VP02H1P.A023H .TVP023H1 INCLUDE TABLESPACE VP02H1P.A023H PARTLEVEL --T...
VP02A1P.A025A .TVP025A1 INCLUDE TABLESPACE VP02A1P.A025A PARTLEVEL --T...
VP02H1P.A025H .TVP025H1 INCLUDE TABLESPACE VP02H1P.A025H PARTLEVEL --T...
VP02A1P.A036A .TVP036A1 INCLUDE TABLESPACE VP02A1P.A036A PARTLEVEL --T...
VP02H1P.A036H .TVP036H1 INCLUDE TABLESPACE VP02H1P.A036H PARTLEVEL --T...
WF01A1P.A003A .TWF003A1 INCLUDE TABLESPACE WF01A1P.A003A PARTLEVEL --T...
WF01A1P.A032A .TWF032A1 INCLUDE TABLESPACE WF01A1P.A032A PARTLEVEL --T...
WF01A1P.A034A .TWF034A1 INCLUDE TABLESPACE WF01A1P.A034A PARTLEVEL --T...
WF01A1P.A035A .TWF035A1 INCLUDE TABLESPACE WF01A1P.A035A PARTLEVEL --T...
WF01A1P.A051A .TWF051A1 INCLUDE TABLESPACE WF01A1P.A051A PARTLEVEL --T...
WF01A1P.A052A .TWF052A1 INCLUDE TABLESPACE WF01A1P.A052A PARTLEVEL --T...
WF01A1P.A073A .TWF073A1 INCLUDE TABLESPACE WF01A1P.A073A PARTLEVEL --T...
WF01A1P.A076A .TWF076A1 INCLUDE TABLESPACE WF01A1P.A076A PARTLEVEL --T...
WF01A1P.A080A .TWF080A1 INCLUDE TABLESPACE WF01A1P.A080A PARTLEVEL --T...
WF01A1P.A082A .TWF082A1 INCLUDE TABLESPACE WF01A1P.A082A PARTLEVEL --T...
WF01A1P.A083A .TWF083A1 INCLUDE TABLESPACE WF01A1P.A083A PARTLEVEL --T...
WF01A1P.A086A .TWF086A1 INCLUDE TABLESPACE WF01A1P.A086A PARTLEVEL --T...
WF01A1P.A088A .TWF088A1 INCLUDE TABLESPACE WF01A1P.A088A PARTLEVEL --T...
WF01A1P.A090A .TWF090A1 INCLUDE TABLESPACE WF01A1P.A090A PARTLEVEL --T...
WF01A1P.A091A .TWF091A1 INCLUDE TABLESPACE WF01A1P.A091A PARTLEVEL --T...
WG01A1P.A100A .TWG100A1 INCLUDE TABLESPACE WG01A1P.A100A PARTLEVEL --T...
WG01A1P.A101A .TWG101A1 INCLUDE TABLESPACE WG01A1P.A101A PARTLEVEL --T...
WG01A1P.A200A .TWG200A1 INCLUDE TABLESPACE WG01A1P.A200A PARTLEVEL --T...
WG01A1P.A400A .TWG400A1 INCLUDE TABLESPACE WG01A1P.A400A PARTLEVEL --T...
WG01A1P.A410A .TWG410A1 INCLUDE TABLESPACE WG01A1P.A410A PARTLEVEL --T...
WL09A1P.A901A .TWL901A1 INCLUDE TABLESPACE WL09A1P.A901A PARTLEVEL --T...
WM01A1P.A005A .TWM005A1 INCLUDE TABLESPACE WM01A1P.A005A PARTLEVEL --T...
WR01A1P.A002A .TWR002A1 INCLUDE TABLESPACE WR01A1P.A002A PARTLEVEL --T...
$#out 20150623 16:00:15
TABLES.OA1P LISTDEF COPYLIST -- OA1P TABLES BELOW
BE01A1P.A010A01 OA1P01.TBE010A1 INCLUDE TABLESPACE BE01A1P.A010A01 PARTLEV...
BE01A1P.A010A02 OA1P02.TBE010A1 INCLUDE TABLESPACE BE01A1P.A010A02 PARTLEV...
BE01A1P.A010A03 OA1P03.TBE010A1 INCLUDE TABLESPACE BE01A1P.A010A03 PARTLEV...
BE01A1P.A010A04 OA1P04.TBE010A1 INCLUDE TABLESPACE BE01A1P.A010A04 PARTLEV...
RA01A1P.A001A .TRA001A1 INCLUDE TABLESPACE RA01A1P.A001A PARTLEVEL --T...
RA01A1P.A060A .TRA060A1 INCLUDE TABLESPACE RA01A1P.A060A PARTLEVEL --T...
RA01A1P.A080A .TRA080A1 INCLUDE TABLESPACE RA01A1P.A080A PARTLEVEL --T...
RA01A1P.A081A .TRA081A1 INCLUDE TABLESPACE RA01A1P.A081A PARTLEVEL --T...
RA01A1P.A082A .TRA082A1 INCLUDE TABLESPACE RA01A1P.A082A PARTLEVEL --T...
RA01A1P.A083A .TRA083A1 INCLUDE TABLESPACE RA01A1P.A083A PARTLEVEL --T...
TABLES.OA1P LISTDEF COPYLIST -- OA1P TABLES BELOW
BS01A1P.A003A .TBS003A1 INCLUDE TABLESPACE BS01A1P.A003A PARTLEVEL --T...
CD01A1P.A031A .TCD031 INCLUDE TABLESPACE CD01A1P.A031A PARTLEVEL --TCD031
CD01A1P.A041A .TCD041 INCLUDE TABLESPACE CD01A1P.A041A PARTLEVEL --TCD041
CD01A1P.A061A .TCD061 INCLUDE TABLESPACE CD01A1P.A061A PARTLEVEL --TCD061
CD01A1P.A091A .TCD091 INCLUDE TABLESPACE CD01A1P.A091A PARTLEVEL --TCD091
CD01A1P.A111A .TCD111 INCLUDE TABLESPACE CD01A1P.A111A PARTLEVEL --TCD111
CD01A1P.A131A .TCD131 INCLUDE TABLESPACE CD01A1P.A131A PARTLEVEL --TCD131
CD01A1P.A231A .TCD231 INCLUDE TABLESPACE CD01A1P.A231A PARTLEVEL --TCD231
CD01A1P.A251A .TCD251 INCLUDE TABLESPACE CD01A1P.A251A PARTLEVEL --TCD251
CD01A1P.A291A .TCD291 INCLUDE TABLESPACE CD01A1P.A291A PARTLEVEL --TCD291
CD01A1P.A301A .TCD301 INCLUDE TABLESPACE CD01A1P.A301A PARTLEVEL --TCD301
CD01A1P.A341A .TCD341 INCLUDE TABLESPACE CD01A1P.A341A PARTLEVEL --TCD341
CD01A1P.A391A .TCD391 INCLUDE TABLESPACE CD01A1P.A391A PARTLEVEL --TCD391
CD01A1P.A451A .TCD451 INCLUDE TABLESPACE CD01A1P.A451A PARTLEVEL --TCD451
CD01A1P.A771A .TCD771 INCLUDE TABLESPACE CD01A1P.A771A PARTLEVEL --TCD771
CD03A1P.A100P .TCD100A1 INCLUDE TABLESPACE CD03A1P.A100P PARTLEVEL --T...
CD03A1P.A100B .TCD100B1 INCLUDE TABLESPACE CD03A1P.A100B PARTLEVEL --T...
CD03A1P.A140A .TCD140A1 INCLUDE TABLESPACE CD03A1P.A140A PARTLEVEL --T...
CD03A1P.A140H .TCD140H1 INCLUDE TABLESPACE CD03A1P.A140H PARTLEVEL --T...
CD03A1P.A181A .TCD181A1 INCLUDE TABLESPACE CD03A1P.A181A PARTLEVEL --T...
CD03A1P.A181H .TCD181H1 INCLUDE TABLESPACE CD03A1P.A181H PARTLEVEL --T...
CD03A1P.A182A .TCD182A1 INCLUDE TABLESPACE CD03A1P.A182A PARTLEVEL --T...
CD03A1P.A182H .TCD182H1 INCLUDE TABLESPACE CD03A1P.A182H PARTLEVEL --T...
CD01A1P.A306A .TCD306A1 INCLUDE TABLESPACE CD01A1P.A306A PARTLEVEL --T...
CD03A1P.A380A .TCD380A1 INCLUDE TABLESPACE CD03A1P.A380A PARTLEVEL --T...
CD02A1P.A470A .TCD470A1 INCLUDE TABLESPACE CD02A1P.A470A PARTLEVEL --T...
CD02A1P.A616A .TCD616A1 INCLUDE TABLESPACE CD02A1P.A616A PARTLEVEL --T...
CD02A1P.A617A .TCD617A1 INCLUDE TABLESPACE CD02A1P.A617A PARTLEVEL --T...
CD02A1P.A619A .TCD619A1 INCLUDE TABLESPACE CD02A1P.A619A PARTLEVEL --T...
CD03A1P.A630A .TCD630A1 INCLUDE TABLESPACE CD03A1P.A630A PARTLEVEL --T...
CD03A1P.A633A .TCD633A1 INCLUDE TABLESPACE CD03A1P.A633A PARTLEVEL --T...
CD03A1P.A634A .TCD634A1 INCLUDE TABLESPACE CD03A1P.A634A PARTLEVEL --T...
CD03A1P.A635A .TCD635A1 INCLUDE TABLESPACE CD03A1P.A635A PARTLEVEL --T...
CK01A1P.A025A .TCK025A1 INCLUDE TABLESPACE CK01A1P.A025A PARTLEVEL --T...
CK01A1P.A030A .TCK030A1 INCLUDE TABLESPACE CK01A1P.A030A PARTLEVEL --T...
CK01A1P.A031A .TCK031A1 INCLUDE TABLESPACE CK01A1P.A031A PARTLEVEL --T...
CK01A1P.A078A .TCK078A1 INCLUDE TABLESPACE CK01A1P.A078A PARTLEVEL --T...
CK01A1P.A083A .TCK083A1 INCLUDE TABLESPACE CK01A1P.A083A PARTLEVEL --T...
CK01A1P.A085A .TCK085A1 INCLUDE TABLESPACE CK01A1P.A085A PARTLEVEL --T...
CT02A1P.A152A .TCT152A1 INCLUDE TABLESPACE CT02A1P.A152A PARTLEVEL --T...
CT01G1P.A152A .TCT152G1 INCLUDE TABLESPACE CT01G1P.A152A PARTLEVEL --T...
CT02A1P.A153A .TCT153A1 INCLUDE TABLESPACE CT02A1P.A153A PARTLEVEL --T...
CT01G1P.A153A .TCT153G1 INCLUDE TABLESPACE CT01G1P.A153A PARTLEVEL --T...
CT02A1P.A202A .TCT202A1 INCLUDE TABLESPACE CT02A1P.A202A PARTLEVEL --T...
CT01G1P.A202A .TCT202G1 INCLUDE TABLESPACE CT01G1P.A202A PARTLEVEL --T...
CT02A1P.A203A .TCT203A1 INCLUDE TABLESPACE CT02A1P.A203A PARTLEVEL --T...
CT01G1P.A203A .TCT203G1 INCLUDE TABLESPACE CT01G1P.A203A PARTLEVEL --T...
CT02A1P.A206A .TCT206A1 INCLUDE TABLESPACE CT02A1P.A206A PARTLEVEL --T...
CT01G1P.A206A .TCT206G1 INCLUDE TABLESPACE CT01G1P.A206A PARTLEVEL --T...
CT02A1P.A217A .TCT217A1 INCLUDE TABLESPACE CT02A1P.A217A PARTLEVEL --T...
CT01G1P.A217A .TCT217G1 INCLUDE TABLESPACE CT01G1P.A217A PARTLEVEL --T...
CT02A1P.A251A .TCT251A1 INCLUDE TABLESPACE CT02A1P.A251A PARTLEVEL --T...
CT01G1P.A251A .TCT251G1 INCLUDE TABLESPACE CT01G1P.A251A PARTLEVEL --T...
CT02A1P.A253A .TCT253A1 INCLUDE TABLESPACE CT02A1P.A253A PARTLEVEL --T...
CT01G1P.A253A .TCT253G1 INCLUDE TABLESPACE CT01G1P.A253A PARTLEVEL --T...
CT02A1P.A254A .TCT254A1 INCLUDE TABLESPACE CT02A1P.A254A PARTLEVEL --T...
CT01G1P.A254A .TCT254G1 INCLUDE TABLESPACE CT01G1P.A254A PARTLEVEL --T...
CT02A1P.A256A .TCT256A1 INCLUDE TABLESPACE CT02A1P.A256A PARTLEVEL --T...
CT01G1P.A256A .TCT256G1 INCLUDE TABLESPACE CT01G1P.A256A PARTLEVEL --T...
CT02A1P.A257A .TCT257A1 INCLUDE TABLESPACE CT02A1P.A257A PARTLEVEL --T...
CT01G1P.A257A .TCT257G1 INCLUDE TABLESPACE CT01G1P.A257A PARTLEVEL --T...
CT02A1P.A258A .TCT258A1 INCLUDE TABLESPACE CT02A1P.A258A PARTLEVEL --T...
CT01G1P.A258A .TCT258G1 INCLUDE TABLESPACE CT01G1P.A258A PARTLEVEL --T...
CT02A1P.A259A .TCT259A1 INCLUDE TABLESPACE CT02A1P.A259A PARTLEVEL --T...
CT01G1P.A259A .TCT259G1 INCLUDE TABLESPACE CT01G1P.A259A PARTLEVEL --T...
CT02A1P.A261A .TCT261A1 INCLUDE TABLESPACE CT02A1P.A261A PARTLEVEL --T...
CT01G1P.A261A .TCT261G1 INCLUDE TABLESPACE CT01G1P.A261A PARTLEVEL --T...
CT02A1P.A301A .TCT301A1 INCLUDE TABLESPACE CT02A1P.A301A PARTLEVEL --T...
CT01G1P.A301A .TCT301G1 INCLUDE TABLESPACE CT01G1P.A301A PARTLEVEL --T...
CT02A1P.A305A .TCT305A1 INCLUDE TABLESPACE CT02A1P.A305A PARTLEVEL --T...
CT01G1P.A305A .TCT305G1 INCLUDE TABLESPACE CT01G1P.A305A PARTLEVEL --T...
CT02A1P.A306A .TCT306A1 INCLUDE TABLESPACE CT02A1P.A306A PARTLEVEL --T...
CT01G1P.A306A .TCT306G1 INCLUDE TABLESPACE CT01G1P.A306A PARTLEVEL --T...
CT02A1P.A308A .TCT308A1 INCLUDE TABLESPACE CT02A1P.A308A PARTLEVEL --T...
CT01G1P.A308A .TCT308G1 INCLUDE TABLESPACE CT01G1P.A308A PARTLEVEL --T...
CT02A1P.A309A .TCT309A1 INCLUDE TABLESPACE CT02A1P.A309A PARTLEVEL --T...
CT01G1P.A309A .TCT309G1 INCLUDE TABLESPACE CT01G1P.A309A PARTLEVEL --T...
CT02A1P.A353A .TCT353A1 INCLUDE TABLESPACE CT02A1P.A353A PARTLEVEL --T...
CT01G1P.A353A .TCT353G1 INCLUDE TABLESPACE CT01G1P.A353A PARTLEVEL --T...
CT02A1P.A356A .TCT356A1 INCLUDE TABLESPACE CT02A1P.A356A PARTLEVEL --T...
CT01G1P.A356A .TCT356G1 INCLUDE TABLESPACE CT01G1P.A356A PARTLEVEL --T...
CT02A1P.A400A .TCT400A1 INCLUDE TABLESPACE CT02A1P.A400A PARTLEVEL --T...
CT01G1P.A400A .TCT400G1 INCLUDE TABLESPACE CT01G1P.A400A PARTLEVEL --T...
CY02A1P.A056A .TCY056A1 INCLUDE TABLESPACE CY02A1P.A056A PARTLEVEL --T...
CZ08A1P.A025A .TCZ025A1 INCLUDE TABLESPACE CZ08A1P.A025A PARTLEVEL --T...
CZ18A1P.A025A .TCZ025E1 INCLUDE TABLESPACE CZ18A1P.A025A PARTLEVEL --T...
CZ08G1P.A025A .TCZ025G1 INCLUDE TABLESPACE CZ08G1P.A025A PARTLEVEL --T...
CZ08A1P.A100A .TCZ100A1 INCLUDE TABLESPACE CZ08A1P.A100A PARTLEVEL --T...
CZ18A1P.A100A .TCZ100E1 INCLUDE TABLESPACE CZ18A1P.A100A PARTLEVEL --T...
CZ08G1P.A100A .TCZ100G1 INCLUDE TABLESPACE CZ08G1P.A100A PARTLEVEL --T...
CZ08A1P.A101A .TCZ101A1 INCLUDE TABLESPACE CZ08A1P.A101A PARTLEVEL --T...
CZ18A1P.A101A .TCZ101E1 INCLUDE TABLESPACE CZ18A1P.A101A PARTLEVEL --T...
CZ08G1P.A101A .TCZ101G1 INCLUDE TABLESPACE CZ08G1P.A101A PARTLEVEL --T...
CZ08A1P.A103A .TCZ103A1 INCLUDE TABLESPACE CZ08A1P.A103A PARTLEVEL --T...
CZ18A1P.A103A .TCZ103E1 INCLUDE TABLESPACE CZ18A1P.A103A PARTLEVEL --T...
CZ08G1P.A103A .TCZ103G1 INCLUDE TABLESPACE CZ08G1P.A103A PARTLEVEL --T...
CZ08A1P.A106A .TCZ106A1 INCLUDE TABLESPACE CZ08A1P.A106A PARTLEVEL --T...
CZ18A1P.A106A .TCZ106E1 INCLUDE TABLESPACE CZ18A1P.A106A PARTLEVEL --T...
CZ08G1P.A106A .TCZ106G1 INCLUDE TABLESPACE CZ08G1P.A106A PARTLEVEL --T...
CZ07A1P.A191A .TCZ191A1 INCLUDE TABLESPACE CZ07A1P.A191A PARTLEVEL --T...
CZ07G1P.A191A .TCZ191G1 INCLUDE TABLESPACE CZ07G1P.A191A PARTLEVEL --T...
CZ03A1P.A235A .TCZ235A1 INCLUDE TABLESPACE CZ03A1P.A235A PARTLEVEL --T...
CZ03G1P.A235A .TCZ235G1 INCLUDE TABLESPACE CZ03G1P.A235A PARTLEVEL --T...
CZ03A1P.A236A .TCZ236A1 INCLUDE TABLESPACE CZ03A1P.A236A PARTLEVEL --T...
CZ03G1P.A236A .TCZ236G1 INCLUDE TABLESPACE CZ03G1P.A236A PARTLEVEL --T...
CZ14A1P.A250A .TCZ250A1 INCLUDE TABLESPACE CZ14A1P.A250A PARTLEVEL --T...
CZ14G1P.A250A .TCZ250G1 INCLUDE TABLESPACE CZ14G1P.A250A PARTLEVEL --T...
CZ14A1P.A251A .TCZ251A1 INCLUDE TABLESPACE CZ14A1P.A251A PARTLEVEL --T...
CZ14G1P.A251A .TCZ251G1 INCLUDE TABLESPACE CZ14G1P.A251A PARTLEVEL --T...
CZ03A1P.A300A .TCZ300A1 INCLUDE TABLESPACE CZ03A1P.A300A PARTLEVEL --T...
CZ03A1P.A313A .TCZ313A1 INCLUDE TABLESPACE CZ03A1P.A313A PARTLEVEL --T...
CZ03G1P.A313A .TCZ313G1 INCLUDE TABLESPACE CZ03G1P.A313A PARTLEVEL --T...
CZ03A1P.A315A .TCZ315A1 INCLUDE TABLESPACE CZ03A1P.A315A PARTLEVEL --T...
CZ03G1P.A315A .TCZ315G1 INCLUDE TABLESPACE CZ03G1P.A315A PARTLEVEL --T...
CZ03A1P.A319A .TCZ319A1 INCLUDE TABLESPACE CZ03A1P.A319A PARTLEVEL --T...
CZ03G1P.A319A .TCZ319G1 INCLUDE TABLESPACE CZ03G1P.A319A PARTLEVEL --T...
CZ03A1P.A321A .TCZ321A1 INCLUDE TABLESPACE CZ03A1P.A321A PARTLEVEL --T...
CZ03G1P.A321A .TCZ321G1 INCLUDE TABLESPACE CZ03G1P.A321A PARTLEVEL --T...
CZ03A1P.A323A .TCZ323A1 INCLUDE TABLESPACE CZ03A1P.A323A PARTLEVEL --T...
CZ03G1P.A323A .TCZ323G1 INCLUDE TABLESPACE CZ03G1P.A323A PARTLEVEL --T...
CZ03A1P.A327A .TCZ327A1 INCLUDE TABLESPACE CZ03A1P.A327A PARTLEVEL --T...
CZ03G1P.A327A .TCZ327G1 INCLUDE TABLESPACE CZ03G1P.A327A PARTLEVEL --T...
CZ03A1P.A331A .TCZ331A1 INCLUDE TABLESPACE CZ03A1P.A331A PARTLEVEL --T...
CZ03G1P.A331A .TCZ331G1 INCLUDE TABLESPACE CZ03G1P.A331A PARTLEVEL --T...
CZ03A1P.A340A .TCZ340A1 INCLUDE TABLESPACE CZ03A1P.A340A PARTLEVEL --T...
CZ03A1P.A384A .TCZ384A1 INCLUDE TABLESPACE CZ03A1P.A384A PARTLEVEL --T...
CZ03G1P.A384A .TCZ384G1 INCLUDE TABLESPACE CZ03G1P.A384A PARTLEVEL --T...
CZ03A1P.A386A .TCZ386A1 INCLUDE TABLESPACE CZ03A1P.A386A PARTLEVEL --T...
CZ03G1P.A386A .TCZ386G1 INCLUDE TABLESPACE CZ03G1P.A386A PARTLEVEL --T...
CZ03A1P.A421A .TCZ421A1 INCLUDE TABLESPACE CZ03A1P.A421A PARTLEVEL --T...
CZ03G1P.A421A .TCZ421G1 INCLUDE TABLESPACE CZ03G1P.A421A PARTLEVEL --T...
CZ03A1P.A428A .TCZ428A1 INCLUDE TABLESPACE CZ03A1P.A428A PARTLEVEL --T...
CZ03G1P.A428A .TCZ428G1 INCLUDE TABLESPACE CZ03G1P.A428A PARTLEVEL --T...
CZ03A1P.A429A .TCZ429A1 INCLUDE TABLESPACE CZ03A1P.A429A PARTLEVEL --T...
CZ03G1P.A429A .TCZ429G1 INCLUDE TABLESPACE CZ03G1P.A429A PARTLEVEL --T...
CZ03A1P.A432A .TCZ432A1 INCLUDE TABLESPACE CZ03A1P.A432A PARTLEVEL --T...
CZ03A1P.A433A .TCZ433A1 INCLUDE TABLESPACE CZ03A1P.A433A PARTLEVEL --T...
CZ04A1P.A500A .TCZ500A1 INCLUDE TABLESPACE CZ04A1P.A500A PARTLEVEL --T...
CZ04A1P.A513A .TCZ513A1 INCLUDE TABLESPACE CZ04A1P.A513A PARTLEVEL --T...
CZ04A1P.A515A .TCZ515A1 INCLUDE TABLESPACE CZ04A1P.A515A PARTLEVEL --T...
CZ04A1P.A519A .TCZ519A1 INCLUDE TABLESPACE CZ04A1P.A519A PARTLEVEL --T...
CZ04A1P.A521A .TCZ521A1 INCLUDE TABLESPACE CZ04A1P.A521A PARTLEVEL --T...
CZ04A1P.A584A .TCZ584A1 INCLUDE TABLESPACE CZ04A1P.A584A PARTLEVEL --T...
CZ04A1P.A621A .TCZ621A1 INCLUDE TABLESPACE CZ04A1P.A621A PARTLEVEL --T...
CZ13A1P.A707A .TCZ707A1 INCLUDE TABLESPACE CZ13A1P.A707A PARTLEVEL --T...
CZ13A1P.A708A .TCZ708A1 INCLUDE TABLESPACE CZ13A1P.A708A PARTLEVEL --T...
DB01A1P.A201A .TDB201A1 INCLUDE TABLESPACE DB01A1P.A201A PARTLEVEL --T...
DE02A1P.A023A .TDE023A1 INCLUDE TABLESPACE DE02A1P.A023A PARTLEVEL --T...
ED02A1P.A023A .TED023A1 INCLUDE TABLESPACE ED02A1P.A023A PARTLEVEL --T...
FC01A1P.A001A .TFC001A0 INCLUDE TABLESPACE FC01A1P.A001A PARTLEVEL --T...
KC01A1P.A001A .TKC001A1 INCLUDE TABLESPACE KC01A1P.A001A PARTLEVEL --T...
KC01A1P.A002A .TKC002A1 INCLUDE TABLESPACE KC01A1P.A002A PARTLEVEL --T...
KC01A1P.A003A .TKC003A1 INCLUDE TABLESPACE KC01A1P.A003A PARTLEVEL --T...
KC01A1P.A010A .TKC010A1 INCLUDE TABLESPACE KC01A1P.A010A PARTLEVEL --T...
MF03A1P.A009A .TMF009A1 INCLUDE TABLESPACE MF03A1P.A009A PARTLEVEL --T...
MF01A1P.A101A .TMF101A1 INCLUDE TABLESPACE MF01A1P.A101A PARTLEVEL --T...
MF01A1P.A103A .TMF103A1 INCLUDE TABLESPACE MF01A1P.A103A PARTLEVEL --T...
MF01A1P.A104A .TMF104A1 INCLUDE TABLESPACE MF01A1P.A104A PARTLEVEL --T...
NI02A1P.A100A .TNI100A101A INCLUDE TABLESPACE NI02A1P.A100A PARTLEVEL ...
NI02A1P.A609A .TNI609A101A INCLUDE TABLESPACE NI02A1P.A609A PARTLEVEL ...
NZ03A1P.A021A .TNZ021A1 INCLUDE TABLESPACE NZ03A1P.A021A PARTLEVEL --T...
NZ02A1P.A150A .TNZ150A1 INCLUDE TABLESPACE NZ02A1P.A150A PARTLEVEL --T...
NZ02A1P.A151A .TNZ151A1 INCLUDE TABLESPACE NZ02A1P.A151A PARTLEVEL --T...
NZ02A1P.A152A .TNZ152A1 INCLUDE TABLESPACE NZ02A1P.A152A PARTLEVEL --T...
NZ01A1P.A202A .TNZ202A1 INCLUDE TABLESPACE NZ01A1P.A202A PARTLEVEL --T...
NZ01A1P.A204A .TNZ204A1 INCLUDE TABLESPACE NZ01A1P.A204A PARTLEVEL --T...
NZ01A1P.A209A .TNZ209A1 INCLUDE TABLESPACE NZ01A1P.A209A PARTLEVEL --T...
NZ01A1P.A212A .TNZ212A1 INCLUDE TABLESPACE NZ01A1P.A212A PARTLEVEL --T...
NZ01A1P.A252A .TNZ252A1 INCLUDE TABLESPACE NZ01A1P.A252A PARTLEVEL --T...
NZ01A1P.A258A .TNZ258A1 INCLUDE TABLESPACE NZ01A1P.A258A PARTLEVEL --T...
RM01A1P.A003A .TRM003A1 INCLUDE TABLESPACE RM01A1P.A003A PARTLEVEL --T...
RM01A1P.A010A .TRM010A1 INCLUDE TABLESPACE RM01A1P.A010A PARTLEVEL --T...
RM01A1P.A020A .TRM020A1 INCLUDE TABLESPACE RM01A1P.A020A PARTLEVEL --T...
RM01A1P.A021A .TRM021A1 INCLUDE TABLESPACE RM01A1P.A021A PARTLEVEL --T...
RV01A1P.A100A .TRV100A1 INCLUDE TABLESPACE RV01A1P.A100A PARTLEVEL --T...
RV01A1P.A110A .TRV110A1 INCLUDE TABLESPACE RV01A1P.A110A PARTLEVEL --T...
RV01A1P.A120A .TRV120A1 INCLUDE TABLESPACE RV01A1P.A120A PARTLEVEL --T...
RV01A1P.A130A .TRV130A1 INCLUDE TABLESPACE RV01A1P.A130A PARTLEVEL --T...
RV01A1P.A140A .TRV140A1 INCLUDE TABLESPACE RV01A1P.A140A PARTLEVEL --T...
RV01A1P.A221A .TRV221A1 INCLUDE TABLESPACE RV01A1P.A221A PARTLEVEL --T...
RV01A1P.A301A .TRV301A1 INCLUDE TABLESPACE RV01A1P.A301A PARTLEVEL --T...
RV01A1P.A431A .TRV431A1 INCLUDE TABLESPACE RV01A1P.A431A PARTLEVEL --T...
RV01A1P.A451A .TRV451A1 INCLUDE TABLESPACE RV01A1P.A451A PARTLEVEL --T...
RV01A1P.A501A .TRV501A1 INCLUDE TABLESPACE RV01A1P.A501A PARTLEVEL --T...
RV01A1P.A600A .TRV600A1 INCLUDE TABLESPACE RV01A1P.A600A PARTLEVEL --T...
UU02A1P.A130A .TUU130A2 INCLUDE TABLESPACE UU02A1P.A130A PARTLEVEL --T...
VD01A1P.A002A .TVD002A1 INCLUDE TABLESPACE VD01A1P.A002A PARTLEVEL --T...
VP03A1P.A009A .TVP009A1 INCLUDE TABLESPACE VP03A1P.A009A PARTLEVEL --T...
VP02A1P.A020A .TVP020A1 INCLUDE TABLESPACE VP02A1P.A020A PARTLEVEL --T...
VP02H1P.A020H .TVP020H1 INCLUDE TABLESPACE VP02H1P.A020H PARTLEVEL --T...
VP02A1P.A023A .TVP023A1 INCLUDE TABLESPACE VP02A1P.A023A PARTLEVEL --T...
VP02H1P.A023H .TVP023H1 INCLUDE TABLESPACE VP02H1P.A023H PARTLEVEL --T...
VP02A1P.A025A .TVP025A1 INCLUDE TABLESPACE VP02A1P.A025A PARTLEVEL --T...
VP02H1P.A025H .TVP025H1 INCLUDE TABLESPACE VP02H1P.A025H PARTLEVEL --T...
VP02A1P.A036A .TVP036A1 INCLUDE TABLESPACE VP02A1P.A036A PARTLEVEL --T...
VP02H1P.A036H .TVP036H1 INCLUDE TABLESPACE VP02H1P.A036H PARTLEVEL --T...
WF01A1P.A003A .TWF003A1 INCLUDE TABLESPACE WF01A1P.A003A PARTLEVEL --T...
WF01A1P.A032A .TWF032A1 INCLUDE TABLESPACE WF01A1P.A032A PARTLEVEL --T...
WF01A1P.A034A .TWF034A1 INCLUDE TABLESPACE WF01A1P.A034A PARTLEVEL --T...
WF01A1P.A035A .TWF035A1 INCLUDE TABLESPACE WF01A1P.A035A PARTLEVEL --T...
WF01A1P.A051A .TWF051A1 INCLUDE TABLESPACE WF01A1P.A051A PARTLEVEL --T...
WF01A1P.A052A .TWF052A1 INCLUDE TABLESPACE WF01A1P.A052A PARTLEVEL --T...
WF01A1P.A073A .TWF073A1 INCLUDE TABLESPACE WF01A1P.A073A PARTLEVEL --T...
WF01A1P.A076A .TWF076A1 INCLUDE TABLESPACE WF01A1P.A076A PARTLEVEL --T...
WF01A1P.A080A .TWF080A1 INCLUDE TABLESPACE WF01A1P.A080A PARTLEVEL --T...
WF01A1P.A082A .TWF082A1 INCLUDE TABLESPACE WF01A1P.A082A PARTLEVEL --T...
WF01A1P.A083A .TWF083A1 INCLUDE TABLESPACE WF01A1P.A083A PARTLEVEL --T...
WF01A1P.A086A .TWF086A1 INCLUDE TABLESPACE WF01A1P.A086A PARTLEVEL --T...
WF01A1P.A088A .TWF088A1 INCLUDE TABLESPACE WF01A1P.A088A PARTLEVEL --T...
WF01A1P.A090A .TWF090A1 INCLUDE TABLESPACE WF01A1P.A090A PARTLEVEL --T...
WF01A1P.A091A .TWF091A1 INCLUDE TABLESPACE WF01A1P.A091A PARTLEVEL --T...
WG01A1P.A100A .TWG100A1 INCLUDE TABLESPACE WG01A1P.A100A PARTLEVEL --T...
WG01A1P.A101A .TWG101A1 INCLUDE TABLESPACE WG01A1P.A101A PARTLEVEL --T...
WG01A1P.A200A .TWG200A1 INCLUDE TABLESPACE WG01A1P.A200A PARTLEVEL --T...
WG01A1P.A400A .TWG400A1 INCLUDE TABLESPACE WG01A1P.A400A PARTLEVEL --T...
WG01A1P.A410A .TWG410A1 INCLUDE TABLESPACE WG01A1P.A410A PARTLEVEL --T...
WL09A1P.A901A .TWL901A1 INCLUDE TABLESPACE WL09A1P.A901A PARTLEVEL --T...
WM01A1P.A005A .TWM005A1 INCLUDE TABLESPACE WM01A1P.A005A PARTLEVEL --T...
WR01A1P.A002A .TWR002A1 INCLUDE TABLESPACE WR01A1P.A002A PARTLEVEL --T...
$#out 20150623 15:21:03
LISTDEF COPYLIST -- OA1P TABLES BELOW
INCLUDE TABLESPACE BE01A1P.A010A01 PARTLEVEL --TBE010A1 OA1P01
INCLUDE TABLESPACE BE01A1P.A010A02 PARTLEVEL --TBE010A1 OA1P02
INCLUDE TABLESPACE BE01A1P.A010A03 PARTLEVEL --TBE010A1 OA1P03
INCLUDE TABLESPACE BE01A1P.A010A04 PARTLEVEL --TBE010A1 OA1P04
INCLUDE TABLESPACE RA01A1P.A001A PARTLEVEL --TRA001A1
INCLUDE TABLESPACE RA01A1P.A060A PARTLEVEL --TRA060A1
INCLUDE TABLESPACE RA01A1P.A080A PARTLEVEL --TRA080A1
INCLUDE TABLESPACE RA01A1P.A081A PARTLEVEL --TRA081A1
INCLUDE TABLESPACE RA01A1P.A082A PARTLEVEL --TRA082A1
INCLUDE TABLESPACE RA01A1P.A083A PARTLEVEL --TRA083A1
COPY
LIST COPYLIST
FULL YES
COPYDDN (TCOPYD)
SHRLEVEL CHANGE
PARALLEL(10)
LISTDEF COPYLIST -- OA1P TABLES BELOW
INCLUDE TABLESPACE BS01A1P.A003A PARTLEVEL --TBS003A1
INCLUDE TABLESPACE CD01A1P.A031A PARTLEVEL --TCD031
INCLUDE TABLESPACE CD01A1P.A041A PARTLEVEL --TCD041
INCLUDE TABLESPACE CD01A1P.A061A PARTLEVEL --TCD061
INCLUDE TABLESPACE CD01A1P.A091A PARTLEVEL --TCD091
INCLUDE TABLESPACE CD01A1P.A111A PARTLEVEL --TCD111
INCLUDE TABLESPACE CD01A1P.A131A PARTLEVEL --TCD131
INCLUDE TABLESPACE CD01A1P.A231A PARTLEVEL --TCD231
INCLUDE TABLESPACE CD01A1P.A251A PARTLEVEL --TCD251
INCLUDE TABLESPACE CD01A1P.A291A PARTLEVEL --TCD291
INCLUDE TABLESPACE CD01A1P.A301A PARTLEVEL --TCD301
INCLUDE TABLESPACE CD01A1P.A341A PARTLEVEL --TCD341
INCLUDE TABLESPACE CD01A1P.A391A PARTLEVEL --TCD391
INCLUDE TABLESPACE CD01A1P.A451A PARTLEVEL --TCD451
INCLUDE TABLESPACE CD01A1P.A771A PARTLEVEL --TCD771
INCLUDE TABLESPACE CD03A1P.A100P PARTLEVEL --TCD100A1
INCLUDE TABLESPACE CD03A1P.A100B PARTLEVEL --TCD100B1
INCLUDE TABLESPACE CD03A1P.A140A PARTLEVEL --TCD140A1
INCLUDE TABLESPACE CD03A1P.A140H PARTLEVEL --TCD140H1
INCLUDE TABLESPACE CD03A1P.A181A PARTLEVEL --TCD181A1
INCLUDE TABLESPACE CD03A1P.A181H PARTLEVEL --TCD181H1
INCLUDE TABLESPACE CD03A1P.A182A PARTLEVEL --TCD182A1
INCLUDE TABLESPACE CD03A1P.A182H PARTLEVEL --TCD182H1
INCLUDE TABLESPACE CD01A1P.A306A PARTLEVEL --TCD306A1
INCLUDE TABLESPACE CD03A1P.A380A PARTLEVEL --TCD380A1
INCLUDE TABLESPACE CD02A1P.A470A PARTLEVEL --TCD470A1
INCLUDE TABLESPACE CD02A1P.A616A PARTLEVEL --TCD616A1
INCLUDE TABLESPACE CD02A1P.A617A PARTLEVEL --TCD617A1
INCLUDE TABLESPACE CD02A1P.A619A PARTLEVEL --TCD619A1
INCLUDE TABLESPACE CD03A1P.A630A PARTLEVEL --TCD630A1
INCLUDE TABLESPACE CD03A1P.A633A PARTLEVEL --TCD633A1
INCLUDE TABLESPACE CD03A1P.A634A PARTLEVEL --TCD634A1
INCLUDE TABLESPACE CD03A1P.A635A PARTLEVEL --TCD635A1
INCLUDE TABLESPACE CK01A1P.A025A PARTLEVEL --TCK025A1
INCLUDE TABLESPACE CK01A1P.A030A PARTLEVEL --TCK030A1
INCLUDE TABLESPACE CK01A1P.A031A PARTLEVEL --TCK031A1
INCLUDE TABLESPACE CK01A1P.A078A PARTLEVEL --TCK078A1
INCLUDE TABLESPACE CK01A1P.A083A PARTLEVEL --TCK083A1
INCLUDE TABLESPACE CK01A1P.A085A PARTLEVEL --TCK085A1
INCLUDE TABLESPACE CT02A1P.A152A PARTLEVEL --TCT152A1
INCLUDE TABLESPACE CT01G1P.A152A PARTLEVEL --TCT152G1
INCLUDE TABLESPACE CT02A1P.A153A PARTLEVEL --TCT153A1
INCLUDE TABLESPACE CT01G1P.A153A PARTLEVEL --TCT153G1
INCLUDE TABLESPACE CT02A1P.A202A PARTLEVEL --TCT202A1
INCLUDE TABLESPACE CT01G1P.A202A PARTLEVEL --TCT202G1
INCLUDE TABLESPACE CT02A1P.A203A PARTLEVEL --TCT203A1
INCLUDE TABLESPACE CT01G1P.A203A PARTLEVEL --TCT203G1
INCLUDE TABLESPACE CT02A1P.A206A PARTLEVEL --TCT206A1
INCLUDE TABLESPACE CT01G1P.A206A PARTLEVEL --TCT206G1
INCLUDE TABLESPACE CT02A1P.A217A PARTLEVEL --TCT217A1
INCLUDE TABLESPACE CT01G1P.A217A PARTLEVEL --TCT217G1
INCLUDE TABLESPACE CT02A1P.A251A PARTLEVEL --TCT251A1
INCLUDE TABLESPACE CT01G1P.A251A PARTLEVEL --TCT251G1
INCLUDE TABLESPACE CT02A1P.A253A PARTLEVEL --TCT253A1
INCLUDE TABLESPACE CT01G1P.A253A PARTLEVEL --TCT253G1
INCLUDE TABLESPACE CT02A1P.A254A PARTLEVEL --TCT254A1
INCLUDE TABLESPACE CT01G1P.A254A PARTLEVEL --TCT254G1
INCLUDE TABLESPACE CT02A1P.A256A PARTLEVEL --TCT256A1
INCLUDE TABLESPACE CT01G1P.A256A PARTLEVEL --TCT256G1
INCLUDE TABLESPACE CT02A1P.A257A PARTLEVEL --TCT257A1
INCLUDE TABLESPACE CT01G1P.A257A PARTLEVEL --TCT257G1
INCLUDE TABLESPACE CT02A1P.A258A PARTLEVEL --TCT258A1
INCLUDE TABLESPACE CT01G1P.A258A PARTLEVEL --TCT258G1
INCLUDE TABLESPACE CT02A1P.A259A PARTLEVEL --TCT259A1
INCLUDE TABLESPACE CT01G1P.A259A PARTLEVEL --TCT259G1
INCLUDE TABLESPACE CT02A1P.A261A PARTLEVEL --TCT261A1
INCLUDE TABLESPACE CT01G1P.A261A PARTLEVEL --TCT261G1
INCLUDE TABLESPACE CT02A1P.A301A PARTLEVEL --TCT301A1
INCLUDE TABLESPACE CT01G1P.A301A PARTLEVEL --TCT301G1
INCLUDE TABLESPACE CT02A1P.A305A PARTLEVEL --TCT305A1
INCLUDE TABLESPACE CT01G1P.A305A PARTLEVEL --TCT305G1
INCLUDE TABLESPACE CT02A1P.A306A PARTLEVEL --TCT306A1
INCLUDE TABLESPACE CT01G1P.A306A PARTLEVEL --TCT306G1
INCLUDE TABLESPACE CT02A1P.A308A PARTLEVEL --TCT308A1
INCLUDE TABLESPACE CT01G1P.A308A PARTLEVEL --TCT308G1
INCLUDE TABLESPACE CT02A1P.A309A PARTLEVEL --TCT309A1
INCLUDE TABLESPACE CT01G1P.A309A PARTLEVEL --TCT309G1
INCLUDE TABLESPACE CT02A1P.A353A PARTLEVEL --TCT353A1
INCLUDE TABLESPACE CT01G1P.A353A PARTLEVEL --TCT353G1
INCLUDE TABLESPACE CT02A1P.A356A PARTLEVEL --TCT356A1
INCLUDE TABLESPACE CT01G1P.A356A PARTLEVEL --TCT356G1
INCLUDE TABLESPACE CT02A1P.A400A PARTLEVEL --TCT400A1
INCLUDE TABLESPACE CT01G1P.A400A PARTLEVEL --TCT400G1
INCLUDE TABLESPACE CY02A1P.A056A PARTLEVEL --TCY056A1
INCLUDE TABLESPACE CZ08A1P.A025A PARTLEVEL --TCZ025A1
INCLUDE TABLESPACE CZ18A1P.A025A PARTLEVEL --TCZ025E1
INCLUDE TABLESPACE CZ08G1P.A025A PARTLEVEL --TCZ025G1
INCLUDE TABLESPACE CZ08A1P.A100A PARTLEVEL --TCZ100A1
INCLUDE TABLESPACE CZ18A1P.A100A PARTLEVEL --TCZ100E1
INCLUDE TABLESPACE CZ08G1P.A100A PARTLEVEL --TCZ100G1
INCLUDE TABLESPACE CZ08A1P.A101A PARTLEVEL --TCZ101A1
INCLUDE TABLESPACE CZ18A1P.A101A PARTLEVEL --TCZ101E1
INCLUDE TABLESPACE CZ08G1P.A101A PARTLEVEL --TCZ101G1
INCLUDE TABLESPACE CZ08A1P.A103A PARTLEVEL --TCZ103A1
INCLUDE TABLESPACE CZ18A1P.A103A PARTLEVEL --TCZ103E1
INCLUDE TABLESPACE CZ08G1P.A103A PARTLEVEL --TCZ103G1
INCLUDE TABLESPACE CZ08A1P.A106A PARTLEVEL --TCZ106A1
INCLUDE TABLESPACE CZ18A1P.A106A PARTLEVEL --TCZ106E1
INCLUDE TABLESPACE CZ08G1P.A106A PARTLEVEL --TCZ106G1
INCLUDE TABLESPACE CZ07A1P.A191A PARTLEVEL --TCZ191A1
INCLUDE TABLESPACE CZ07G1P.A191A PARTLEVEL --TCZ191G1
INCLUDE TABLESPACE CZ03A1P.A235A PARTLEVEL --TCZ235A1
INCLUDE TABLESPACE CZ03G1P.A235A PARTLEVEL --TCZ235G1
INCLUDE TABLESPACE CZ03A1P.A236A PARTLEVEL --TCZ236A1
INCLUDE TABLESPACE CZ03G1P.A236A PARTLEVEL --TCZ236G1
INCLUDE TABLESPACE CZ14A1P.A250A PARTLEVEL --TCZ250A1
INCLUDE TABLESPACE CZ14G1P.A250A PARTLEVEL --TCZ250G1
INCLUDE TABLESPACE CZ14A1P.A251A PARTLEVEL --TCZ251A1
INCLUDE TABLESPACE CZ14G1P.A251A PARTLEVEL --TCZ251G1
INCLUDE TABLESPACE CZ03A1P.A300A PARTLEVEL --TCZ300A1
INCLUDE TABLESPACE CZ03A1P.A313A PARTLEVEL --TCZ313A1
INCLUDE TABLESPACE CZ03G1P.A313A PARTLEVEL --TCZ313G1
INCLUDE TABLESPACE CZ03A1P.A315A PARTLEVEL --TCZ315A1
INCLUDE TABLESPACE CZ03G1P.A315A PARTLEVEL --TCZ315G1
INCLUDE TABLESPACE CZ03A1P.A319A PARTLEVEL --TCZ319A1
INCLUDE TABLESPACE CZ03G1P.A319A PARTLEVEL --TCZ319G1
INCLUDE TABLESPACE CZ03A1P.A321A PARTLEVEL --TCZ321A1
INCLUDE TABLESPACE CZ03G1P.A321A PARTLEVEL --TCZ321G1
INCLUDE TABLESPACE CZ03A1P.A323A PARTLEVEL --TCZ323A1
INCLUDE TABLESPACE CZ03G1P.A323A PARTLEVEL --TCZ323G1
INCLUDE TABLESPACE CZ03A1P.A327A PARTLEVEL --TCZ327A1
INCLUDE TABLESPACE CZ03G1P.A327A PARTLEVEL --TCZ327G1
INCLUDE TABLESPACE CZ03A1P.A331A PARTLEVEL --TCZ331A1
INCLUDE TABLESPACE CZ03G1P.A331A PARTLEVEL --TCZ331G1
INCLUDE TABLESPACE CZ03A1P.A340A PARTLEVEL --TCZ340A1
INCLUDE TABLESPACE CZ03A1P.A384A PARTLEVEL --TCZ384A1
INCLUDE TABLESPACE CZ03G1P.A384A PARTLEVEL --TCZ384G1
INCLUDE TABLESPACE CZ03A1P.A386A PARTLEVEL --TCZ386A1
INCLUDE TABLESPACE CZ03G1P.A386A PARTLEVEL --TCZ386G1
INCLUDE TABLESPACE CZ03A1P.A421A PARTLEVEL --TCZ421A1
INCLUDE TABLESPACE CZ03G1P.A421A PARTLEVEL --TCZ421G1
INCLUDE TABLESPACE CZ03A1P.A428A PARTLEVEL --TCZ428A1
INCLUDE TABLESPACE CZ03G1P.A428A PARTLEVEL --TCZ428G1
INCLUDE TABLESPACE CZ03A1P.A429A PARTLEVEL --TCZ429A1
INCLUDE TABLESPACE CZ03G1P.A429A PARTLEVEL --TCZ429G1
INCLUDE TABLESPACE CZ03A1P.A432A PARTLEVEL --TCZ432A1
INCLUDE TABLESPACE CZ03A1P.A433A PARTLEVEL --TCZ433A1
INCLUDE TABLESPACE CZ04A1P.A500A PARTLEVEL --TCZ500A1
INCLUDE TABLESPACE CZ04A1P.A513A PARTLEVEL --TCZ513A1
INCLUDE TABLESPACE CZ04A1P.A515A PARTLEVEL --TCZ515A1
INCLUDE TABLESPACE CZ04A1P.A519A PARTLEVEL --TCZ519A1
INCLUDE TABLESPACE CZ04A1P.A521A PARTLEVEL --TCZ521A1
INCLUDE TABLESPACE CZ04A1P.A584A PARTLEVEL --TCZ584A1
INCLUDE TABLESPACE CZ04A1P.A621A PARTLEVEL --TCZ621A1
INCLUDE TABLESPACE CZ13A1P.A707A PARTLEVEL --TCZ707A1
INCLUDE TABLESPACE CZ13A1P.A708A PARTLEVEL --TCZ708A1
INCLUDE TABLESPACE DB01A1P.A201A PARTLEVEL --TDB201A1
INCLUDE TABLESPACE DE02A1P.A023A PARTLEVEL --TDE023A1
INCLUDE TABLESPACE ED02A1P.A023A PARTLEVEL --TED023A1
INCLUDE TABLESPACE FC01A1P.A001A PARTLEVEL --TFC001A0
INCLUDE TABLESPACE KC01A1P.A001A PARTLEVEL --TKC001A1
INCLUDE TABLESPACE KC01A1P.A002A PARTLEVEL --TKC002A1
INCLUDE TABLESPACE KC01A1P.A003A PARTLEVEL --TKC003A1
INCLUDE TABLESPACE KC01A1P.A010A PARTLEVEL --TKC010A1
INCLUDE TABLESPACE MF03A1P.A009A PARTLEVEL --TMF009A1
INCLUDE TABLESPACE MF01A1P.A101A PARTLEVEL --TMF101A1
INCLUDE TABLESPACE MF01A1P.A103A PARTLEVEL --TMF103A1
INCLUDE TABLESPACE MF01A1P.A104A PARTLEVEL --TMF104A1
INCLUDE TABLESPACE NI02A1P.A100A PARTLEVEL --TNI100A101A
INCLUDE TABLESPACE NI02A1P.A609A PARTLEVEL --TNI609A101A
INCLUDE TABLESPACE NZ03A1P.A021A PARTLEVEL --TNZ021A1
INCLUDE TABLESPACE NZ02A1P.A150A PARTLEVEL --TNZ150A1
INCLUDE TABLESPACE NZ02A1P.A151A PARTLEVEL --TNZ151A1
INCLUDE TABLESPACE NZ02A1P.A152A PARTLEVEL --TNZ152A1
INCLUDE TABLESPACE NZ01A1P.A202A PARTLEVEL --TNZ202A1
INCLUDE TABLESPACE NZ01A1P.A204A PARTLEVEL --TNZ204A1
INCLUDE TABLESPACE NZ01A1P.A209A PARTLEVEL --TNZ209A1
INCLUDE TABLESPACE NZ01A1P.A212A PARTLEVEL --TNZ212A1
INCLUDE TABLESPACE NZ01A1P.A252A PARTLEVEL --TNZ252A1
INCLUDE TABLESPACE NZ01A1P.A258A PARTLEVEL --TNZ258A1
INCLUDE TABLESPACE RM01A1P.A003A PARTLEVEL --TRM003A1
INCLUDE TABLESPACE RM01A1P.A010A PARTLEVEL --TRM010A1
INCLUDE TABLESPACE RM01A1P.A020A PARTLEVEL --TRM020A1
INCLUDE TABLESPACE RM01A1P.A021A PARTLEVEL --TRM021A1
INCLUDE TABLESPACE RV01A1P.A100A PARTLEVEL --TRV100A1
INCLUDE TABLESPACE RV01A1P.A110A PARTLEVEL --TRV110A1
INCLUDE TABLESPACE RV01A1P.A120A PARTLEVEL --TRV120A1
INCLUDE TABLESPACE RV01A1P.A130A PARTLEVEL --TRV130A1
INCLUDE TABLESPACE RV01A1P.A140A PARTLEVEL --TRV140A1
INCLUDE TABLESPACE RV01A1P.A221A PARTLEVEL --TRV221A1
INCLUDE TABLESPACE RV01A1P.A301A PARTLEVEL --TRV301A1
INCLUDE TABLESPACE RV01A1P.A431A PARTLEVEL --TRV431A1
INCLUDE TABLESPACE RV01A1P.A451A PARTLEVEL --TRV451A1
INCLUDE TABLESPACE RV01A1P.A501A PARTLEVEL --TRV501A1
INCLUDE TABLESPACE RV01A1P.A600A PARTLEVEL --TRV600A1
INCLUDE TABLESPACE UU02A1P.A130A PARTLEVEL --TUU130A2
INCLUDE TABLESPACE VD01A1P.A002A PARTLEVEL --TVD002A1
INCLUDE TABLESPACE VP03A1P.A009A PARTLEVEL --TVP009A1
INCLUDE TABLESPACE VP02A1P.A020A PARTLEVEL --TVP020A1
INCLUDE TABLESPACE VP02H1P.A020H PARTLEVEL --TVP020H1
INCLUDE TABLESPACE VP02A1P.A023A PARTLEVEL --TVP023A1
INCLUDE TABLESPACE VP02H1P.A023H PARTLEVEL --TVP023H1
INCLUDE TABLESPACE VP02A1P.A025A PARTLEVEL --TVP025A1
INCLUDE TABLESPACE VP02H1P.A025H PARTLEVEL --TVP025H1
INCLUDE TABLESPACE VP02A1P.A036A PARTLEVEL --TVP036A1
INCLUDE TABLESPACE VP02H1P.A036H PARTLEVEL --TVP036H1
INCLUDE TABLESPACE WF01A1P.A003A PARTLEVEL --TWF003A1
INCLUDE TABLESPACE WF01A1P.A032A PARTLEVEL --TWF032A1
INCLUDE TABLESPACE WF01A1P.A034A PARTLEVEL --TWF034A1
INCLUDE TABLESPACE WF01A1P.A035A PARTLEVEL --TWF035A1
INCLUDE TABLESPACE WF01A1P.A051A PARTLEVEL --TWF051A1
INCLUDE TABLESPACE WF01A1P.A052A PARTLEVEL --TWF052A1
INCLUDE TABLESPACE WF01A1P.A073A PARTLEVEL --TWF073A1
INCLUDE TABLESPACE WF01A1P.A076A PARTLEVEL --TWF076A1
INCLUDE TABLESPACE WF01A1P.A080A PARTLEVEL --TWF080A1
INCLUDE TABLESPACE WF01A1P.A082A PARTLEVEL --TWF082A1
INCLUDE TABLESPACE WF01A1P.A083A PARTLEVEL --TWF083A1
INCLUDE TABLESPACE WF01A1P.A086A PARTLEVEL --TWF086A1
INCLUDE TABLESPACE WF01A1P.A088A PARTLEVEL --TWF088A1
INCLUDE TABLESPACE WF01A1P.A090A PARTLEVEL --TWF090A1
INCLUDE TABLESPACE WF01A1P.A091A PARTLEVEL --TWF091A1
INCLUDE TABLESPACE WG01A1P.A100A PARTLEVEL --TWG100A1
INCLUDE TABLESPACE WG01A1P.A101A PARTLEVEL --TWG101A1
INCLUDE TABLESPACE WG01A1P.A200A PARTLEVEL --TWG200A1
INCLUDE TABLESPACE WG01A1P.A400A PARTLEVEL --TWG400A1
INCLUDE TABLESPACE WG01A1P.A410A PARTLEVEL --TWG410A1
INCLUDE TABLESPACE WL09A1P.A901A PARTLEVEL --TWL901A1
INCLUDE TABLESPACE WM01A1P.A005A PARTLEVEL --TWM005A1
INCLUDE TABLESPACE WR01A1P.A002A PARTLEVEL --TWR002A1
COPY
LIST COPYLIST
FULL YES
COPYDDN (TCOPYD)
SHRLEVEL CHANGE
PARALLEL(10)
$#out 20150623 15:20:49
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
i
$#out 20150623 14:23:23
*** run error ***
implement f in pipe +Pff
$#out
}¢--- A540769.WK.REXX(RYXEM01) cre=2011-04-14 mod=2011-04-14-13.42.33 A540769 ---
/*REXX ***/
/* -------------------------------------------------------------- */
/* ------- FUNKTION: ------- */
/* -------------------------------------------------------------- */
ADDRESS ISREDIT "MACRO "
ADDRESS ISPEXEC "VGET (VCAT) PROFILE"
ADDRESS ISPEXEC "VGET (RZX ) PROFILE"
ADDRESS ISPEXEC "VGET (LIB ) PROFILE"
ADDRESS ISPEXEC "VGET (VLIB ) PROFILE"
ADDRESS ISPEXEC "VGET (MEMBNAM ) PROFILE"
ADDRESS ISREDIT
"X ALL"
"DEL ALL X"
"COPY 'DSN.MAREC.CNTL("MEMBNAM")' BEFORE .ZFIRST"
"C #VCAT# "VCAT" ALL "
"C #RZX# "RZX" ALL "
"C #LIB# '"LIB"' ALL "
"C #VLIB# '"VLIB"' ALL "
"END "
}¢--- A540769.WK.REXX(RZALL) cre=2016-01-20 mod=2016-04-15-12.42.13 A540769 ----
$#@
call iiIni
sLi = dsn.source.cadb.cdbamdl
do ix=1 to words(m.ii_rz)
rz = word(m.ii_rz, ix)
say 'deleting from' rz
call dsnDel rz4'/dsn.cadb2.cs.exec', anapost chkstart utPun
$*( say 'copying to' rz
call dsnCopy sLi, rz'/dsn.cadb2.'iirz2dsn(rz)'.P0.CDBAMDL',
, MJBPMDL MJBPMDLD
$*) end
}¢--- A540769.WK.REXX(SB) cre= mod=-. ------------------------------------------
/* copy SB begin ***************************************************
Achtung: inc generiert SB aus scanSB, Aenderungen nur in scanSB|
scan: basic scan
scanLook(m,len) : returns next len chars, pos is not moved
scanChar(m,len) : scans next len chars
scanString(m,q): scan a String with quote q. (with doubble = 1)
scanVerify(m,c,o): verify(...,c,o,...)
scanWord(m,u) : scan a space delimited word or a string,
if u=1 then uppercase non-strings
variable interface
scanSrc(m, source) starts scanning a single line
scanEnd(m) : returns whether we reached end of input
scanErr(m, txt): error with current scan location
m is an address, to store our state
if a scan function succeeds, the scan posititon is moved
returns: true if scanned, false otherwise
m.m.tok ==> last token
m.m.val ==> last value for scanString/Word
m.m.pos ==> scan position
m.m.src ==> scan source
***********************************************************************/
/*--- return the next len characters until end of src ----------------*/
scanLook: procedure expose m.
parse arg m, len
if len == '' then
return substr(m.m.src, m.m.pos)
else
return substr(m.m.src, m.m.pos,
, min(len, 1 + length(m.m.src) - m.m.pos))
endProcedure scanLook
/*--- scan len chararcters, atmost to end of src ---------------------*/
scanChar: procedure expose m.
parse arg m, len
m.m.tok = scanLook(m, len)
m.m.pos = m.m.pos + length(m.m.tok)
return m.m.tok \== ''
endProcedure scanChar
/*--- scan the literal lit ------------------------------------------*/
scanLit: procedure expose m.
parse arg m
do ax=2 to arg()
if abbrev(substr(m.m.src, m.m.pos), arg(ax)) then do
m.m.tok = arg(ax)
m.m.pos = m.m.pos + length(arg(ax))
return 1
end
end
m.m.tok = ''
return 0
endProcedure scanLit
/*--- scan with verify, vOpt is passed to verify ---------------------*/
scanVerify: procedure expose m.
parse arg m, alpha, vOpt, onlyIfMatch
if arg() > 3 then
call err 'deimplement onlyIfMatch???'
if vOpt == '' then /* empty string does not take default */
nx = verify(m.m.src, alpha, , m.m.pos)
else
nx = verify(m.m.src, alpha, vOpt, m.m.pos)
if nx = 0 then
if onlyIfMatch == 1 then
nx = m.m.pos
else
nx = length(m.m.src) + 1
m.m.tok = substr(m.m.src, m.m.pos, nx - m.m.pos)
m.m.pos = nx
return m.m.tok \== ''
endProcedure scanVerify
/*--- scan while in charset ------------------------------------------*/
scanWhile: procedure expose m.
parse arg m, chSet
return scanVerify(m, chSet, 'n')
/*--- scan until in charset ------------------------------------------*/
scanUntil: procedure expose m.
parse arg m, chSet
return scanVerify(m, chSet, 'm')
/*--- scan until (and over) string End -------------------------------*/
scanStrEnd: procedure expose m.
parse arg m, sep
sx = m.m.pos
bx = sx
do forever
ex = pos(sep, m.m.src, sx)
if ex = 0 then do
m.m.val = m.m.val || substr(m.m.src, bx)
return 0
end
m.m.val = m.m.val || substr(m.m.src, bx, ex-bx)
bx = ex + length(sep)
if \ abbrev(substr(m.m.src, bx), sep) then do
m.m.tok = m.m.tok || substr(m.m.src, m.m.pos, bx-m.m.pos)
m.m.pos = bx
return 1
end
sx = bx + length(sep)
end
endProcedure scanStrEnd
/*--- scan a string with quote char qu -------------------------------*/
scanString: procedure expose m.
parse arg m, prefs
if prefs = '' then do
call scanLit m, "'", '"'
end
else do
do px=1 to words(prefs) until scanLit(m, word(prefs, px))
end
end
if m.m.tok == '' then
return 0
m.m.val = ''
if \ scanStrEnd(m, m.m.tok) then
return scanErr(m, 'ending Apostroph missing')
return 1
endProcedure scanString
/*--- scan a word and put value into *.val
a word is either delimited by space or stopper
or a string (with single or double quotes -------*/
scanWord: procedure expose m.
parse arg m, stopper, ucWord
if scanString(m) then
return 1
if stopper == '' then
stopper = ' '
if \scanUntil(m, stopper) then
return 0
if ucWord == 1 then
m.m.val = translate(m.m.tok)
else
m.m.val = m.m.tok
return 1
endProcedure scanWord
/*--- skip, scan and return next word --------------------------------*/
scanSkWord: procedure expose m.
parse arg m, stopper, ucWord, eMsg
if scanWord(scanSkip(m), stopper, ucWord) then
return m.m.val
else if eMsg == '' then
return ''
else
call scanErr m, eMsg 'expected'
endProcedure scanSkWord
/*--- go back the current token --------------------------------------*/
scanBack: procedure expose m.
parse arg m, tok
if m.m.pos <= length(tok) then
call scanErr sc, 'cannot back "'tok'" length'
cx = m.m.pos - length(tok)
if substr(m.m.src, cx, length(tok)) \== tok then
return scanErr(m, 'cannot back "'tok'" value')
m.m.pos = cx
return
endProcedure scanBack
/*--- set new src - allow scanning without open ----------------------*/
scanSrc: procedure expose m.
parse arg m, m.m.src
return scanStart(m)
endProcedure scanSrc
/*--- start scanning -------------------------------------------------*/
scanStart: procedure expose m.
parse arg m
m.m.pos = 1
m.m.tok = ''
return m
endProcedure scanStart
scanSpace: procedure expose m.
parse arg m
nx = verify(m.m.src, ' ', , m.m.pos)
if nx = 0 then
nx = length(m.m.src) + 1
res = nx <> m.m.pos
m.m.tok = left(' ', res)
m.m.pos = nx
return res
endProcedure scanSpace
/*--- skip over space, nl and comments and return m -----------------*/
scanSkip: procedure expose m.
parse arg m
call scanSpace m
return m
endProcedure scanSkip
scanErr: procedure expose m.
parse arg m, txt
if arg() < 3 then
return err('s}'txt'\n'scanInfo(m))
else
return err('scanErr' txt'\n'arg(3))
endProcedure scanErr
scanInfo: procedure expose m.
parse arg m
return 'last token' m.m.tok 'scanPosition' ,
strip(substr(m.m.src, m.m.pos, 40), 't') ,
|| '\npos' m.m.Pos 'in string' strip(m.m.src, 't')
endProcedure scanInfo
/*--- return position in simple format -------------------------------*/
scanPos: procedure expose m.
parse arg m
return 'singleSrc' m.m.pos
return if(m.m.pos > length(m.m.src), 'E', 'singleSrc' m.m.pos)
/*--- set position to position in arg to------------------------------*/
scanSetPos: procedure expose m.
parse arg m, to
cur = scanPos(m)
wc = words(cur)
if wc <> words(to) ,
| subWord(cur, 1, wc-1) <> subWord(to, 1, wc-1) then
call scanErr m 'cannot back from' cur 'to' to
m.m.pos = word(to, wc)
return
/*--- return true if at end of src -----------------------------------*/
scanEnd: procedure expose m.
parse arg m
return m.m.pos > length(m.m.src)
/*--- return true if at comment --------------------------------------*/
scanCom: procedure expose m.
parse arg m
m.m.tok = ''
if m.m.scanComment == '' then
return 0
if \ abbrev(substr(m.m.src, m.m.pos), m.m.scanComment) then
return 0
m.m.tok = substr(m.m.scr, m.m.pos)
m.m.pos = 1 + length(m.m.src)
return 1
endProcedure scanCom
/* copy SB end ****************************************************/
}¢--- A540769.WK.REXX(SCAN) cre=2016-08-08 mod=2016-08-08-09.46.03 A540769 -----
/* copy scan begin ************************************************
Achtung: inc generiert SB aus scan, Aenderungen nur in scan|
SB = scanBasic: single line, no reader, no newLines, class not needed
scanSrc(m, source) starts scanning a single line = scanBasic
scanLook(m,len) : returns next len chars, pos is not moved
scanChar(m,len) : scans next len chars
scanString(m,q): scan a String with quote q. (with doubble = 1)
scanVerify(m,c,o): verify(...,c,o,...)
scanEnd(m) : returns whether we reached end of input
scanLit(m,lit) : scan Literal lit if present or return 0
scanChar(m,n) : scan next n characters
scanName(m) : scan a name
ScanNat(m) : scan a natural number (without sign)
scanString(m,q): scan a String with quote q. (with doubble = 1)
scanVerify(m,c,o): verify(...,c,o,...)
scanKeyValue(m): scan a key = value clause (with spaces)
scanWord(m,st,uc) : scan a space delimited word or a string,
st=stopper, if u=1 then uppercase non-strings
scanSpace(m) : skips over spaces (and nl and comment if \ basic
scanInfo(m) : text of current scan location
scanErr(m, txt): error with current scan location
m is an address, to store our state
returns: true if scanned, false otherwise
if a scan function succeeds, the scan position is moved
m.m.tok ==> last token
m.m.val ==> last value for scanString/Word
m.m.pos ==> scan position
m.m.src ==> scan source
**********************************************************************/
/*--- start basic scannig: set new src, reset outFields -------------*/
scanSrc: procedure expose m.
parse arg m, m.m.src
m.m.pos = 1
m.m.tok = ''
m.m.scanIsBasic = 1
return m
endProcedure scanSrc
scanBasic: procedure expose m.
parse arg src
if symbol('m.scan.0') == 'VAR' then
m.scan.0 = m.scan.0 + 1
else
m.scan.0 = 1
return scanSrc('SCAN.'m.scan.0, src)
endProcedure scanBasic
scanEr3: procedure expose m.
parse arg m, txt, info
return err('s}'txt'\n'info)
scanErr: procedure expose m.
parse arg m, txt
if arg() > 2 then
return err(m,'old interface scanErr('m',' txt',' arg(3)')')
return scanEr3(m, txt, scanInfo(m))
/*--- scanInfo: text of current scan position for scanErr -----------*/
scanInfo: procedure expose m.
parse arg m
if m.m.scanIsBasic then
return scanSBInfo(m)
else
interpret objMet(m, 'scanInfo')
endProcedure scanInfo
scanSBInfo: procedure expose m.
parse arg m
return 'last token' m.m.tok 'scanPosition' ,
strip(substr(m.m.src, m.m.pos, 40), 't') ,
|| '\npos' m.m.Pos 'in string' strip(m.m.src, 't')
/*--- return the next len characters until end of src ---------------*/
scanLook: procedure expose m.
parse arg m, len
if len == '' then
return substr(m.m.src, m.m.pos)
else
return substr(m.m.src, m.m.pos,
, min(len, 1 + length(m.m.src) - m.m.pos))
endProcedure scanLook
/*--- scan len chararcters, atmost to end of src --------------------*/
scanChar: procedure expose m.
parse arg m, len
m.m.tok = scanLook(m, len)
m.m.pos = m.m.pos + length(m.m.tok)
return m.m.tok \== ''
endProcedure scanChar
/*--- scan the literal lit ------------------------------------------*/
scanLit: procedure expose m.
parse arg m
do ax=2 to arg()
if abbrev(substr(m.m.src, m.m.pos), arg(ax)) then do
m.m.tok = arg(ax)
m.m.pos = m.m.pos + length(arg(ax))
return 1
end
end
m.m.tok = ''
return 0
endProcedure scanLit
/*--- scan with verify, vOpt is passed to verify --------------------*/
scanVerify: procedure expose m.
parse arg m, alpha, vOpt
if vOpt == '' then /* empty string does not take default */
nx = verify(m.m.src, alpha, , m.m.pos)
else
nx = verify(m.m.src, alpha, vOpt, m.m.pos)
if nx = 0 then
nx = length(m.m.src) + 1
m.m.tok = substr(m.m.src, m.m.pos, nx - m.m.pos)
m.m.pos = nx
return m.m.tok \== ''
endProcedure scanVerify
/*--- scan while in charset -----------------------------------------*/
scanWhile: procedure expose m.
parse arg m, chSet
return scanVerify(m, chSet, 'n')
/*--- scan until in charset -----------------------------------------*/
scanUntil: procedure expose m.
parse arg m, chSet
return scanVerify(m, chSet, 'm')
/*--- scan until (and over) string End ------------------------------*/
scanStrEnd: procedure expose m.
parse arg m, sep
sx = m.m.pos
bx = sx
do forever
ex = pos(sep, m.m.src, sx)
if ex = 0 then do
m.m.val = m.m.val || substr(m.m.src, bx)
return 0
end
m.m.val = m.m.val || substr(m.m.src, bx, ex-bx)
bx = ex + length(sep)
if \ abbrev(substr(m.m.src, bx), sep) then do
m.m.tok = m.m.tok || substr(m.m.src, m.m.pos, bx-m.m.pos)
m.m.pos = bx
return 1
end
sx = bx + length(sep)
end
endProcedure scanStrEnd
/*--- scan a string with quote char qu ------------------------------*/
scanString: procedure expose m.
parse arg m, prefs
if prefs = '' then do
call scanLit m, "'", '"'
end
else do
do px=1 to words(prefs) until scanLit(m, word(prefs, px))
end
end
if m.m.tok == '' then
return 0
m.m.val = ''
if \ scanStrEnd(m, m.m.tok) then
return scanErr(m, 'ending Apostroph missing')
return 1
endProcedure scanString
/*--- scan a word and put value into *.val
a word is either delimited by space or stopper
or a string (with single or double quotes ------*/
scanWord: procedure expose m.
parse arg m, stopper, ucWord
if scanString(m) then
return 1
if stopper == '' then
stopper = m.ut_space
if \scanUntil(m, stopper) then
return 0
if ucWord == 1 then
m.m.val = translate(m.m.tok)
else
m.m.val = m.m.tok
return 1
endProcedure scanWord
/*--- skip, scan and return word or scanErr -------------------------*/
scanRetWord: procedure expose m.
parse arg m, stopper, ucWord, eWhat
if scanWord(scanSKip(m), stopper, ucWord) then
return m.m.val
else
return scanErr(m, eWhat 'expected')
endProcedure scanRetWord
/*--- scan a key = word phrase
put key into m.key and word into m.m.val -------*/
scanKeyValue: procedure expose m.
parse arg m, def, uc
if \ scanWord(m, ' =''"') then
return 0
m.m.key = m.m.val
if \ scanLit(scanSkip(m), '=') then
m.m.val = def
else if \ scanWord(scanSkip(m)) then
return scanErr(m, 'word expected after' m.m.key '=')
if uc == 1 then
upper m.m.key m.m.val
return 1
endProcedure scanKeyValue
/*--- scan over space, nl, comments ---------------------------------*/
scanSpace: procedure expose m.
parse arg m
if m.m.scanIsBasic then
return scanSpaceOnly(m)
else
return scanSpNlCo(m)
endProcedure scanSpace
scanSpaceOnly: procedure expose m.
parse arg m
nx = verify(m.m.src, m.ut_space, , m.m.pos)
if nx = 0 then
nx = length(m.m.src) + 1
m.m.tok = left(' ', nx <> m.m.pos)
m.m.pos = nx
return m.m.tok == ' '
endProcedure scanSpaceOnly
/*--- skip over space and return m ----------------------------------*/
scanSkip: procedure expose m.
parse arg m
call scanSpace m
return m
endProcedure scanSkip
/*--- return true if at end of src ----------------------------------*/
scanEnd: procedure expose m.
parse arg m
if m.m.pos <= length(m.m.src) then
return 0
else if m.m.scanIsBasic then
return 1
else
return m.m.atEnd
endProcedure scanEnd
/*--- scan a natural number (no sign, decpoint ...) Ignore After ----*/
scanNatIA: procedure expose m.
parse arg m
return scanVerify(m, '0123456789')
/*--- scan an integer (optional sign, no decpoint ...) Ignore After -*/
scanIntIA: procedure expose m.
parse arg m
poX = m.m.pos
call scanLit m, '-', '+'
if \ scanNatIA(m) then do
m.m.pos = poX
return 0
end
m.m.tok = substr(m.m.src, poX, m.m.pos - poX)
return 1
endProcedure scanIntIA
/*--- scanOpt set the valid characters for names, and comments
it must be called
before any of the following functions ---------------------*/
scanOpt: procedure expose m.
parse arg m, m.m.scanName1, namePlus, m.m.scanComment, nest
if m.m.scanName1 == '' then
m.m.scanName1 = m.ut_alfa
if namePlus == '' then
m.m.scanNameR = m.m.scanName1 || '0123456789'
else
m.m.scanNameR = m.m.scanName1 || namePlus
m.m.scanNestCom = nest == 1
return m
endProcedure scanOpt
/*--- return true if at comment -------------------------------------*/
scanSBCom: procedure expose m.
parse arg m
m.m.tok = ''
if m.m.scanComment == '' then
return 0
if \ abbrev(substr(m.m.src, m.m.pos), m.m.scanComment) then
return 0
m.m.tok = substr(m.m.src, m.m.pos)
m.m.pos = 1 + length(m.m.src)
return 1
endProcedure scanSBCom
/*--- scan a Name, first char in *.scanName1, rest in *.scanNameR ---*/
scanName: procedure expose m.
parse arg m
if pos(substr(m.m.src, m.m.pos, 1),
, m.m.scanName1) <= 0 then do
m.m.tok = ''
return 0
end
return scanVerify(m, m.m.scanNameR)
endProcedure scanName
/*--- check character after a number
must not be Identifier or plus ----------------------------*/
scanCheckNumAfter: procedure expose m.
parse arg m, res, plus
if \ res then
return 0
if pos(substr(m.m.src, m.m.pos, 1), m.m.scanNameR || plus) > 0 then
call scanErr m, 'illegal char after number' m.m.tok
return 1
endProcedure scanCheckNumAfter
/*--- scan a natural number check character after -------------------*/
scanNat: procedure expose m.
parse arg m
if arg() \== 1 then
return err('old interface scanNat') / 0
return scanCheckNumAfter(m, scanNatIA(m), '.')
endProcedure ScanNat
/*--- scan an Integer check character after -------------------------*/
scanInt: procedure expose m.
parse arg m
if arg() \== 1 then
return err('old interface scanInt') / 0
return scanCheckNumAfter(m, scanIntIA(m), '.')
endProcedure ScanInt
/*--- scan a Number check character after ---------------------------*/
scanNum: procedure expose m.
parse arg m
if arg() \== 1 then
return err('old interface scanNum') / 0
return scanCheckNumAfter(m, scanNumIA(m))
endProcedure ScanInt
/*--- scan a number (optional sign, decpoint, exponent) Ignore After-*/
scanNumIA: procedure expose m.
parse arg m
poX = m.m.pos
call scanLit m, '-', '+'
cx = scanNumUSPos(m)
if cx == 0 then do
m.m.pos = poX
return 0
end
m.m.tok = substr(m.m.src, poX, cx-poX)
m.m.val = translate(m.m.tok)
m.m.pos = cx
return 1
endProcedure scanNumIA
/*--- scan unsigned number (opt. decpoint, exponent) Ignore After ---*/
scanNumUSPos: procedure expose m.
parse arg m
poX = m.m.pos
cx = verify(m.m.src, '0123456789', , poX)
if cx > 0 then
if substr(m.m.src, cx, 1) == '.' then
cx = verify(m.m.src, '0123456789', , cx+1)
if cx < 1 then do
if abbrev('.', substr(m.m.src, poX)) then
return 0
end
else if abbrev('.', substr(m.m.src, poX, cx-poX)) then do
return 0
end
else if pos(substr(m.m.src, cx, 1), 'eE') > 0 then do
cy = cx + 1 + (pos(substr(m.m.src, cx+1, 1), '-+') > 0)
cx = verify(m.m.src, '0123456789', , cy)
if cx==cy | (cx == 0 & cy > length(m.s.src)) then
call scanErr m, 'exponent expected after E'
end
if cx >= poX then
return cx
else
return length(m.s.src)+1
/*
m.m.tok = substr(m.m.src, poX, cx-poX)
m.m.pos = cx
end
else do
m.m.tok = substr(m.m.src, poX)
m.m.pos = length(m.s.src)+1
end
m.m.val = translate(m.m.tok)
return 1 */
endProcedure scanNumUSPos
scanType: procedure expose m.
parse arg m, opt
m.m.tok = ''
if scanName(m) then
m.m.type = 'n'
else if scanNum(m) then
m.m.type = 0
else if scanString(m) then
m.m.type = left(m.m.tok, 1)
else if scanSpace(m) then
m.m.type = 's'
else do
call scanChar m, 1
m.m.type = m.m.tok
end
return m.m.type
endProcedure scanType
/* copy scan end *************************************************/
}¢--- A540769.WK.REXX(SCANREAD) cre=2016-08-23 mod=2016-08-23-05.32.51 A540769 ---
/* copy scanRead begin ***********************************************
Scan: scan an input: with multiple lines
==> all of scan
returns: true if scanned, false otherwise
m.m.tok ==> last token
m.m.val ==> last value for scanString/Word/KeyValue
m.key ==> key for scanKeyValue
m.m.pos ==> scan position
m.m.src ==> scan source
**********************************************************************/
scanReadIni: procedure expose m.
if m.scanRead_ini == 1 then
return
m.scanRead_ini = 1
call jIni
ts = classNew('n ScanRes u f TOK v, f VAL v, f KEY v, f TYPE v')
call classNew 'n ScanRead u JRW', 'm',
, 'oReset return scanReadReset(m, arg)',
, 'scanNL return scanReadNL(m, unCond)',
, 'scanCom return scanSBCom(m)',
, 'scanInfo return scanReadInfo(m)',
, 'scanPos return scanReadPos(m)',
, "jOpen call scanReadOpen m, arg(3)" ,
, "jClose call scanReadClose m" ,
, 'isWindow 0',
, "jRead if scanType(m) == '' then return 0;" ,
"m.rStem.1 = oClaCopy('"ts"', m, ''); m.rStem.0 = 1"
call classNew "n EditRead u JRW", "m" ,
, "jRead if \ editRead(m, rStem) then return 0",
, "jOpen" ,
, "jReset m.m.linex = arg - 1"
call classNew 'n ScanSqlStmtRdr u JRW', 'm',
, "jReset call scanSqlStmtRdrReset m, arg, arg2",
, "jOpen call scanOpen m'.SCAN'" ,
, "jClose call scanClose m'.SCAN'" ,
, "jRead r = scanSqlStmt(m'.SCAN');if r=='' then return 0" ,
"; m.rStem.1 = r; m.rStem.0 = 1"
return
endProcedure scanReadIni
scanOpen: procedure expose m.
parse arg m
interpret objMet(m, 'jOpen')
return m
endProcedure scanOpen
scanClose: procedure expose m.
parse arg m
interpret objMet(m, 'jClose')
return m
endProcedure scanClose
/*--- scan over white space, nl, comments ...------------------------*/
scanSpNlCo: procedure expose m.
parse arg m
res = 0
do while scanSpaceOnly(m) | scanCom(m) | scanNl(m)
res = 1
end
m.m.tok = left(' ', res)
return res
endProcedure scanSpNlCo
/*--- scan next line ------------------------------------------------*/
scanNL: procedure expose m.
parse arg m, unCond
interpret objMet(m, 'scanNL')
/*--- scanNl until line starts with trg -----------------------------*/
scanNlUntil: procedure expose m.
parse arg s, trg
do until scanLook(s, length(trg)) == trg
if \ scanNl(s, 1) then
return 0
end
return 1
endProcedure scanNlUntil
/*--- scan one comment ----------------------------------------------*/
scanCom: procedure expose m.
parse arg m
interpret objMet(m, 'scanCom')
/*--- go back the current token -------------------------------------*/
scanBack: procedure expose m.
parse arg m, tok
if m.m.pos <= length(tok) then
call scanErr sc, 'cannot back "'tok'" length'
cx = m.m.pos - length(tok)
if substr(m.m.src, cx, length(tok)) \== tok then
return scanErr(m, 'cannot back "'tok'" value') + sauerei
m.m.pos = cx
return
endProcedure scanBack
/*--- return position in simple format ------------------------------*/
scanPos: procedure expose m.
parse arg m
interpret objMet(m, 'scanPos')
endProcedure scanPos
/*--- set position to position in arg to-----------------------------*/
scanBackPos: procedure expose m.
parse arg m, to
cur = scanPos(m)
wc = words(cur)
if wc <> words(to) ,
| subWord(cur, 1, wc-1) <> subWord(to, 1, wc-1) then
call scanErr m 'cannot back from' cur 'to' to
m.m.pos = word(to, wc)
return
endProcedure scanBackPos
/*--- begin scanning the lines of a reader --------------------------*/
scanRead: procedure expose m.
parse arg rdr, n1, np, co
return scanOpt(oNew(m.class_ScanRead, rdr), n1, np, co)
scanReadReset: procedure expose m.
parse arg m, m.m.rdr m.m.strip .
return oMutate(m, m.class_ScanRead)
endProcedure scanReadReset
scanReadOpen: procedure expose m.
parse arg m, line0
call jOpen m.m.rdr, '<'
return scanSetPos0(m, (line0 == '') 1, line0)
endProcedure scanReadOpen
scanReadClose: procedure expose m.
parse arg m
call jClose m.m.rdr
m.m.atEnd = 'closed'
return m
endProcedure scanReadClose
/*--- scan over next newLine
if unCond \== 1 only if we are already at endOfLine
return true if we scanned a NL -----------------------------*/
scanReadNL: procedure expose m.
parse arg m, unCond
m.m.tok = ''
if unCond \== 1 then
if m.m.pos <= length(m.m.src) then
return 0
if m.m.atEnd then
return 0
if unCond == '?' then
return 1
m.m.tok = substr(m.m.src, m.m.pos)
r = m.m.rdr
if \ jRead(r) then do
m.m.atEnd = 1
m.m.pos = 1 + length(m.m.src)
return 0
end
if m.m.strip == '-' then
m.m.src = m.r
else /* strip trailing spaces for vl32755 inputs ,
use only if nl space* is equivalent to nl */
m.m.src = strip(m.r, 't')
m.m.pos = 1
m.m.lineX = m.m.lineX + 1
return 1
endProcedure scanReadNl
/*--- postition scanner to lx px (only with jBuf)
after rdr is positioned to line before ----------------------*/
scanSetPos: procedure expose m.
parse arg m, lx px
call jPosBefore m.m.rdr, lx
return scanSetPos0(m, lx px)
/*--- postition scanner to lx px
after rdr is positioned to line before -------------------------*/
scanSetPos0: procedure expose m.
parse arg m, lx px, line0
call scanReset m, line0
call scanNl m
m.m.lineX = lx
m.m.pos = px
return m
endProcedure scanSetPos0
/*--- reset scanner fields ------------------------------------------*/
scanReset: procedure expose m.
parse arg m, m.m.src
m.m.pos = 1
m.m.tok = ''
m.m.scanIsBasic = 0
m.m.atEnd = 0
m.m.lineX = 0
m.m.val = ''
m.m.key = ''
return m
endProcedure
scanTextCom: procedure expose m.
parse arg m, untC, untWrds
if \ m.m.scanNestCom then
return scanText(m, untC, untWrds)
else if wordPos('*/', untWrds) > 0 then
return scanText(m, untC'*/', untWrds)
res = scanText(m, untC'*/', untWrds '*/')
if res then
if scanLook(m, 2) == '*/' then
call scanErr m, '*/ without preceeding comment start /*'
return res
endProcedure scanTextCom
scanText: procedure expose m.
parse arg m, untC, untWrds
res = ''
do forever
if scanUntil(m, untC) then do
res = res || m.m.tok
if m.m.pos > length(m.m.src) then do
/* if windowing we need to move the window| */
if scanNl(m, 0) then
if right(res, 1) \==' ' & scanLook(m, 1)\==' ' then
res = res' '
iterate
end
end
c9 = scanLook(m, 9)
do sx=1 to words(untWrds)
if abbrev(c9, word(untWrds, sx)) then do
m.m.tok = res
return 1
end
end
if scanCom(m) | scanNl(m, 0) then do
if right(res, 1) \== ' ' & scanLook(m, 1) \== ' ' then
res = res' '
end
else if scanString(m) then
res = res || m.m.tok
else if scanChar(m, 1) then
res = res || m.m.tok
else if scanEnd(m) then do
m.m.tok = res
return res \== '' /* erst hier NACH scanCom, scanNl */
end
else
call scanErr m, 'bad pos'
end
endProcedure scanText
scanReadPos: procedure expose m.
parse arg m, msg
return m.m.lineX m.m.pos
endProcedure scanReadPos
scanReadInfo: procedure expose m.
parse arg m
msg = 'last token' m.m.tok 'scanPosition' ,
strip(substr(m.m.src, m.m.pos, 40), 't')
if scanEnd(m) then
msg = msg'\natEnd after'
else
msg = msg'\npos' m.m.pos 'in'
return msg 'line' m.m.lineX':' strip(m.m.src, 't')
endProcedure scanReadInfo
/*--- use scan sqlEdit macro --> temporarily here -------------------*/
/*--- read next line from edit data ---------------------------------*/
editRead: procedure expose m.
parse arg m, rStem
m.m.lineX = m.m.lineX + 1
if adrEdit('(ll) = line' m.m.lineX, 12) \= 0 then
return 0
m.rStem.1 = ll
m.rStem.0 = 1
return 1
endProcedure editRead
/*--- search loop in edit macro -------------------------------------*/
scanSqlSeekId: procedure expose m.
parse arg m, lx, cmd, opts
if opts = '' then
opts = word
/* line 1 col 0, otherwise first word is skipped*/
if adrEdit("cursor =" max(trunc(lx), 1) 0, 12) = 12 then
return -1
do while adrEdit("seek" cmd opts, 4) = 0 /* find each command*/
call adrEdit "(fx) = cursor"
if m.debug then do
call adrEdit "(LI) = LINE" fx
call debug 'scanSqlSeekId after' lx 'found' cmd 'at' fx li
end
call jReset m.m.rdr, fx
call jOpen m, '<'
m.m.lineX = fx
do while word(scanPos(m), 1) <= fx & scanSqlClass(m)
if m.m.sqlClass = 'i' & m.m.val == cmd then
return fx
end
call jClose m
end
return -1
endProcedure scanSqlSeekId
/* copy scanRead end *************************************************/
}¢--- A540769.WK.REXX(SCANSB) cre= mod=-. --------------------------------------
/* copy scanSB begin ************************************************
Achtung: inc generiert SB aus scan, Aenderungen nur in scan|
SB = scanBasic: single line, no reader, no newLines, class not needed
scanSrc(m, source) starts scanning a single line = scanBasic
scanLook(m,len) : returns next len chars, pos is not moved
scanChar(m,len) : scans next len chars
scanString(m,q): scan a String with quote q. (with doubble = 1)
scanVerify(m,c,o): verify(...,c,o,...)
scanEnd(m) : returns whether we reached end of input
scanLit(m,lit) : scan Literal lit if present or return 0
scanChar(m,n) : scan next n characters
scanName(m) : scan a name
ScanNat(m) : scan a natural number (without sign)
scanString(m,q): scan a String with quote q. (with doubble = 1)
scanVerify(m,c,o): verify(...,c,o,...)
scanKeyValue(m): scan a key = value clause (with spaces)
scanWord(m,st,uc) : scan a space delimited word or a string,
st=stopper, if u=1 then uppercase non-strings
scanSpace(m) : skips over spaces (and nl and comment if \ basic
scanInfo(m) : text of current scan location
scanErr(m, txt): error with current scan location
m is an address, to store our state
returns: true if scanned, false otherwise
if a scan function succeeds, the scan position is moved
m.m.tok ==> last token
m.m.val ==> last value for scanString/Word
m.m.pos ==> scan position
m.m.src ==> scan source
**********************************************************************/
/*--- start basic scannig: set new src, reset outFields -------------*/
scanSrc: procedure expose m.
parse arg m, m.m.src
m.m.pos = 1
m.m.tok = ''
/* assignment deleted by inc#mbrTransfor2 */
return m
endProcedure scanSrc
scanBasic: procedure expose m.
parse arg src
if symbol('m.scan.0') == 'VAR' then
m.scan.0 = m.scan.0 + 1
else
m.scan.0 = 1
return scanSrc('SCAN.'m.scan.0, src)
endProcedure scanBasic
scanEr3: procedure expose m.
parse arg m, txt, info
return err('s}'txt'\n'info)
scanErr: procedure expose m.
parse arg m, txt
if arg() > 2 then
return err(m,'old interface scanErr('m',' txt',' arg(3)')')
return scanEr3(m, txt, scanInfo(m))
/*--- scanInfo: text of current scan position for scanErr -----------*/
scanInfo: procedure expose m.
parse arg m
/* if deleted by inc#mbrTransfor2 */
return scanSBInfo(m)
endProcedure scanInfo
scanSBInfo: procedure expose m.
parse arg m
return 'last token' m.m.tok 'scanPosition' ,
strip(substr(m.m.src, m.m.pos, 40), 't') ,
|| '\npos' m.m.Pos 'in string' strip(m.m.src, 't')
/*--- return the next len characters until end of src ---------------*/
scanLook: procedure expose m.
parse arg m, len
if len == '' then
return substr(m.m.src, m.m.pos)
else
return substr(m.m.src, m.m.pos,
, min(len, 1 + length(m.m.src) - m.m.pos))
endProcedure scanLook
/*--- scan len chararcters, atmost to end of src --------------------*/
scanChar: procedure expose m.
parse arg m, len
m.m.tok = scanLook(m, len)
m.m.pos = m.m.pos + length(m.m.tok)
return m.m.tok \== ''
endProcedure scanChar
/*--- scan the literal lit ------------------------------------------*/
scanLit: procedure expose m.
parse arg m
do ax=2 to arg()
if abbrev(substr(m.m.src, m.m.pos), arg(ax)) then do
m.m.tok = arg(ax)
m.m.pos = m.m.pos + length(arg(ax))
return 1
end
end
m.m.tok = ''
return 0
endProcedure scanLit
/*--- scan with verify, vOpt is passed to verify --------------------*/
scanVerify: procedure expose m.
parse arg m, alpha, vOpt
if vOpt == '' then /* empty string does not take default */
nx = verify(m.m.src, alpha, , m.m.pos)
else
nx = verify(m.m.src, alpha, vOpt, m.m.pos)
if nx = 0 then
nx = length(m.m.src) + 1
m.m.tok = substr(m.m.src, m.m.pos, nx - m.m.pos)
m.m.pos = nx
return m.m.tok \== ''
endProcedure scanVerify
/*--- scan while in charset -----------------------------------------*/
scanWhile: procedure expose m.
parse arg m, chSet
return scanVerify(m, chSet, 'n')
/*--- scan until in charset -----------------------------------------*/
scanUntil: procedure expose m.
parse arg m, chSet
return scanVerify(m, chSet, 'm')
/*--- scan until (and over) string End ------------------------------*/
scanStrEnd: procedure expose m.
parse arg m, sep
sx = m.m.pos
bx = sx
do forever
ex = pos(sep, m.m.src, sx)
if ex = 0 then do
m.m.val = m.m.val || substr(m.m.src, bx)
return 0
end
m.m.val = m.m.val || substr(m.m.src, bx, ex-bx)
bx = ex + length(sep)
if \ abbrev(substr(m.m.src, bx), sep) then do
m.m.tok = m.m.tok || substr(m.m.src, m.m.pos, bx-m.m.pos)
m.m.pos = bx
return 1
end
sx = bx + length(sep)
end
endProcedure scanStrEnd
/*--- scan a string with quote char qu ------------------------------*/
scanString: procedure expose m.
parse arg m, prefs
if prefs = '' then do
call scanLit m, "'", '"'
end
else do
do px=1 to words(prefs) until scanLit(m, word(prefs, px))
end
end
if m.m.tok == '' then
return 0
m.m.val = ''
if \ scanStrEnd(m, m.m.tok) then
return scanErr(m, 'ending Apostroph missing')
return 1
endProcedure scanString
/*--- scan a word and put value into *.val
a word is either delimited by space or stopper
or a string (with single or double quotes ------*/
scanWord: procedure expose m.
parse arg m, stopper, ucWord
if scanString(m) then
return 1
if stopper == '' then
stopper = m.ut_space
if \scanUntil(m, stopper) then
return 0
if ucWord == 1 then
m.m.val = translate(m.m.tok)
else
m.m.val = m.m.tok
return 1
endProcedure scanWord
/*--- skip, scan and return word or scanErr -------------------------*/
scanRetWord: procedure expose m.
parse arg m, stopper, ucWord, eWhat
if scanWord(scanSKip(m), stopper, ucWord) then
return m.m.val
else
return scanErr(m, eWhat 'expected')
endProcedure scanRetWord
/*--- scan a key = word phrase
put key into m.key and word into m.m.val -------*/
scanKeyValue: procedure expose m.
parse arg m, def, uc
if \ scanWord(m, ' =''"') then
return 0
m.m.key = m.m.val
if \ scanLit(scanSkip(m), '=') then
m.m.val = def
else if \ scanWord(scanSkip(m)) then
return scanErr(m, 'word expected after' m.m.key '=')
if uc == 1 then
upper m.m.key m.m.val
return 1
endProcedure scanKeyValue
/*--- scan over space, nl, comments ---------------------------------*/
scanSpace: procedure expose m.
parse arg m
/* if deleted by inc#mbrTransfor2 */
return scanSpaceOnly(m)
endProcedure scanSpace
scanSpaceOnly: procedure expose m.
parse arg m
nx = verify(m.m.src, m.ut_space, , m.m.pos)
if nx = 0 then
nx = length(m.m.src) + 1
m.m.tok = left(' ', nx <> m.m.pos)
m.m.pos = nx
return m.m.tok == ' '
endProcedure scanSpaceOnly
/*--- skip over space and return m ----------------------------------*/
scanSkip: procedure expose m.
parse arg m
call scanSpace m
return m
endProcedure scanSkip
/*--- return true if at end of src ----------------------------------*/
scanEnd: procedure expose m.
parse arg m
if m.m.pos <= length(m.m.src) then
return 0
else /* if deleted by inc#mbrTransfor2 */
return 1
endProcedure scanEnd
/*--- scan a natural number (no sign, decpoint ...) Ignore After ----*/
scanNatIA: procedure expose m.
parse arg m
return scanVerify(m, '0123456789')
/*--- scan an integer (optional sign, no decpoint ...) Ignore After -*/
scanIntIA: procedure expose m.
parse arg m
poX = m.m.pos
call scanLit m, '-', '+'
if \ scanNatIA(m) then do
m.m.pos = poX
return 0
end
m.m.tok = substr(m.m.src, poX, m.m.pos - poX)
return 1
endProcedure scanIntIA
/*--- scanOpt set the valid characters for names, and comments
it must be called
before any of the following functions ---------------------*/
scanOpt: procedure expose m.
parse arg m, m.m.scanName1, namePlus, m.m.scanComment, nest
if m.m.scanName1 == '' then
m.m.scanName1 = m.ut_alfa
if namePlus == '' then
m.m.scanNameR = m.m.scanName1 || '0123456789'
else
m.m.scanNameR = m.m.scanName1 || namePlus
m.m.scanNestCom = nest == 1
return m
endProcedure scanOpt
/*--- return true if at comment -------------------------------------*/
scanSBCom: procedure expose m.
parse arg m
m.m.tok = ''
if m.m.scanComment == '' then
return 0
if \ abbrev(substr(m.m.src, m.m.pos), m.m.scanComment) then
return 0
m.m.tok = substr(m.m.src, m.m.pos)
m.m.pos = 1 + length(m.m.src)
return 1
endProcedure scanSBCom
/*--- scan a Name, first char in *.scanName1, rest in *.scanNameR ---*/
scanName: procedure expose m.
parse arg m
if pos(substr(m.m.src, m.m.pos, 1),
, m.m.scanName1) <= 0 then do
m.m.tok = ''
return 0
end
return scanVerify(m, m.m.scanNameR)
endProcedure scanName
/*--- check character after a number
must not be Identifier or plus ----------------------------*/
scanCheckNumAfter: procedure expose m.
parse arg m, res, plus
if \ res then
return 0
if pos(substr(m.m.src, m.m.pos, 1), m.m.scanNameR || plus) > 0 then
call scanErr m, 'illegal char after number' m.m.tok
return 1
endProcedure scanCheckNumAfter
/*--- scan a natural number check character after -------------------*/
scanNat: procedure expose m.
parse arg m
if arg() \== 1 then
return err('old interface scanNat') / 0
return scanCheckNumAfter(m, scanNatIA(m), '.')
endProcedure ScanNat
/*--- scan an Integer check character after -------------------------*/
scanInt: procedure expose m.
parse arg m
if arg() \== 1 then
return err('old interface scanInt') / 0
return scanCheckNumAfter(m, scanIntIA(m), '.')
endProcedure ScanInt
/*--- scan a Number check character after ---------------------------*/
scanNum: procedure expose m.
parse arg m
if arg() \== 1 then
return err('old interface scanNum') / 0
return scanCheckNumAfter(m, scanNumIA(m))
endProcedure ScanInt
/*--- scan a number (optional sign, decpoint, exponent) Ignore After-*/
scanNumIA: procedure expose m.
parse arg m
poX = m.m.pos
call scanLit m, '-', '+'
cx = scanNumUSPos(m)
if cx == 0 then do
m.m.pos = poX
return 0
end
m.m.tok = substr(m.m.src, poX, cx-poX)
m.m.val = translate(m.m.tok)
m.m.pos = cx
return 1
endProcedure scanNumIA
/*--- scan unsigned number (opt. decpoint, exponent) Ignore After ---*/
scanNumUSPos: procedure expose m.
parse arg m
poX = m.m.pos
cx = verify(m.m.src, '0123456789', , poX)
if cx > 0 then
if substr(m.m.src, cx, 1) == '.' then
cx = verify(m.m.src, '0123456789', , cx+1)
if cx < 1 then do
if abbrev('.', substr(m.m.src, poX)) then
return 0
end
else if abbrev('.', substr(m.m.src, poX, cx-poX)) then do
return 0
end
else if pos(substr(m.m.src, cx, 1), 'eE') > 0 then do
cy = cx + 1 + (pos(substr(m.m.src, cx+1, 1), '-+') > 0)
cx = verify(m.m.src, '0123456789', , cy)
if cx==cy | (cx == 0 & cy > length(m.s.src)) then
call scanErr m, 'exponent expected after E'
end
if cx >= poX then
return cx
else
return length(m.s.src)+1
/*
m.m.tok = substr(m.m.src, poX, cx-poX)
m.m.pos = cx
end
else do
m.m.tok = substr(m.m.src, poX)
m.m.pos = length(m.s.src)+1
end
m.m.val = translate(m.m.tok)
return 1 */
endProcedure scanNumUSPos
scanType: procedure expose m.
parse arg m, opt
m.m.tok = ''
if scanName(m) then
m.m.type = 'n'
else if scanNum(m) then
m.m.type = 0
else if scanString(m) then
m.m.type = left(m.m.tok, 1)
else if scanSpace(m) then
m.m.type = 's'
else do
call scanChar m, 1
m.m.type = m.m.tok
end
return m.m.type
endProcedure scanType
/* copy scanSB end *************************************************/
}¢--- A540769.WK.REXX(SCANSQL) cre=2016-08-23 mod=2016-08-23-05.32.51 A540769 ---
/* copy scanSql begin ************************************************/
/*--- initialize with reader inRdr ----------------------------------*/
scanSqlReset: procedure expose m.
parse arg m, r, scanWin, stmtOpt
call scanSqlStmtOpt scanSqlOpt(m), strip(stmtOpt)
if scanWin \== 0 then
return scanWinReset(m, r, scanWin)
else if r \== '' then
return scanReadReset(m, r)
else
return scanSrc(m, m.m.src)
endProcedure scanSqlReset
scanSqlOpt: procedure expose m.
parse arg m
return scanOpt(m, m.ut_alfa'$#@', '0123456789_' , '--', 1)
endProcedure scanSqlOpt
/*--- scan a sql token put class in m.sqlclass:
'i': ordinary identifier e.g. Name
'd': delimited identifier e.g. "Delimited"
'q': qualified identifier e.g. abc."efg"
'u': integer units e.g. 8G
'n': number e.g. -234 or .2e3
's': string e.g. 'abc''ef'
'' : at end
: any other character e.g. ;
---------------------------------------------------------------*/
scanSqlClass: procedure expose m.
parse arg m, retSpace
m.m.val = ''
if scanSpNlCo(m) & retSpace = 1 then do
m.m.sqlClass = 'b'
return 1
end
c2 = scanLook(m ,2)
if scanLit(m, "'", "x'", "X'") then do
if \ scanStrEnd(m, "'") then
call scanErr m, 'ending apostroph missing'
m.m.sqlClass = 's'
if \abbrev(m.m.tok, "'") then
m.m.val = x2c(m.m.val)
end
else if scanSqlQuId(m, 1) then do
if m.m.val.0 > 1 then
m.m.sqlClass = 'q'
else if abbrev(m.m.tok, '"') then
m.m.sqlClass = 'd'
else
m.m.sqlClass = 'i'
end
else if scanSqlNumPM(m) then do
if m.m.tok == '-' | m.m.tok == '+' then
m.m.sqlClass = m.m.tok
else
m.m.sqlClass = 'n'
end
else if scanChar(m, 1) then
m.m.sqlClass = m.m.tok
else if scanEnd(m) then do
m.m.sqlClass = ''
return 0
end
else
call scanErr m, 'cannot scan sql'
return 1
endProcedure scanSqlClass
scanSqlSkipBrackets: procedure expose m.
parse arg m, br
if br \== '' then
nop
else if scanLit(m, '(') then
br = 1
else
return 0
do while scanSqlClass(m) & m.m.sqlClass \== ';'
if m.m.sqlClass = '(' then br = br + 1
else if m.m.sqlClass \== ')' then iterate
else if br > 1 then br = br - 1
else return 1
end
call scanErr m, '; or eof, but' br 'closing ) expected'
endProcedure skipBrackets
/*--- scan an ordinary sql identifier e.g. abc, ef_12 ---------------*/
scanSqlId: procedure expose m.
parse arg m
if \ scanName(m) then
return 0
m.m.val = translate(m.m.tok)
return 1
endProcedure scanSqlId
/*--- scan a delimited or ordinay sql identifier --------------------*/
scanSqlDeId: procedure expose m.
parse arg m
if scanSqlId(m) then
return 1
if \ scanString(m, '"') then
return 0
m.m.val = strip(m.m.val, 't')
return 1
endProcedure scanSqlDeId
/*--- scan a qualified sql identifier -------------------------------*/
scanSqlQuId: procedure expose m.
parse arg m, starOk
res = ''
rto = ''
do qx=1
if \ scanSqlDeId(m) then do
if qx == 1 then
return 0 /* sometimes last qual may be '*' */
if starOk \== 1 | \ scanLit(m, '*') then
call scanErr m, 'id expected after .'
else if scanLit(scanSkip(m), '.') then
call scanErr m, 'dot after id...*'
else
leave
end
m.m.val.qx = m.m.val
res = res'.'m.m.val
rto = rto'.'m.m.tok
if \ scanLit(scanSkip(m), '.') then
leave
call scanSpace m
end
m.m.val.0 = qx
m.m.val = substr(res, 2)
m.m.tok = substr(rto, 2)
return 1
endProcedure scanSqlQuId
/*--- scan a sql number, Ignore After -------------------------------*/
scanSqlNumIA: procedure expose m.
parse arg m
if \ scanSqlNumPM(m) then
return 0
else if m.m.tok == '+' | m.m.tok == '-' then
call scanErr m, 'no sqlNum after +-'
return 1
endProcedure scanSqlNumIA
/*--- scan a sql number, + or -, ignore after -----------------------*/
scanSqlNumPM: procedure expose m.
parse arg m
if scanLit(m, '+', '-') then do
si = m.m.tok
call scanSkip m
end
else
si = ''
cx = scanNumUSPos(m)
if cx == 0 then do
m.m.val = si
m.m.tok = si
return si \== ''
end
m.m.tok = si || substr(m.m.src, m.m.pos, cx-m.m.pos)
m.m.val = translate(m.m.tok)
m.m.pos = cx
return 1
endProcedure scanSqlNumIA
/*--- scan a sql number, check After --------------------------------*/
scanSqlNum: procedure expose m.
parse arg m
if arg() \== 1 then
return err('old interface scanSqlNum') / 0
return scanCheckNumAfter(m, scanSqlNumIA(m))
endProcedure ScanSqlNum
/*--- scan a sql number with a unit which may follow without space --*/
scanSqlNumUnit: procedure expose m.
parse arg m, both, units
if \ scanSqlNumIA(m) then
return 0
nu = m.m.val
sp = scanSpace(m)
if scanSqlId(m) then do
if units == '' | wordpos(m.m.val, units) > 0 then
nu = nu m.m.val
else if both | \ sp then
call scanErr m, 'bad unit' m.m.val 'after' nu
else
call scanBack m, m.m.tok
end
else if both then
call scanErr m, 'no unit after' nu
else if \sp & pos(scanLook(m, 1), m.m.scanNameR) > 0 then
call scanErr m, 'bad unit after number' nu
m.m.val = nu
return 1
endProcedure scanSqlNumUnit
/*--- find next statement, after scanSqlStmtOpt -----------------------
m.m.stop contains delimiter, will be changed by
terminator?; or --#terminator */
scanSqlStmtOpt: procedure expose m.
parse arg m, m.m.stop
if m.m.stop == '' then
m.m.stop = ';'
return m
endProcedure scanSqlStmtOpt
scanSqlStop: procedure expose m.
parse arg m
res = ''
fuCo = copies(m.m.scanComment'#SET', m.m.scanComment \== '')
u1 = '''"'left(m.m.scanComment, m.m.scanComment \== '')
do lx=1
if lx > 100 then
say '????iterating' scanLook(m)
if m.m.stop == '' then
scTx = scanTextCom(m, u1 ,fuCo)
else
scTx = scanTextCom(m, u1||left(m.m.stop,1), m.m.stop fuCo)
if scTx then
res = res || m.m.tok
if fuCo \== '' then
if scanLook(m, length(fuCo)) == fuCo then do
if scanCom(m) then do
tx = m.m.tok
if word(tx, 2) == 'TERMINATOR' ,
& length(word(tx, 3)) == 1 then do
m.m.stop = word(tx, 3)
if \ (right(res, 1) == ' ' ,
| scanLook(m, 1) == ' ') then
res = res' '
end
else
say 'ignoring --##SET at' scanInfo(m)
end
iterate
end
if m.m.stop \== '' then
call scanLit m, m.m.stop
res = strip(res)
if length(res)=11 ,
& abbrev(translate(res), 'TERMINATOR') then do
m.m.stop = substr(res, 11, 1)
res = ''
end
return res
end
endProcedure scanSqlStop
scanSqlStmt: procedure expose m.
parse arg m
do forever
res = scanSqlStop(m)
if res <> '' then
return res
if scanEnd(m) then
return ''
end
endProcedure scanSqlStmt
/*-- return next sqlStmt from rdr ( or string or '' = j.in) ---------*/
scanSqlIn2Stmt: procedure expose m.
parse arg rdr, wOpt
s = scanSqlIn2Scan(rdr, m'.SCAN_SqlIn2Stmt', wOpt)
res = scanSqlStmt(scanOpen(s))
call scanReadClose s
return res
endProcedure scanSqlIn2Stmt
/*-- reset s as scanSql from rdr ( or string or '' = j.in) ----------*/
scanSqlIn2Scan: procedure expose m.
parse arg m, s, wOpt, sOpt
if m \== '' & wOpt == '' then
if oKindOfString(m) then
wOpt = 0
return scanSqlReset(s, in2File(m), wOpt, sOpt)
endProcedure scanSqlIn2Scan
/*-- create a new scanSqlStmtRdr ------------------------------------*/
scanSqlStmtRdr: procedure expose m.
parse arg rdr, wOpt, sOpt
return oNew('ScanSqlStmtRdr', rdr, wOpt, sOpt)
/*-- reset a new scanSqlStmtRdr
must be called from jReset to allow jRead ------------------*/
scanSqlStmtRdrReset: procedure expose m.
parse arg m, rdr, wOpt, sOpt
call scanSqlIn2Scan rdr, m'.SCAN', wOpt, sOpt
return oMutate(m, m.class_ScanSqlStmtRdr)
endProcedure scanSqlStmtRdrReset
/* copy scanSql end ************************************************/
}¢--- A540769.WK.REXX(SCANUTIL) cre=2016-08-09 mod=2016-08-09-10.24.49 A540769 ---
/* copy scanUtil begin ************************************************
scan db2 utility input statements using scan and a reader
**********************************************************************/
/*--- initialize with reader inRdr ----------------------------------*/
scanUtilOpt: procedure expose m.
parse arg m
call scanSqlOpt m
m.m.scanNestCom = 0
m.m.utilBrackets = 0
m.scanUtil = 'BACKUP CATENFM CATMAINT CHECK' ,
'COPY COPYTOCOPY DIAGNOSE EXEC LISTDEF LOAD' ,
'MERGECOPY MODIFY OPTIONS QUIESCE REBUILD' ,
'RECOVER REORG REPAIR REPORT RESTORE' ,
'RUNSTATS STOSPACE TEMPLATE UNLOAD'
return m
endProcedure scanUtilOpt
/*--- scan next token and put its class in m.sc.utilClass:
'u' a utility name
'n' a name
'"' a quoted name
"'" an apostroph'd string
'.' a .
',' a ,
'v' a value
'' at end
---------------------------------------------------------------*/
scanUtil: procedure expose m.
parse arg sc
m.sc.utilSpace = scanSpace(sc)
ty = '?'
if scanLit(sc, '(') then do
m.sc.utilBrackets = m.sc.utilBrackets + 1
end
else if scanLIT(sc, ')') then do
m.sc.utilBrackets = m.sc.utilBrackets - 1
if m.sc.utilBrackets < 0 then
call scanErr sc, 'unmatched closing bracket )'
end
else if scanLit(sc, ',') then do
end
else if scanLit(sc, '.') then do
end
else if scanString(sc, "'") then do
end
else if scanString(sc, '"') then do
end
else if scanName(sc) then do
m.sc.val = translate(m.sc.tok)
if m.sc.utilBrackets > 0 then
ty = 'n'
else if 0 < wordPos(m.sc.val, m.scanUtil) then
ty = 'u'
else
ty = 'n'
end
else if scanVerify(sc, ' (),''"', 'm') then do
ty = 'v'
m.sc.val = translate(m.sc.tok)
end
else if \scanEnd(sc) then do
call scanErr sc, 'scanUtil stopped before end'
end
else do
ty = ''
m.sc.val = ''
end
if ty == '?' then
m.sc.utilClass = left(m.sc.tok, 1)
else
m.sc.utilClass = ty
return m.sc.utilClass
endProcedure scanUtil
/*--- scan a value or a bracketed list of values --------------------*/
scanUtilValue: procedure expose m.
parse arg sc, remApo, nl
if remApo = '' | rempApo = 0 then
remApo = "nv"
else if rempApo = 1 then
remApo = "nv'"
if '(' \== scanUtil(sc) then
return scanUtilValueOne(sc, remApo)
v = ''
brx = m.sc.utilBrackets
oLine = word(scanPos(sc), 1)
do forever
call scanUtil sc
one = scanUtilValueOne(sc, remApo)
if one == '' then
call scanErr sc, 'eof in brackets'
else if brx > m.sc.utilBrackets then
return v
nLine = word(scanPos(sc), 1)
if \ m.sc.utilSpace then
v = v || one
else if nl \== '' & oLine <> nLine then
v = v || nl || one
else
v = v' 'one
oLine = nLine
end
endProcedure scanUtilValue
scanUtilValueOne: procedure expose m.
parse arg sc, valTy
if m.sc.utilClass == '' then
return ''
else if m.sc.utilClass == 'u' then
call scanErr sc, 'util in scanUtilValueOne'
if pos(m.sc.utilClass, valTy) > 0 then
return m.sc.val
else
return m.sc.tok
endProcedure scanUtilValueOne
/*--- skip over nested brackets -------------------------------------*/
scanUtilSkipBrackets: procedure expose m.
parse arg m, br, doCat
if br \== '' then
lim = m.m.utilBrackets - br
else if scanLit(m, '(') then do
lim = m.m.utilBrackets
m.m.utilBrackets = lim + 1
end
else
return 0
doCat = doCat == 1
res = ''
do while scanUtil(m) \== ''
if m.m.utilBrackets <= lim then do
if doCat then
m.m.val = res
return 1
end
if doCat then
res = res m.m.tok
end
return scanErr(m, 'eof with' m.m.utilBrackets 'open (')
endProcedure skipBrackets
/*--- analyze a punch file write intoField to stdOut ----------------*/
scanUtilInto: procedure expose m.
parse arg m
if m.m.utilBrackets \== 0 then
call scanErr m, 'scanUtilInto with brackets' m.m.utilBrackets
/*sc = scanUtilReader(m.j.in)
call jOpen sc, 'r'
*/ do forever
cl = scanUtil(m)
if cl == '' then
return 0
if cl = 'n' & m.m.tok == 'INTO' then
leave
end
if scanUtil(m) \== 'n' | m.m.tok \== 'TABLE' then
call scanErr m, 'bad into table '
if \ scanSqlQuId(scanSkip(m)) then
call scanErr m, 'table name expected'
if m.m.utilBrackets \== 0 then
call scanErr m, 'into table in brackets' m.m.utilBrackets
m.m.tb = m.m.val
m.m.part = ''
m.m.when = ''
do forever
cl = scanUtil(m)
if cl == '' then
call scanErr m, 'eof after into'
if cl == 'n' & m.m.tok == 'PART' then do
if scanUtil(m) == 'v' then
m.m.part = m.m.val
else
call scanErr m, 'bad part'
end
else if cl=='n' & wordPos(m.m.val, 'WHEN WORKDDN') > 0 then do
call scanUtilSkipBrackets m
end
else if cl == '(' then do
leave
end
end
oX = m.m.lineX
oL = overlay('', m.m.src, 1, m.m.pos-2)
do while m.m.utilBrackets > 0
call scanUtil m
if oX \== m.m.lineX then do
call out strip(oL, 't')
oX = m.m.lineX
oL = m.m.src
end
end
call out left(oL, m.m.pos)
/* call jClose sc
*/ return 1
endProcedure scanUtilInto
/* copy scanUtil end *************************************************/
}¢--- A540769.WK.REXX(SCANWIN) cre=2016-08-12 mod=2016-08-12-16.03.46 A540769 ---
/* copy scanWin begin *************************************************
scan the the concatenation of the lines of a reader
any token my be split over several line
except the end-of-line-comment-token
**********************************************************************/
scanWinIni: procedure expose m.
if m.scanWin.ini = 1 then
return
m.scanWin.ini = 1
call scanReadIni
call classNew 'n ScanWin u ScanRead', 'm',
, "oReset call scanWinReset m, arg, arg2",
, "jOpen call scanWinOpen m, arg(3)",
, "jClose call scanReadClose m",
, 'scanNL return scanWinNl(m, unCond)',
, 'scanCom return scanWinCom(m)',
, 'scanInfo return scanWinInfo(m)',
, 'scanPos return scanWinPos(m)',
, 'isWindow 1'
return
endProcedure scanWinIni
/*--- instanciate a new window scanner ------------------------------*/
scanWin: procedure expose m.
parse arg rdr, wOpts
return oNew(m.class_ScanWin, rdr, wOpts)
/*--- set the reader and window attributes of scanner m -------------*/
scanWinReset: procedure expose m.
parse arg m, m.m.rdr, winOpt
return scanSqlOpt(scanWinOpt(oMutate(m, m.class_ScanWin), winOpt))
/*--- set the window scanner attributes -----------------------------*/
scanWinOpt: procedure expose m.
parse arg m, cuLe wiLi wiBa
if pos('@', cuLe) > 0 then
parse var cuLe cuLe '@' m.m.cutPos
else
m.m.cutPos = 1
cuLe = word(cuLe 72, 1)
m.m.cutLen = cuLe /* fix recLen */
wiLe = cuLe * (1 + word(wiLi 5, 1))
m.m.posMin = word(wiba 3, 1) * cuLe /* room to go back */
m.m.posLim = m.m.posMin + wiLe
m.m.winTot = m.m.posLim + wiLe
return m
endProcedure scanWinReset
/*--- open reader and start scanning --------------------------------*/
scanWinOpen: procedure expose m.
parse arg m, line0
call jOpen m.m.rdr, '<'
if line0 == '' then
return scanSetPos0(m, 1 1)
if length(line0) // m.m.cutLen \== 0 then
line0 = line0||left('', m.m.cutLen - length(line0)//m.m.cutLen)
return scanSetPos0(m, (1 - length(line0) % m.m.cutLen) 1, line0)
endProcedure scanWinOpen
/*--- move the source window: cut left side and append at right side
return number of characters cut at left -----------------------*/
scanWinRead: procedure expose m.
parse arg m
dlt = 0
if m.m.atEnd then
return 0
if m.m.pos >= m.m.posLim then do /* cut left side */
dlt = m.m.pos - ((m.m.pos-1) // m.m.cutLen + 1 + m.m.posMin)
call assert 'dlt >= 0 & dlt // m.m.cutLen = 0','dlt m.m.cutLen'
m.m.src = substr(m.m.src, dlt+1)
m.m.pos = m.m.pos - dlt
m.m.lineX = m.m.lineX + dlt % m.m.cutLen
end
r = m.m.rdr
do while length(m.m.src) < m.m.winTot /* read and fill to len */
if \ jRead(r) then do
m.m.atEnd = 1
return dlt
end
m.m.src = m.m.src || substr(m.r, m.m.cutPos, m.m.cutLen)
end
call assert 'length(m.m.src) = m.m.winTot',
, 'm.m.winTot length(m.m.src) m.m.src'
return dlt
endProcedure scanWinRead
/*--- return position of next line start ----------------------------*/
scanWinNLPos: procedure expose m.
parse arg m
return m.m.pos + m.m.cutLen - ((m.m.pos - 1) // m.m.cutLen)
/*--- scan comment --------------------------------------------------*/
scanWinCom: procedure expose m.
parse arg m
call scanWinRead m
if m.m.scanComment \== '' then do
cl = length(m.m.scanComment)
if scanLook(m, cl) == m.m.scanComment then do
np = scanWinNlPos(m)
if np = m.m.pos then
np = np + m.m.cutLen
if np >= m.m.pos + cl then do
m.m.tok = substr(m.m.src, m.m.pos, np - m.m.pos)
m.m.pos = np
return 1
end
end
end
if m.m.scanNestCom then
if scanLit(m, '/*') then do
tk = substr(m.m.src, m.m.pos, m.m.cutLen + 2)
call scanTextCom m, , '*/'
if \ scanLit(m, '*/') then
call scanErr m, 'nested comment after /* not finished'
if pos('*/', tk) < 1 then
m.m.tok = left(tk, m.m.cutLen - 5)'...*/'
else
m.m.tok = left(tk, pos('*/', tk) + 1)
return 1
end
m.m.tok = ''
return 0
endProcedure scanWinCom
/*--- scan nl -------------------------------------------------------*/
scanWinNL: procedure expose m.
parse arg m, unCond
call scanWinRead m
m.m.tok = ''
if unCond \== 1 then
return 0
np = scanWinNLPos(m)
if np = m.m.pos then
return 0
if unCond == '?' then
return 1
m.m.tok = substr(m.m.pos, np-m.m.pos)
m.m.pos = np
return 1
endProcedure scanWinNl
/*--- return current position in input ------------------------------*/
scanWinPos: procedure expose m.
parse arg m
ps = m.m.pos - 1
return (m.m.lineX + (ps % m.m.cutLen)) (ps // m.m.cutLen + 1)
endProcedure scanWinPos
/*--- return a description of the current scan position -------------*/
scanWinInfo: procedure expose m.
parse arg m
p = scanWinPos(m)
if scanEnd(m) then do
res = 'atEnd after'
p = m.m.lineX - 1 + length(m.m.src) % m.m.cutLen
p = word(p, 1)
end
else do
res = 'pos' word(p, 2) 'in'
p = word(p, 1)
end
return 'last token' m.m.tok 'scanPosition' ,
strip(left(substr(m.m.src, m.m.pos), 40), 't') ,
|| '\n'res 'line' p':' strip(substr(m.m.src,
, 1 + (p - m.m.lineX) * m.m.cutLen, m.m.cutLen), 't')
endProcedure scanWinInfo
/* copy scanWin end ************************************************/
}¢--- A540769.WK.REXX(SECHS) cre=2009-05-07 mod=2009-05-07-17.03.15 F540769 ----
sechs 6.1
sechs 6.2
sechs 6.3
sechs 6.4
}¢--- A540769.WK.REXX(SENDJOB) cre=2009-12-07 mod=2014-01-10-09.27.42 A540769 ---
/* rexx ****************************************************************
send files, job and receceive outputs with CSM
node destNode set destination node
send fn send fn (filename or -dd)
job fn opt? cf mark send job from fn (filename or -dd),
communication file cf and mark mark
opt: leer or
123 timout secs (default 3600) or
//?? replace leading ?? by // or
123//?? timeout and replace
mark cf mark res mark communicationfile cf with mark mark
and result res (ok or errorMessage)
wait ti? cf mark wait with timeout ti secs (default 3600)
until communicationfile cf is marked ok
receive fn receive (filename or -dd)
************************************************************************
10.01.14 W. Keller wieder csm.div
27.09.13 W. Keller Anpassungen RZ4, neue Copies
07.12.09 W. Keller csm.div -> csm.rz1
05.09.08 W. Keller neu
***********************************************************************/
parse arg args
call errReset 'h'
if args = '?' then /* no help for //?? || */
return help()
else if args = '' then do
if 1 then
return errHelp('no args')
args = 'node rz1 mark A540769.tmp.ganz.neu(eins) hier submit' ,
'node rr2' ,
'job A540769.WK.JCL(sendJobI) 9//?? ' ,
' A540769.tmp.e.d(sejoTest) sejoTest' ,
'receive A540769.TMP.TEXT(BBB)'
end
/* 'mark A540769.tmp.b.c(d) markMarjk ok',
'job A540769.WK.TEST(RUN) 13 A540769.tmp.b.c(cf) jobEins'
*/
defTimeOut = 3600
ax = 1
do forever
parse value subword(args, ax, 5) with w1 w2 w3 w4 w5 .
upper w1
em = w1 '(word' ax' in' space(args, 1)')'
if w1 = '' then
leave
if w2 = '' then
call errHelp 'argument missing for' em
if w1 = 'NODE' then do
m.node = w2
ax = ax + 2
end
else if m.node = '' then do
call errHelp 'first statement not NODE in' em
end
else if w1 = 'JOB' then do
cc = (datatype(w3, 'N') | pos('//', w3) > 0) + 4
ax = ax + cc
if value('w'cc) = '' then
call errHelp 'argument missing for' em
if cc = 5 & abbrev(w3, '//') then
w3 = defTimeOut || w3
if cc = 5 then
call job w2, w3, w4, w5
else
call job w2, defTimeOut, w3, w4
end
else if w1 = 'MARK' then do
if w4 = '' then
call errHelp 'argument missing for' em
call mark w2, w3, w4
ax = ax + 4
end
else if w1 = 'RECEIVE' then do
say 'copying' m.node'/'w2 'to */'w2
call csmCopy m.node'/'w2, '*/'w2
ax = ax + 2
end
else if w1 = 'SEND' then do
say 'copying' '*/'w2 'to' m.node'/'w2
call csmCopy '*/'w2, m.node'/'w2
ax = ax + 2
end
else if w1 = 'WAIT' then do
cc = datatype(w2, 'N')+3
ax = ax + cc
if value('w'cc) = '' then
call errHelp 'argument missing for' em
if datatype(w3, 'N') then
call wait w2, w3, w4
else
call wait defTimeOut, w2, w3
end
else do
call errHelp 'bad statement' em
end
end
exit
job: procedure expose m.
parse arg jo, tiOu '//' rep, cf, mark
sysl = csmSysDsn(m.node'/')
if sysl = '*/' then
sysl = ''
say 'job from' jo 'tiOu' tiOu 'communicationfile' cf 'mark' mark
call mark sysl || cf, mark, 'submit'
call readDsn jo, j.
if rep ^= '' then
do jx=1 to j.0
if abbrev(j.jx, rep) then
j.jx = '//'substr(j.jx, length(rep)+1)
end
call writeDsn sysl 'SYSOUT(T) dd(ir) .WRITER(INTRDR)', j.
call wait tiOu, cf, mark
return
endProcedure job
wait: procedure expose m.
parse arg tiOu, cf, mark
sysl = csmSysDsn(m.node'/')
if sysl = '*/' then
sysl = ''
cf = sysl || cf
tot = 0
info = 'job' mark 'on' cf
do dly=1 by 1
say time() 'after' tot 'secs, waiting for' info
call sleep min(dly, 60)
tot = tot + min(dly, 60)
call readDsn cf, j.
if j.0 ^== 1 then
call err 'communicationFile' cf 'has' j.0 'records not 1'
if ^ abbrev(j.1, mark' ') then
call err 'communicationFile' cf 'should start with' mark,
'not' strip(j.1, 't')
rst = strip(substr(j.1, length(mark)+2))' '
upper rst
if abbrev(rst, 'OK') then do
say time() 'after' tot 'secs' info 'ended ok:' strip(j.1)
return
end
if ^ abbrev(rst, 'SUBMIT') then
call err info 'ended with error' strip(j.1, 't')
else if tot >= tiOu then
call err info 'timed out after' tot 'secs'
end
return
endProcedure job
mark: procedure expose m.
parse arg cf, mark, res
o.1 = mark res
say 'mark communicationfile' cf 'with' o.1
call writeDsn cf '::F', o., 1, 1
return
endProcedure mark
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
/* copy csm begin ******************************************************
interface to csm,
it is integrate with adrTso, eg. dsnAlloc , 'RZ3/..' uses csm
***********************************************************************/
adrCsm:
return adrTso('csmExec' arg(1), arg(2))
endProcedure adrCsm
csmCopy: procedure expose m.
parse arg csnFr, csnTo, 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
parse value csmSysDsn(csnFr) with sysFr '/' dsnFr
parse value csmSysDsn(csnTo) with sysTo '/' dsnTo
if sysTo = '*' then do
old = sysDsn("'"dsnTo"'")
end
else if sysFr = '*' then do
pdsTo = dsnSetMbr(dsnTo)
al = "SYSTEM("sysTo") DDNAME(COPYTo)",
"DATASET('"pdsTo"') DISP(SHR)"
alRes = dsnAlloc(systo'/'pdsTo, ,'COPYTO', '*')
if datatype(alRes, 'n') then do
/* wir müssen es selbst allozieren csmxUtil
vergisst management class ||||| */
say 'could not allocate' al
say 'trying to create'
rc = listDsi("'"dsnSetMbr(dsnFr)"' SMSINFO")
if rc = 0 then
mv = ''
else if rc = 4 & sysReason = 19 then do
mv = 'UCOUNT(30)' /* 7.8.13 corrected attribute */
mv = 'UNITCNT(30)' /* 3.10.13 wieder zurueck */
say 'creating' dsn 'with multi volume' mv
end
else if rc \= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
al = left(al, length(al)-4)'CAT)'
if right(sysDsSms, 7) == 'LIBRARY' ,
| abbrev(sysDsSms, 'PDS') then
al = al 'DSNTYPE(LIBRARY)'
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
al = al "DSORG("sysDSorg") MGMTCLAS("sysMgmtClass")",
"RECFM("sysREcFM") LRECL("SYSLRECL")",
"blksize("sysBLkSIZE")",
"SPACE("sysPrimary"," sysSeconds")" sysUnits mv
call adrCsm "allocate" al
end
call tsoFree word(alRes, 2)
end
c = "'COPY" sysFr"/''"dsnFr"'' TO" ,
sysTo"/''"dsnSetMbr(dsnTo)"'' REPLACE'"
csmRc = adrTso("exec 'CSM.DIV.P0.EXEC(CSRXUTIL)'",
c , retOk)
if sysTo = '*' & old <> 'OK' then do
/* csm normally does not set mgmtclass - avoid delete | */
call adrTso "ALTER '"dsnTo"' mgmtclas(COM#A091)"
end
return csmRc
endProcedure csmCopy
csmAlloc: procedure expose m.
parse arg dsn dd disp rest ':' nn, retRc
sys = ''
a2 = ''
parse value csmSysDsn(dsn) with sys '/' dsn
if disp = '' then
disp = 'shr'
al = "SYSTEM("sys") DDNAME("dd")"
if dsn <> '' then do
a2 = "DATASET('"dsnSetMbr(dsn)"')"
mbr = dsnGetMbr(dsn)
if mbr <> '' then
a2 = a2 'MEMBER('mbr')'
end
if abbrev(disp, 'SYSOUT(') then
a2 = a2 disp
else
a2 = a2 "DISP("disp")"
if disp = 'NEW' & nn \== '' then
a2 = a2 dsnCreateAtts( , nn, 1)
if retRc <> '' | nn = '' then
return adrCsm('allocate' al a2 rest, retRc)
do retry=0 by 1
alRc = adrCsm('allocate' al a2 rest, '*')
if alRc = 0 then
return 0
if retry > 0 | nn = '' | wordPos(disp, 'OLD SHR') < 1 then
return err('cmsAlloc rc' alRc 'for' al rest)
say 'csmAlloc rc' alRc 'for' al a2 rest '...trying to create'
nn = al 'disp(cat)' dsnCreateAtts(dsn, nn, 1)
call adrCsm 'allocate' nn
call adrTso 'free dd('dd')'
end
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
/*--- 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
/*--- 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
/* 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 ''
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.adrTsoAl.1 = ''
m.adrTsoAl.2 = ''
m.adrTsoAl.3 = ''
call outtrap m.adrTsoAl.
res = dsnAlloc(spec, pDi, pDD, '*')
call outtrap off
if \ datatype(res, 'n') then
return res
msg = m.adrTsoAl.1'\n'm.adrTsoAl.2'\n'm.adrTsoAl.3
if rt > timeOut & timeOut \== '' then
return err('timeout allocating' spec time() '\n'msg)
if pos('DATA SET IS ALLOCATED TO ANOTHER', msg) < 1 then
return err('allocating' spec'\n'msg)
say time() 'sleep and retry alloc' spec
call sleep 1, 0
end
endProcedure dsnAllocWait
/*--- alloc a dsn or a dd
spec '-'<ddName>
datasetName? disposition? '.'? attributes? (':' newAtts)?
disp default disposition
dd default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc -----*/
dsnAlloc: procedure expose m.
parse upper arg spec, pDi, pDD, retRc
parse value dsnSpec(spec) with na dd di rest
if na = '-' then
m.dsnAlloc.dsn = ''
else
m.dsnAlloc.dsn = na
if dd == '-' & pDD \== '' then
dd = pDD
if dd == '-' then
dd = 'DD*'
dd = tsoDD(dd, 'a')
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 pos('/', na) > 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 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
c = 'alloc dd('dd')' disp
if na \== '-' then
c = c "DSN('"na"')"
else if disp = 'NEW' and nn \== '' then
c = c dsnCreateAtts(,nn)
call outtrap m.adrTsoAl.
alRc = adrTso(c rest, '*')
call outtrap off
if alRc = 0 then
return 0
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& sysDsn("'"m.dsnAlloc.dsn"'") == 'DATASET NOT FOUND' then do
say 'tsoAlloc creating' c rest ':'nn
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na dd disp rest, retRc)
end
say 'rc='alRc 'for' c rest
call saySt adrTsoal
if retRc = '*' | wordPos(alRc, retRc) > 0 then
return alRc
call err 'tsoAlloc rc' alRc 'for' c rest
endProcedure tsoAlloc
tsoAtts: procedure expose m.
parse arg dsn
rc = listDsi("'"dsn"' SMSINFO")
if rc = 0 then
mv = ''
else if rc = 4 & sysReason = 19 then do
mv = '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
al = 'CAT'
al = ''
if right(sysDsSms, 7) == 'LIBRARY' ,
| abbrev(sysDsSms, 'PDS') then
al = al 'DSNTYPE(LIBRARY)'
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
return al "DSORG("sysDSorg") MGMTCLAS("sysMgmtClass")",
"DATACLAS("sysDataClass")" ,
"RECFM("translate('1 2 3', ' 'sysREcFM, ' 123')")",
"LRECL("SYSLRECL")",
"SPACE("sysPrimary"," sysSeconds")" sysUnits mv
/* "blksize("sysBLkSIZE")" removed 3.4.13: let sms do the magic */
endProcedure tsoAtts
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, forCsm
forCsm = forCsm == 1
aU = ' 'translate(atts)
res = ''
if dsn \== '' then
res = "dataset('"dsnSetMbr(dsn)"')"
if abbrev(atts, '~') then
return res tsoAtts(substr(atts, 2))
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
recfm='f b'
end
else do
if rl = '' then
rl = 32756
recfm = substr(a1, 2, 1) 'b'
end
res = res "recfm("space(recfm, 1-forCsm)") lrecl("rl")"
end
if pos('(', dsn) > 0 & pos(' DSNTYPE(', aU) < 1 ,
& pos(' DSORG(', aU) < 1 then
res = res 'dsntype(library) dsorg(po)'
if pos(' MGMTCLAS(', aU) < 1 then
res = res 'mgmtclas(COM#A091)'
if pos(' SPACE(', aU) < 1 then
res = res 'space(100, 500) cyl' || copies('inder', forCsm)
return res atts
endProcedure dsnCreateAtts
/*--- check if a dataset is archive ------------------------------------
returns 'ok' if dataset on disk
'not' if dataset is not catalogued
'arc' if dataset archived
listDsi errorMsg otherwise ------------------*/
dsnArc: procedure expose m.
parse upper arg dsn
lc = listDsi("'"strip(dsn)"' noRecall")
if lc = 0 then
return 'ok'
else if lc=4 & sysReason = 19 then /* multiple volumes */
return 'ok'
else if lc=16 & sysReason = 5 then
return 'notCat'
else if lc=16 & sysReason = 9 then
return 'arc'
else
return 'listDsi cc='lc', sysReason='sysReason ,
'm2='sysMsgLvl2', m1='sysMsgLvl1
endProcedure dsnArc
/*--- read the dataset specified in ggDsnSpec to stem ggSt -----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
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 ********************************************************/
}¢--- A540769.WK.REXX(SLEEP) cre=2009-07-22 mod=2009-09-03-10.16.11 A540769 ----
/* copy sleep begin ***************************************************/
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
/* copy sleep end *****************************************************/
}¢--- A540769.WK.REXX(SLEEPLO) cre=2013-01-21 mod=2013-01-21-07.56.21 A540769 ---
do i=1 to 100
call sleep 20
end
exit
/* copy sleep begin ***************************************************/
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
/* copy sleep end *****************************************************/
}¢--- A540769.WK.REXX(SMF) cre=2014-10-10 mod=2014-10-10-15.28.23 A540769 ------
o.1 = date('s') time() sysVar(sysNode) mvsvar('symdef', 'jobname') ,
'test1 .........?'
call dsnAlloc 'dd(O1) mod dsn.ablf.logDeImp ::f'
call writeDD o1, o., 1
call tsoClose o1
call tsoFree o1
exit
44608 14 1 2 3 4 5 6 7 8 9 0 1 2 3 4
1 14 1E0200210D240114283FE2F2F1C2
t d S 2 1 B D O F 1
2 2916 5E6500200BAB0114283FE2F2F1C2C4D6C6F100010000000000000A4C011C0
004C0006000100000054000000040000073C002C0004000007EC00400004000008EC0058
400010004000001B800010020C3C8E2D2C1F0F0F0C4C2D6C640404040D5E940404040404
40404040404040E8D5E9D7C1D9D4404040404040404040404018D1C5911CF26FFA000000
00000000000CDE19BBC47CAAD7400000000000B895E0000000000000000000001496B62D
S21B DOF1
call errReset 'hi'
call readDsn 'SMF.RZ2.P0.DB2.INTVL.S21B.D14283.T060100', i.
say i.0 length(i.1)
do j=1 to 20
say right(j, 3) right(length(i.j), 6) c2x(i.j)
end
exit
/* copy adrTso begin *************************************************/
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet ---*/
adrTso:
parse arg m.tso_stmt, ggRet
call outtrap m.tso_trap.
address tso m.tso_stmt
m.tso_rc = rc
call outtrap off
if m.tso_rc == 0 then
return 0
m.tso_trap = ''
do ggXx=1 to min(7, m.tso_trap.0)
m.tso_trap = m.tso_trap'\n'strip(m.tso_trap.ggXx)
end
if m.tso_trap.0 > 7 then do
if m.tso_trap.0 > 14 then
m.tso_trap = m.tso_trap'\n............'
do ggXx=max(8, m.tso_trap.0-6) to m.tso_trap.0
m.tso_trap = m.tso_trap'\n'strip(m.tso_trap.ggXx)
end
end
if ggRet <> '*' & wordPos(m.tso_rc, ggRet) <= 0 then
call err 'adrTso rc=' m.tso_rc 'stmt='m.tso_stmt m.tso_trap
return m.tso_rc
endSubroutine 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 dd '(open)')
return /* end tsoOpen */
/*--- close dd -----------------------------------------------------*/
tsoClose: procedure expose m.
parse upper arg dd
return adrTso('execio 0 diskR' 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' | w == 'CAT' then
di = di 'CAT'
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 = ''
res = dsnAlloc(spec, pDi, pDD, '*')
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_dsn.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, noErr
if symbol('m.tso_ddAll') \== 'VAR' then do
call errIni
m.tso_ddAll = ''
end
if f == '-' then do
ax = wordPos(dd, m.tso_ddAll)
if ax > 0 then
m.tso_ddAll = delWord(m.tso_ddAll, ax, 1)
else if noErr \== 1 then
call err 'tsoDD dd' dd 'not used' m.tso_ddAll
end
else if f <> 'A' then
call err 'tsoDD bad fun' f
else do
if right(dd, 1) = '*' then do
d0 = left(dd, length(dd)-1) || m.err.screen
dd = d0
do dx=1 while wordPos(dd, m.tso_ddAll) > 0
dd = d0 || dx
end
end
else if pos('?', dd) > 0 then
dd = repAll(dd, '?', m.err.screen)
if wordPos(dd, m.tso_ddAll) < 1 then
m.tso_ddAll = strip(m.tso_ddAll dd)
m.tso_dsn.dd = ''
m.tso_dsOrg.dd = ''
end
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_dsn.dd = ''
else if na \== 'INTRDR' then do
c = c "DSN('"na"')"
m.tso_dsn.dd = na
end
else do
c = c "sysout(*) writer(intRdr)"
m.tso_dsn.dd = '*intRdr'
end
if wordPos(disp, 'NEW MOD') > 0 & nn \== '' then
c = c dsnCreateAtts(,nn)
if adrTso(c rest, '*') = 0 then
return 0
if pos('IKJ56246I', m.tso_trap) > 0 then
if pos('TED, FILE IN USE', m.tso_trap) > 0 then do
/* IKJ56246I DATA SET A540769.WK.REXX NOT ALLOCATED, FILE IN USE */
say 'tsoAlloc dd' dd 'already in use:' substr(m.tso_trap, 3)
say '.... trying to free'
call tsoFree dd, 1
say '.... retrying to allocate' c rest
if adrTso(c rest, '*') = 0 then
return 0
end
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& pos('IKJ56228I', m.tso_trap) > 0 ,
& pos(' NOT IN CATALOG ', m.tso_trap) > 0 then do
/* IKJ56228I DATA SET A540769.XY.REXX NOT IN CATALOG OR CATAL*/
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
if pos('*', retRc) < 1 & wordPos(m.tso_rc, retRc) < 1 then
call err 'tsoAlloc rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
call sayNl 'tsoAlloc rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
return m.tso_rc
endProcedure tsoAlloc
dsnExists: procedure expose m.
parse upper arg aDsn
parse value csmSysDsn(aDsn) with sys '/' dsn
dsn = dsnSetMbr(dsn)
if sys == '*' then
return sysDsn("'"dsn"'") == 'OK'
lc = adrCsm('dslist system('sys') dsnMask('dsn') short', 4)
if stemsize = 0 | stemSize = 1 then
return stemSize
call err 'csmExists stemSize='stemsize 'for dsn='dsn n
endProcedure dsnExists
dsnLikeAtts: procedure expose m.
parse upper arg dsn, isFile
if isFile then do
ddDsn = m.tso_dsn.dsn
if lastPos('/', m.tso_dsn.dsn, 4) < 1 then
return tsoLikeAtts(dsn, 1)
dsn = m.tso_dsn.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, tryClose
do dx=1 to words(ddList)
dd = word(ddList, dx)
if adrTso('free dd('dd')', '*') <> 0 then do
if pos('IKJ56861I', m.tso_trap) > 0 & tryClose == 1 then
if pos('NOT FREED, DATA SET IS OPEN', m.tso_trap),
> 0 then do
/* IKJ56861I FILE A1 NOT FREED, DATA SET IS OPEN */
say 'dataset open:' substr(m.tso_trap, 3)
say '.... trying to close'
if adrTso('execio 0 diskR' dd '(finis)', '*') = 0 then
call adrTso 'free dd('dd')', '*'
end
if m.tso_rc \== 0 then
call sayNl 'rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
end
call tsoDD dd, '-', 1
end
return
endProcedure tsoFree
dsnCreateAtts: procedure expose m.
parse arg dsn, atts
res = ''
if dsn \== '' & \ abbrev(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
hasMbr = pos('(', dsn) > 0
if hasMbr & \ hasOrg then
atts = atts 'dsorg(po) dsntype(library)'
if hasOrg | hasMbr then do
ww = DSORG DSNTYPE
do wx=1 to words(ww)
do forever
cx = pos(' 'word(ww, wx)'(', ' 'translate(res))
if cx == 0 then
leave
cy = pos(')', res, cx)
res = delstr(res, cx, cy+1-cx)
end
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
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 do
address tso 'profile MsgId' /* brauchen wir in tsoAlloc| */
if sysVar('sysISPF') = 'ACTIVE' then do
m.err.ispf = 1
address ispExec 'vget zScreen shared'
m.err.screen = zScreen
end
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 stackHistory
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
x = show + stackHistory + by + bad + arithmetic + conversion
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_ddAll') == 'VAR' then
call tsoFree m.tso_ddAll, 1
return
endProcedure errCleanup
/*--- say an errorMessage msg with pref and linesplits --------------*/
errSay: procedure expose m.
parse arg msg
return sayNl(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 res
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
outNL: procedure expose m.
parse arg msg
bx = 1
do lx=1 to 20
ex = pos('\n', msg, bx)
if ex < bx then
leave
call out substr(msg, bx, ex-bx)
bx = ex+2
end
call out substr(msg, bx)
return
endProcedure outNL
/*--- say (part of) the lines of a stem ----------------------------*/
sayNl: procedure expose m.
parse arg msg
bx = 1
do lx=1 to 20
ex = pos('\n', msg, bx)
if ex < bx then
leave
say strip(substr(msg, bx, ex-bx), 't')
bx = ex+2
end
say strip(substr(msg, bx), 't')
return 0
endProcedure sayNl
/*--- 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 *****************************************************/
}¢--- A540769.WK.REXX(SMSREST) cre=2011-03-01 mod=2011-03-01-16.15.25 A540769 ---
$<.fileList('A540769.WK', 'r')
$<.fileList('A540769.TMP', 'r')
$<.fileList('DBAF.DA540769.APER09.P*23.D110222.**')
$<.fileList('DBAF.DA540769.APER09.P*12.**')
$<.fileList('DBAF.DA540769.APER09.P*.D110222.**')
$@for d $@¢
say 'recalling' $d
$**call adrTso hrecall "'"$d"'"
$!
$#out 20110301 16:06:28
}¢--- A540769.WK.REXX(SORT) cre=2016-07-11 mod=2016-07-11-11.46.31 A540769 -----
/* copy sort begin ***************************************************/
sortComparator: procedure expose m.
parse arg cmp, le, ri
if cmp == '' then
cmp = '<<='
if length(cmp) < 6 then
m.sort_comparator = 'cmp =' le cmp ri
else if pos(';', cmp) < 1 then
m.sort_comparator = "aLe =" le"; aRi =" ri"; cmp =" cmp
else
m.sort_comparator = "aLe =" le "; aRi =" ri";" cmp
return
endProcedure sort
sortWords: procedure expose m.
parse arg wrds, cmp
if words(wrds) <= 1 then
return strip(wrds)
m.sort_ii.0 = words(wrds)
do sx=1 to m.sort_ii.0
m.sort_ii.sx = word(wrds, sx)
end
call sort sort_ii, sort_oo, cmp
r = m.sort_oo.1
do sx=2 to m.sort_oo.0
r = r m.sort_oo.sx
end
return r
endProcedure sortWords
sortWordsQ: procedure expose m.
parse arg wrds, cmp
call sortComparator cmp, 'word(le, lx)', 'word(ri, rx)'
return strip(sortWord1(wrds))
endProcedure sortWordsQ
sortWord1: procedure expose m.
parse arg wrds
if words(wrds) <= 1 then
return wrds
h = words(wrds) % 2
le = sortWord1(subWord(wrds, 1, h))
ri = sortWord1(subWord(wrds, h+1))
lx = 1
rx = 1
res = ''
do forever
interpret m.sort_comparator
if cmp then do
res = res word(le, lx)
if lx >= words(le) then
return res subword(ri, rx)
lx = lx + 1
end
else do
res = res word(ri, rx)
if rx >= words(ri) then
return res subword(le, lx)
rx = rx + 1
end
end
endProcedure sortWord1
sort: procedure expose m.
parse arg i, o, cmp
call sortComparator cmp, 'm.l.l0', 'm.r.r0'
call sort1 i, 1, m.i.0, o, 1, sort_work, 1
m.o.0 = m.i.0
return
endProcedure sort
sort1: procedure expose m.
parse arg i, i0, le, o, o0, w, w0
if le <= 3 then do
if le = 3 then do
call sortMerge i, i0, i0+1, i, i0+1, i0+2, w, w0
call sortMerge i, i0+2, i0+3, w, w0, w0+2, o, o0
end
else if le = 2 then
call sortMerge i, i0, i0+1, i, i0+1, i0+2, o, o0
else if le = 1 then
m.o.o0 = m.i.i0
return
end
h = (le + 1) % 2
call sort1 i, i0, h, o, o0+le-h, w, w0
call sort1 i, i0+h, le-h, w, w0, o, o0
call sortMerge o, o0+le-h, o0+le, w, w0, w0+le-h, o, o0
return
endProcedure sort1
sortMerge: procedure expose m.
parse arg l, l0, le, r, r0, re, o, o0
do while l0 < le & r0 < re
interpret m.sort_comparator
if cmp then do
m.o.o0 = m.l.l0
l0 = l0 + 1
end
else do
m.o.o0 = m.r.r0
r0 = r0 + 1
end
o0 = o0 + 1
end
do while l0 < le
m.o.o0 = m.l.l0
l0 = l0 + 1
o0 = o0 + 1
end
do while r0 < re
m.o.o0 = m.r.r0
r0 = r0 + 1
o0 = o0 + 1
end
return
endProcedure sortMerge
/* copy sort end ***************************************************/
}¢--- A540769.WK.REXX(SPUFCOMP) cre=2013-01-07 mod=2013-01-14-10.42.41 A540769 ---
m.lib = 'A540769.TMP.TEXV'
call spufComp 'prbg#x2m', 'pdbg#x2n', 'pout#x2n', 13
exit
spufComp: procedure expose m.
parse arg mNeu, mAlt, mOut, cWW
call outDst '0'
m.sep = '---------+---------+---------+'
ab = rBegin(a, m.Lib'('mAlt')')
do cAlt=0 while rNext(a)
ax = m.a.xx
pl = word(m.a.ax, 1)
m.alt.pl = m.a.ax
end
nb = rBegin(n, m.Lib'('mNeu')')
if m.a.tit <> m.n.tit then
call err 'tit <> \nalt='m.a.tit'\nneu='m.n.tit
call out 'tit ' m.a.tit
equals = ''
cDiff = 0
ox = 0
cMat = 0
cEq = 0
cSim= 0
do cNeu=0 while rNext(n)
nx = m.n.xx
nl = m.n.nx
pl = word(nl, 1)
m.neu.pl = 1
if symbol('m.alt.pl') == 'VAR' then do
al = m.alt.pl
cMat = cMat + 1
isEq = 1
isSim = 1
do wx = 2 to cWW
aw = word(al, wx)
nw = word(nl, wx)
if aw = nw then
iterate
isEq = 0
if datatype(aw, 'n') & datatype(nw, 'n') then do
rl = min(aw, nw) / max(aw, nw)
if rl <= 1 & rl >= 0.80 then
iterate
end
isSim = 0
leave
end
if isSim then do
equals = equals pl
end
else do
call out 'alt ' al
call out 'neu ' nl
cDiff = cDiff + 1
end
cEq = cEq + isEq
cSim = cSim + isSim
end
else do
ox = ox + 1
m.neuOnly.ox = right(cNeu, 3) nl
end
end
do px=1 to ox
call out 'neuO'm.neuOnly.px
end
m.a.xx = ab
cAltOnly = 0
do cAlt=0 while rNext(a)
ax = m.a.xx
pl = word(m.a.ax, 1)
if m.neu.pl \== 1 then do
cAltOnly = cAltOnly + 1
call out 'altO'right(cAlt, 3) m.a.ax
end
end
call out 'equal ' equals
call outDst 'so'
call out 'match='cMat 'neu='ox 'alt='cAltOnly
call out 'match='cMat 'eq='cEq 'simOnly=' || (cSim-cEq) ,
'diff=' || cDiff
call writeDsn m.Lib'('mOut')', 'M.OUT.', , 1
exit
rBegin: procedure expose m.
parse arg m, dsn
call readDsn dsn, 'M.'m'.'
do lx=1 to m.m.0 until abbrev(word(m.m.lx, 1), ';')
end
lx = lx+1
if \ abbrev(m.m.lx, m.sep) then
call err 'bad start1 in' dsn':'lx left(m.m.lx, 60)
lx = lx+1
m.m.tit = m.m.lx
lx = lx+1
if \ abbrev(m.m.lx, m.sep) then
call err 'bad start2 in' dsn':'lx left(m.m.lx, 60)
m.m.xx = lx
return m.m.xx
endProcedure rBegin
rNext: procedure expose m.
parse arg m
do lx = m.m.xx+1 to m.m.0
if abbrev(m.m.lx, m.sep) | m.m.lx = m.m.tit then
iterate
if abbrev(m.m.lx, 'DSNE610I NUMBER OF') then
return 0
m.m.xx = lx
m.m.lx = translate(m.m.lx, ' ', '00'x)
return 1
end
return 0
endProcedure rNext
/* copy adrTso begin *************************************************/
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet ---*/
adrTso:
parse arg ggTsoCmd, ggRet
address tso ggTsoCmd
if rc == 0 then return 0
else if ggRet == '*' then return rc
else if wordPos(rc, ggRet) > 0 then return rc
else
call err 'adrTso rc' rc 'for' ggTsoCmd
return /* end adrTso */
/*--- format dsn from tso format to jcl format -----------------------*/
dsn2jcl: procedure expose m.
parse upper arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
cx = pos('~', dsn)
if cx < 1 & addPrefix == 1 then
return sp'.'dsn
do while cx \== 0
le = left(dsn, cx-1)
ri = substr(dsn, cx+1)
if right(le, 1) == '.' | left(ri, 1) == '.' then
dsn = le || sp || ri
else
dsn = le || left('.', le \== '') || sp ,
|| left('.', ri \== '') || ri
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
parse arg dsn, mbr
bx = pos('(', dsn)
if bx > 0 then
dsn = strip(left(dsn, bx-1))
if mbr <> '' then
dsn = dsn'('strip(mbr)')'
return dsn
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn
lx = pos('(', dsn)
rx = pos(')', dsn, lx+1)
if lx < 1 then
return ''
else if lx < rx then
return substr(dsn, lx+1, rx-lx-1)
else
return strip(substr(dsn,lx+1))
endProcedure dsnGetMbr
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: readDDBegin, readDD*, readDDEnd
write: writeBegin, writeDD*, writeEnd
readDD returns true if data read, false at eof
***********************************************************************/
/*--- prepare reading from a DD --------------------------------------*/
readDDBegin: procedure expose m.
parse upper arg ggDD
call errAddCleanup 'call readDDEnd' ggDD', "*"'
return /* end readDDBegin */
/*--- read from DD ggDD into ggSt, return false at eof ---------------*/
readDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskr' ggDD '(stem' ggSt')', 2
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- finish reading DD ggDD ----------------------------------------*/
readDDEnd: procedure expose m.
parse upper arg ggDD, ggRet
call errRmCleanup 'call readDDEnd' ggDD', "*"'
return adrTso('execio 0 diskr' ggDD '(finis)', ggRet)
endProcedure readDDEnd
/*--- prepare writing to DD ggDD -------------------------------------*/
writeDDBegin: procedure expose m.
parse upper arg ggDD
/* ensure file is erased, if no records are written */
call adrTso 'execio' 0 'diskw' ggDD '(open)'
call errAddCleanup 'call writeDDEnd' ggDD', "*"'
return /* end writeDDBegin */
/*--- write to gg ggDD from stem ggSt, ggCnt records -----------------*/
writeDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt == '' then
ggCnt = value(ggst'0')
call adrTso 'execio' ggCnt 'diskw' ggDD '(stem' ggSt')'
return
endSubroutine writeDD
/*--- end writing to dd ggDD (close) --------------------------------*/
writeDDEnd: procedure expose m.
parse upper arg ggDD, ggRet
call errRmCleanup 'call writeDDEnd' ggDD', "*"'
return adrTso('execio 0 diskw' ggDD '(finis)', ggRet)
endProcedure writeDDEnd
/*--- readNx: read next line, using buffer ---------------------------*/
/*--- begin: allocate dsnSpec and ini ------------------------ -------*/
readNxBegin: procedure expose m.
parse arg m, m.m.dsn, m.m.dd, m.m.Cnt
if m.m.dd = '' then
m.m.dd = 'DDNX'
if m.m.cnt = '' then
m.m.cnt = 1000
m.m.cx = m.m.cnt + 999
m.m.buf0x = 0
m.m.0 = 0
m.m.free = subword(dsnAlloc('dd('m.m.dd')' m.m.dsn), 2)
call readDDBegin m.m.dd
return m
endProcedure readDDNxBegin
/*--- return the stem of the next line, or '' at end -----------------*/
readNx: procedure expose m.
parse arg m
m.m.cx = m.m.cx + 1
if m.m.cx <= m.m.0 then
return m'.'m.m.cx
m.m.buf0x = m.m.buf0x + m.m.0
if \ readDD(m.m.dd, 'M.'m'.', m.m.cnt)then
return ''
m.m.cx = 1
return m'.1'
endProcedure readDDNx
/*--- return the stem of the curr line, '' at end --------------------*/
readNxCur: procedure expose m.
parse arg m
if m.m.cx <= m.m.0 then
return m'.'m.m.cx
else
return ''
endProcedure readNxCur
/*--- return the position (line number) of reader
plus le characters of the current line (default 50) ------*/
readnxPos: procedure expose m.
parse arg m, le
li = m'.'m.m.cx
li = strip(m.li, 't')
if arg() < 2 then
le = 50
if le < 1 then
li = ''
else if length(li) <= le then
li = ':' li
else
li = ':' left(li, le-3)'...'
return 'line' (m.m.buf0x + m.m.cx)li
endProcedure readnxPos
/*--- close and deallocate ------------------------------------------*/
readNxEnd: procedure expose m.
parse arg m
call readDDEnd m.m.dd
interpret m.m.free
return
endProcedure readDDNxEnd
/*--- standardise a dsn spec
word1 dsName or -
word2 dd or -
word3 disp or -
word4 to first : attributes in tso format
after first : attributes for new allocation
----------------------------------------------------------------------*/
dsnSpec: procedure expose m.
parse upper arg spec
rr = '' /* put leading - in separate words */
do sx=1 while words(rr) < 3 & wx \= ''
wx = word(spec, sx)
do while abbrev(wx, '-') & words(rr) < 3
wx = substr(wx, 2)
rr = rr '-'
end
rr = rr wx
end
spec = rr subWord(spec, sx)
na = ''
dd = ''
di = ''
if left(spec, 1) = '&' then /* external spec is handled ok */
spec = strip(substr(spec, 2))
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, '.') | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
di = w
else if w = 'CATALOG' then
di = di w
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
na = strip(substr(w, 5, length(w)-5))
else if na == '' then
na = dsn2jcl(w)
else if dd == '' then
dd = w
else if di == '' then
di = w
else
leave
end
if na == '' then
na = '-'
else if abbrev(na, "'") then
na = substr(na, 2, length(na)-2)
if dd == '' then dd = '-'
if di == '' then di = '-'
re = subword(spec, wx)
if abbrev(re, '.') then
re = substr(re, 2)
return na dd di re
endProcedure dsnSpec
/*--- alloc a dsn with dsnAlloc
if the dsn is inuse wait and retry
until either the allocation is successfull
or the timeout occurs --------------------------------------*/
dsnAllocWait: procedure expose m.
parse upper arg spec, pDi, pDD, timeOut
x = max(1, arg() - 1)
do rt=0
m.adrTsoAl.1 = ''
m.adrTsoAl.2 = ''
m.adrTsoAl.3 = ''
call outtrap m.adrTsoAl.
res = dsnAlloc(spec, pDi, pDD, '*')
call outtrap off
if \ abbrev(res, ' ') then
return res
msg = m.adrTsoAl.1'\n'm.adrTsoAl.2'\n'm.adrTsoAl.3
if rt > timeOut & timeOut \== '' then
return err('timeout allocating' spec time() '\n'msg)
if pos('DATA SET IS ALLOCATED TO ANOTHER', msg) < 1 then
return err('allocating' spec'\n'msg)
say time() 'sleep and retry alloc' spec
call sleep 1, 0
end
endProcedure dsnAllocWait
/*--- alloc a dsn or a dd
spec '-'<ddName>
datasetName? disposition? '.'? attributes? (':' newAtts)?
disp default disposition
dd default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc -----*/
dsnAlloc: procedure expose m.
parse upper arg spec, pDi, pDD, retRc
parse value dsnSpec(spec) with na dd di rest
if na = '-' then
m.dsnAlloc.dsn = ''
else
m.dsnAlloc.dsn = na
if na == '-' & dd \== '-' & di == '-' & rest = '' then
return dd
if dd == '-' & pDD \== '' then
dd = pDD
if dd == '-' then do
if symbol('m.adrTso.ddNum') = 'VAR' then
dd = m.adrTso.ddNum + 1
else
dd = 1
m.adrTso.ddNum = dd
dd = 'DD' || dd
end
if di = '-' & pDi \== '' then
di = pDi
if di = '-' then
di = 'SHR'
else if pos('(', na) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if pos('/', na) > 0 then
return csmAlloc(na dd di rest, retRc)
else
return tsoAlloc(na dd di rest, retRc)
endProcedure dsnAlloc
tsoAlloc: procedure expose m.
parse arg na dd disp rest ':' nn, retRc
c = 'alloc dd('dd')' disp
if na \== '-' then
c = c "DSN('"na"')"
else if disp = 'NEW' and nn \== '' then
c = c dsnCreateAtts(,nn)
call outtrap m.adrTsoAl.
alRc = adrTso(c rest, '*')
call outtrap off
if alRc = 0 then do
call errAddCleanup 'call tsoFree' dd', "*"'
return dd 'call tsoFree' dd';'
end
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& sysDsn("'"m.dsnAlloc.dsn"'") == 'DATASET NOT FOUND' then do
say 'tsoAlloc creating' c rest ':'nn
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na dd disp rest, retRc)
end
do ax=1 to m.adrTsoAl.0
say m.adrTsoal.ax
end
if retRc = '*' | wordPos(alRc, retRc) > 0 then
return ' ' alRc
call err 'tsoAlloc rc' alRc 'for' c rest
endProcedure tsoAlloc
tsoAtts: procedure expose m.
parse arg dsn
rc = listDsi("'"dsn"' SMSINFO")
if rc = 0 then
mv = ''
else if rc = 4 & sysReason = 19 then do
mv = 'UNITCNT(30)'
say 'multi volume' mv
end
else if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
al = 'CAT'
al = ''
if right(sysDsSms, 7) == 'LIBRARY' ,
| abbrev(sysDsSms, 'PDS') then
al = al 'DSNTYPE(LIBRARY)'
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
al = al "DSORG("sysDSorg") MGMTCLAS("sysMgmtClass")",
"DATACLAS("sysDataClass")" ,
"RECFM("translate('1 2 3', ' 'sysREcFM, ' 123')")",
"LRECL("SYSLRECL")",
"blksize("sysBLkSIZE")",
"SPACE("sysPrimary"," sysSeconds")" sysUnits mv
return al
endProcedure tsoAtts
tsoFree: procedure expose m.
parse arg dd, ggRet
call adrTso 'free dd('dd')', ggRet
call errRmCleanup 'call tsoFree' dd', "*"'
return
endProcedure tsoFree
dsnCreateAtts: procedure expose m.
parse arg dsn, atts, forCsm
forCsm = forCsm == 1
aU = ' 'translate(atts)
if abbrev(atts, ':') then do
parse var atts a1 atts
bl = 32760
rl = substr(a1, 3)
if abbrev(a1, ':F') then do
if rl = '' then
rl = 80
recfm='f b'
bl = bl - (bl // rl)
end
else do
if rl = '' then
rl = bl-4
recfm = substr(a1, 2, 1) 'b'
end
if forCsm then
atts = atts "recfm("space(recfm, 0)") lrecl("rl")",
"blkSize("bl")"
else
atts = atts "recfm("recfm") lrecl("rl") block("bl")"
end
if pos('(', dsn) > 0 & pos(' DSNTYPE(', aU) < 1 ,
& pos(' DSORG(', aU) < 1 then
atts = atts 'dsntype(library) dsorg(po)'
if pos(' MGMTCLAS(', aU) < 1 then
atts = atts 'mgmtclas(COM#A091)'
if pos(' SPACE(', aU) < 1 then
if forCsm then
atts = atts 'space(10, 1000) cylinder'
else
atts = atts 'space(10, 1000) cyl'
if dsn == '' then
return atts
return "dataset('"dsnSetMbr(dsn)"')" atts
endProcedure dsnCreateAtts
/*--- read the dataset specified in ggDsnSpec to stem ggSt -----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
interpret subword(ggAlloc, 2)
return
endSubroutine readDsn
/*--- write the dataset specified in ggDsnSpec from stem ggSt
write ggCnt records if not empty otherwise ggst0
if ggSay 1 then say ... records written to ... -------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'open finis)'
interpret subword(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
copyDSN: procedure expose m.
parse arg frSpec, toSpec, ggSay
frDD = dsnAlloc(frSpec, 'SHR', 'FRDD')
toDD = dsnAlloc(toSpec, 'OLD', 'TODD')
call readDDBegin word(frDD, 1)
call writeDDBegin word(toDD, 1)
cnt = 0
do while readDD(word(frDD, 1), r.)
call writeDD word(toDD, 1), r.
cnt = cnt + r.0
end
call readDDEnd word(frDD, 1)
call writeDDEnd word(toDD, 1)
interpret ';' subword(frDD, 2) '; ; ;' subword(toDD, 2)
if ggSay == 1 | m.debug == 1 then
say cnt 'records copied from' frSpec 'to' to toSpec
return
endSubroutine writeDsn
/* copy adrTso end ****************************************************/
/* copy err begin *** errorhandling, messages, help ****************/
errIni: procedure expose m.
if m.err.ini == 1 then
return
m.err.ini = 1
m.err.handler = ''
m.err.cleanup = ';'
m.err.opt = ''
return
endProcedure errIni
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err.opt, m.err.handler
if pos('I', translate(m.err.opt)) > 0 then
if errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
call adrIsp 'control errors return'
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
call errIni
drop err handler cleanup opt call return
if ggOpt == '' & m.err.handler \== '' then
interpret m.err.handler
call errSay ggTxt, 'e'
call errCleanup
if ggOpt == '' then
ggOpt = m.err.opt
ggOpt = translate(ggOpt)
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 then do
call errSay 'divide by zero to show stackHistory', 'e'
x = 1 / 0
end
call errSay 'exit(12)', 'e'
exit errSetRc(12)
endSubroutine err
/*--- return the Operating System we are running on: TSO or LINUX ---*/
errOS: procedure expose m.
parse source os .
return os
endProcedure errOS
/*--- set rc for ispf: -------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared variable zIspfRc
back as return code
----------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- error routine: user message cleanup exit -----------------------*/
errAddCleanup: procedure expose m.
parse arg code
call errIni
/* concatenate backwards, then it is executed also backwards */
m.err.cleanup = ';'code || m.err.cleanup
return
endProcedure errAddCleanup
errRmCleanup: procedure expose m.
parse arg code
call errIni
cx = pos(';'code';', m.err.cleanup)
if cx > 0 then
m.err.cleanup = left(m.err.cleanup, cx) ,
|| substr(m.err.cleanup, cx + length(code)+2)
return
endProcedure errRmCleanup
errCleanup: procedure expose m.
call errIni
errCleanup = m.err.cleanup
if errCleanup = ';' then
return
m.err.cleanup = ';'
say 'err cleanup begin' errCleanup
call errInterpret errCleanup
say 'err cleanup end' errCleanup
return
endProcedure errCleanup
/*--- say an errorMessage msg with pref and linesplits --------------*/
errSay: procedure expose m.
parse arg msg, pref
return saySt(errMsg(msg, pref))
/*--- prefix an errormessage with pref,
split it into lines at \n to stem m.err -------------------*/
errMsg: procedure expose m.
parse arg msg, pref
parse source . . ggS3 . /* current rexx */
if pref == 'e' then
msg = 'fatal error in' ggS3':' msg
else if pref == 'w' then
msg = 'warning in' ggS3':' msg
else if pref \== '' then
msg = pref':' msg
/* split lines at \n */
bx = 1
do lx=1 to 20
ex = pos('\n', msg, bx)
if ex < bx then
leave
m.err.lx = substr(msg, bx, ex-bx)
bx = ex+2
end
m.err.lx = substr(msg, bx)
m.err.0 = lx
return err
endProcedure errMsg
/*--- say (part of) the lines of a stem ----------------------------*/
saySt: procedure expose m.
parse arg st, fx, tx
do lx=word(fx 1, 1) to word(tx m.st.0, 1)
say m.st.lx
end
return st
endProcedure saySt
/*--- out (part of) the lines of a stem ----------------------------*/
outSt: procedure expose m.
parse arg st, fx, tx
do lx=word(fx 1, 1) to word(tx m.st.0, 1)
call out m.st.lx
end
return st
endProcedure outSt
/*--- say a trace message if m.trace is set --------------------------*/
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
say 'debug:' msg
return
endProcedure debug
/*--- output a trace if m.trace is set -------------------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
/*--- assert that the passed rexx expression evaluates to true -------*/
assert:
interpret 'assertRes =' arg(1)
if assertRes \==1 then
call err 'assert failed' arg(1) '==>' assertRes':' arg(2)
return
endProcedure assert
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg, op
call errSay msg, 'e'
call help
call err msg, op
endProcedure errHelp
/*--- display the first comment block of the source as help ----------*/
help: procedure expose m.
parse source . . s3 .
say right(' help for rexx' s3, 79, '*')
do ax=1 to arg()
say ' ' arg(ax)
end
do lx=1 by 1
if pos('/*', sourceLine(lx)) > 0 then
leave
else if lx > 10 then do
say 'initial commentblock not found for help'
return
end
end
do lx=lx+1 by 1
li = strip(sourceLine(lx), 't', ' ')
if pos('*/', li) > 0 then
leave
say li
end
say right(' end help for rexx' s3, 79, '*')
return 4
endProcedure help
/* copy err end *****************************************************/
/* copy out begin ******************************************************
out interface simple with say or stem m.out only
***********************************************************************/
outIni: procedure expose m.
return outDst()
/*--- output a message to the current destination -------------------*/
out: procedure expose m.
parse arg msg
if m.out.ini \== 1 then
call outDst
if m.out.say then
say msg
if m.out.out then do
ox = m.out.0 + 1
m.out.0 = ox
m.out.ox = msg
end
return 0
endProcedure out
/*--- set a new out destination and return old one ------------------*/
outDst: procedure expose m.
parse arg d
if m.out.ini == 1 then
old = '-' || left('s', m.out.say) || left('o', m.out.out)
else do
m.out.ini = 1
old = '-s'
end
m.out.say = d == '' | pos('s', d) > 0
m.out.out = verify(d, 'o0', 'm') > 0
if pos('0', d) > 0 | \ datatype(m.out.0, 'n') then
m.out.0 = 0
return old
endProcedure outDst
/* return the contents of a string or std input */
inp2str: procedure expose m.
parse arg rdr, opt
return rdr
endProcedure inp2str
/* copy out end *****************************************************/
}¢--- A540769.WK.REXX(SPUFELAR) cre=2013-01-11 mod=2013-01-11-15.45.56 A540769 ---
m.pds = 'A540769.TMP.TEXV'
if 0 then
call matrix elar, elarOut, woche, plan, c2cpu
if 1 then
call matrix elaPkg, elaPkgOu, woche, pkg, c7cpu
if 1 then
call matrix elaPkg, elaPkgEl, woche, pkg, c7ela
exit
matrix: procedure expose m.
parse arg mIn, mOut, xaN, yaN, vaN
m.sep = '---------+---------+---------+'
xaS = ''
yaS = ''
call outDst '0'
ib = rBegin(i, m.pds'('mIn')')
xaX = pos(xaN, m.i.tit)
yaX = pos(yaN, m.i.tit)
vaX = pos(vaN, m.i.tit)
do cAlt=0 while rNext(i)
ix = m.i.xx
li = m.i.ix
xaY = word(substr(li, xaX), 1)
if xaY == '11.01.2013' then
iterate
if wordPos(xaY, xaS) < 1 then
xaS = xaS xaY
yaY = word(substr(li, yaX), 1)
if wordPos(yaY, yaS) < 1 then
yaS = yaS yaY
vaY = word(substr(li, vaX), 1)
va.yaY.xaY = vaY
end
li = left('', 11)
do wx=1 to words(xaS)
xa = word(xaS, wx)
li = li left(xa, 11)
end
call out li
do px=1 to words(yaS)
ya = word(yaS, px)
li = left(ya, 11)
do wx=1 to words(xaS)
xa = word(xaS, wx)
if symbol('va.ya.xa') == 'VAR' then
li = li left(va.ya.xa, 11)
else
li = li left('' , 11)
end
call out li
end
call writeDsn m.pds'('mOut')', 'M.OUT.', , 1
return
endProcedure matrix
rBegin: procedure expose m.
parse arg m, dsn
call readDsn dsn, 'M.'m'.'
do lx=1 to m.m.0 until abbrev(m.m.lx, ';')
end
lx = lx+1
if \ abbrev(m.m.lx, m.sep) then
call err 'bad start1 in' dsn':'lx left(m.m.lx, 60)
lx = lx+1
m.m.tit = m.m.lx
lx = lx+1
if \ abbrev(m.m.lx, m.sep) then
call err 'bad start2 in' dsn':'lx left(m.m.lx, 60)
m.m.xx = lx
return m.m.xx
endProcedure rBegin
rNext: procedure expose m.
parse arg m
do lx = m.m.xx+1 to m.m.0
if abbrev(m.m.lx, m.sep) | m.m.lx = m.m.tit then
iterate
if abbrev(m.m.lx, 'DSNE610I NUMBER OF') then
return 0
m.m.xx = lx
m.m.lx = translate(m.m.lx, ' ', '00'x)
return 1
end
return 0
endProcedure rNext
/* copy adrTso begin *************************************************/
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet ---*/
adrTso:
parse arg ggTsoCmd, ggRet
address tso ggTsoCmd
if rc == 0 then return 0
else if ggRet == '*' then return rc
else if wordPos(rc, ggRet) > 0 then return rc
else
call err 'adrTso rc' rc 'for' ggTsoCmd
return /* end adrTso */
/*--- format dsn from tso format to jcl format -----------------------*/
dsn2jcl: procedure expose m.
parse upper arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
cx = pos('~', dsn)
if cx < 1 & addPrefix == 1 then
return sp'.'dsn
do while cx \== 0
le = left(dsn, cx-1)
ri = substr(dsn, cx+1)
if right(le, 1) == '.' | left(ri, 1) == '.' then
dsn = le || sp || ri
else
dsn = le || left('.', le \== '') || sp ,
|| left('.', ri \== '') || ri
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
parse arg dsn, mbr
bx = pos('(', dsn)
if bx > 0 then
dsn = strip(left(dsn, bx-1))
if mbr <> '' then
dsn = dsn'('strip(mbr)')'
return dsn
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn
lx = pos('(', dsn)
rx = pos(')', dsn, lx+1)
if lx < 1 then
return ''
else if lx < rx then
return substr(dsn, lx+1, rx-lx-1)
else
return strip(substr(dsn,lx+1))
endProcedure dsnGetMbr
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: readDDBegin, readDD*, readDDEnd
write: writeBegin, writeDD*, writeEnd
readDD returns true if data read, false at eof
***********************************************************************/
/*--- prepare reading from a DD --------------------------------------*/
readDDBegin: procedure expose m.
parse upper arg ggDD
call errAddCleanup 'call readDDEnd' ggDD', "*"'
return /* end readDDBegin */
/*--- read from DD ggDD into ggSt, return false at eof ---------------*/
readDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskr' ggDD '(stem' ggSt')', 2
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- finish reading DD ggDD ----------------------------------------*/
readDDEnd: procedure expose m.
parse upper arg ggDD, ggRet
call errRmCleanup 'call readDDEnd' ggDD', "*"'
return adrTso('execio 0 diskr' ggDD '(finis)', ggRet)
endProcedure readDDEnd
/*--- prepare writing to DD ggDD -------------------------------------*/
writeDDBegin: procedure expose m.
parse upper arg ggDD
/* ensure file is erased, if no records are written */
call adrTso 'execio' 0 'diskw' ggDD '(open)'
call errAddCleanup 'call writeDDEnd' ggDD', "*"'
return /* end writeDDBegin */
/*--- write to gg ggDD from stem ggSt, ggCnt records -----------------*/
writeDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt == '' then
ggCnt = value(ggst'0')
call adrTso 'execio' ggCnt 'diskw' ggDD '(stem' ggSt')'
return
endSubroutine writeDD
/*--- end writing to dd ggDD (close) --------------------------------*/
writeDDEnd: procedure expose m.
parse upper arg ggDD, ggRet
call errRmCleanup 'call writeDDEnd' ggDD', "*"'
return adrTso('execio 0 diskw' ggDD '(finis)', ggRet)
endProcedure writeDDEnd
/*--- readNx: read next line, using buffer ---------------------------*/
/*--- begin: allocate dsnSpec and ini ------------------------ -------*/
readNxBegin: procedure expose m.
parse arg m, m.m.dsn, m.m.dd, m.m.Cnt
if m.m.dd = '' then
m.m.dd = 'DDNX'
if m.m.cnt = '' then
m.m.cnt = 1000
m.m.cx = m.m.cnt + 999
m.m.buf0x = 0
m.m.0 = 0
m.m.free = subword(dsnAlloc('dd('m.m.dd')' m.m.dsn), 2)
call readDDBegin m.m.dd
return m
endProcedure readDDNxBegin
/*--- return the stem of the next line, or '' at end -----------------*/
readNx: procedure expose m.
parse arg m
m.m.cx = m.m.cx + 1
if m.m.cx <= m.m.0 then
return m'.'m.m.cx
m.m.buf0x = m.m.buf0x + m.m.0
if \ readDD(m.m.dd, 'M.'m'.', m.m.cnt)then
return ''
m.m.cx = 1
return m'.1'
endProcedure readDDNx
/*--- return the stem of the curr line, '' at end --------------------*/
readNxCur: procedure expose m.
parse arg m
if m.m.cx <= m.m.0 then
return m'.'m.m.cx
else
return ''
endProcedure readNxCur
/*--- return the position (line number) of reader
plus le characters of the current line (default 50) ------*/
readnxPos: procedure expose m.
parse arg m, le
li = m'.'m.m.cx
li = strip(m.li, 't')
if arg() < 2 then
le = 50
if le < 1 then
li = ''
else if length(li) <= le then
li = ':' li
else
li = ':' left(li, le-3)'...'
return 'line' (m.m.buf0x + m.m.cx)li
endProcedure readnxPos
/*--- close and deallocate ------------------------------------------*/
readNxEnd: procedure expose m.
parse arg m
call readDDEnd m.m.dd
interpret m.m.free
return
endProcedure readDDNxEnd
/*--- standardise a dsn spec
word1 dsName or -
word2 dd or -
word3 disp or -
word4 to first : attributes in tso format
after first : attributes for new allocation
----------------------------------------------------------------------*/
dsnSpec: procedure expose m.
parse upper arg spec
rr = '' /* put leading - in separate words */
do sx=1 while words(rr) < 3 & wx \= ''
wx = word(spec, sx)
do while abbrev(wx, '-') & words(rr) < 3
wx = substr(wx, 2)
rr = rr '-'
end
rr = rr wx
end
spec = rr subWord(spec, sx)
na = ''
dd = ''
di = ''
if left(spec, 1) = '&' then /* external spec is handled ok */
spec = strip(substr(spec, 2))
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, '.') | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
di = w
else if w = 'CATALOG' then
di = di w
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
na = strip(substr(w, 5, length(w)-5))
else if na == '' then
na = dsn2jcl(w)
else if dd == '' then
dd = w
else if di == '' then
di = w
else
leave
end
if na == '' then
na = '-'
else if abbrev(na, "'") then
na = substr(na, 2, length(na)-2)
if dd == '' then dd = '-'
if di == '' then di = '-'
re = subword(spec, wx)
if abbrev(re, '.') then
re = substr(re, 2)
return na dd di re
endProcedure dsnSpec
/*--- alloc a dsn with dsnAlloc
if the dsn is inuse wait and retry
until either the allocation is successfull
or the timeout occurs --------------------------------------*/
dsnAllocWait: procedure expose m.
parse upper arg spec, pDi, pDD, timeOut
x = max(1, arg() - 1)
do rt=0
m.adrTsoAl.1 = ''
m.adrTsoAl.2 = ''
m.adrTsoAl.3 = ''
call outtrap m.adrTsoAl.
res = dsnAlloc(spec, pDi, pDD, '*')
call outtrap off
if \ abbrev(res, ' ') then
return res
msg = m.adrTsoAl.1'\n'm.adrTsoAl.2'\n'm.adrTsoAl.3
if rt > timeOut & timeOut \== '' then
return err('timeout allocating' spec time() '\n'msg)
if pos('DATA SET IS ALLOCATED TO ANOTHER', msg) < 1 then
return err('allocating' spec'\n'msg)
say time() 'sleep and retry alloc' spec
call sleep 1, 0
end
endProcedure dsnAllocWait
/*--- alloc a dsn or a dd
spec '-'<ddName>
datasetName? disposition? '.'? attributes? (':' newAtts)?
disp default disposition
dd default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc -----*/
dsnAlloc: procedure expose m.
parse upper arg spec, pDi, pDD, retRc
parse value dsnSpec(spec) with na dd di rest
if na = '-' then
m.dsnAlloc.dsn = ''
else
m.dsnAlloc.dsn = na
if na == '-' & dd \== '-' & di == '-' & rest = '' then
return dd
if dd == '-' & pDD \== '' then
dd = pDD
if dd == '-' then do
if symbol('m.adrTso.ddNum') = 'VAR' then
dd = m.adrTso.ddNum + 1
else
dd = 1
m.adrTso.ddNum = dd
dd = 'DD' || dd
end
if di = '-' & pDi \== '' then
di = pDi
if di = '-' then
di = 'SHR'
else if pos('(', na) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if pos('/', na) > 0 then
return csmAlloc(na dd di rest, retRc)
else
return tsoAlloc(na dd di rest, retRc)
endProcedure dsnAlloc
tsoAlloc: procedure expose m.
parse arg na dd disp rest ':' nn, retRc
c = 'alloc dd('dd')' disp
if na \== '-' then
c = c "DSN('"na"')"
else if disp = 'NEW' and nn \== '' then
c = c dsnCreateAtts(,nn)
call outtrap m.adrTsoAl.
alRc = adrTso(c rest, '*')
call outtrap off
if alRc = 0 then do
call errAddCleanup 'call tsoFree' dd', "*"'
return dd 'call tsoFree' dd';'
end
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& sysDsn("'"m.dsnAlloc.dsn"'") == 'DATASET NOT FOUND' then do
say 'tsoAlloc creating' c rest ':'nn
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na dd disp rest, retRc)
end
do ax=1 to m.adrTsoAl.0
say m.adrTsoal.ax
end
if retRc = '*' | wordPos(alRc, retRc) > 0 then
return ' ' alRc
call err 'tsoAlloc rc' alRc 'for' c rest
endProcedure tsoAlloc
tsoAtts: procedure expose m.
parse arg dsn
rc = listDsi("'"dsn"' SMSINFO")
if rc = 0 then
mv = ''
else if rc = 4 & sysReason = 19 then do
mv = 'UNITCNT(30)'
say 'multi volume' mv
end
else if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
al = 'CAT'
al = ''
if right(sysDsSms, 7) == 'LIBRARY' ,
| abbrev(sysDsSms, 'PDS') then
al = al 'DSNTYPE(LIBRARY)'
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
al = al "DSORG("sysDSorg") MGMTCLAS("sysMgmtClass")",
"DATACLAS("sysDataClass")" ,
"RECFM("translate('1 2 3', ' 'sysREcFM, ' 123')")",
"LRECL("SYSLRECL")",
"blksize("sysBLkSIZE")",
"SPACE("sysPrimary"," sysSeconds")" sysUnits mv
return al
endProcedure tsoAtts
tsoFree: procedure expose m.
parse arg dd, ggRet
call adrTso 'free dd('dd')', ggRet
call errRmCleanup 'call tsoFree' dd', "*"'
return
endProcedure tsoFree
dsnCreateAtts: procedure expose m.
parse arg dsn, atts, forCsm
forCsm = forCsm == 1
aU = ' 'translate(atts)
if abbrev(atts, ':') then do
parse var atts a1 atts
bl = 32760
rl = substr(a1, 3)
if abbrev(a1, ':F') then do
if rl = '' then
rl = 80
recfm='f b'
bl = bl - (bl // rl)
end
else do
if rl = '' then
rl = bl-4
recfm = substr(a1, 2, 1) 'b'
end
if forCsm then
atts = atts "recfm("space(recfm, 0)") lrecl("rl")",
"blkSize("bl")"
else
atts = atts "recfm("recfm") lrecl("rl") block("bl")"
end
if pos('(', dsn) > 0 & pos(' DSNTYPE(', aU) < 1 ,
& pos(' DSORG(', aU) < 1 then
atts = atts 'dsntype(library) dsorg(po)'
if pos(' MGMTCLAS(', aU) < 1 then
atts = atts 'mgmtclas(COM#A091)'
if pos(' SPACE(', aU) < 1 then
if forCsm then
atts = atts 'space(10, 1000) cylinder'
else
atts = atts 'space(10, 1000) cyl'
if dsn == '' then
return atts
return "dataset('"dsnSetMbr(dsn)"')" atts
endProcedure dsnCreateAtts
/*--- read the dataset specified in ggDsnSpec to stem ggSt -----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
interpret subword(ggAlloc, 2)
return
endSubroutine readDsn
/*--- write the dataset specified in ggDsnSpec from stem ggSt
write ggCnt records if not empty otherwise ggst0
if ggSay 1 then say ... records written to ... -------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'open finis)'
interpret subword(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
copyDSN: procedure expose m.
parse arg frSpec, toSpec, ggSay
frDD = dsnAlloc(frSpec, 'SHR', 'FRDD')
toDD = dsnAlloc(toSpec, 'OLD', 'TODD')
call readDDBegin word(frDD, 1)
call writeDDBegin word(toDD, 1)
cnt = 0
do while readDD(word(frDD, 1), r.)
call writeDD word(toDD, 1), r.
cnt = cnt + r.0
end
call readDDEnd word(frDD, 1)
call writeDDEnd word(toDD, 1)
interpret ';' subword(frDD, 2) '; ; ;' subword(toDD, 2)
if ggSay == 1 | m.debug == 1 then
say cnt 'records copied from' frSpec 'to' to toSpec
return
endSubroutine writeDsn
/* copy adrTso end ****************************************************/
/* copy err begin *** errorhandling, messages, help ****************/
errIni: procedure expose m.
if m.err.ini == 1 then
return
m.err.ini = 1
m.err.handler = ''
m.err.cleanup = ';'
m.err.opt = ''
return
endProcedure errIni
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err.opt, m.err.handler
if pos('I', translate(m.err.opt)) > 0 then
if errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
call adrIsp 'control errors return'
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
call errIni
drop err handler cleanup opt call return
if ggOpt == '' & m.err.handler \== '' then
interpret m.err.handler
call errSay ggTxt, 'e'
call errCleanup
if ggOpt == '' then
ggOpt = m.err.opt
ggOpt = translate(ggOpt)
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 then do
call errSay 'divide by zero to show stackHistory', 'e'
x = 1 / 0
end
call errSay 'exit(12)', 'e'
exit errSetRc(12)
endSubroutine err
/*--- return the Operating System we are running on: TSO or LINUX ---*/
errOS: procedure expose m.
parse source os .
return os
endProcedure errOS
/*--- set rc for ispf: -------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared variable zIspfRc
back as return code
----------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- error routine: user message cleanup exit -----------------------*/
errAddCleanup: procedure expose m.
parse arg code
call errIni
/* concatenate backwards, then it is executed also backwards */
m.err.cleanup = ';'code || m.err.cleanup
return
endProcedure errAddCleanup
errRmCleanup: procedure expose m.
parse arg code
call errIni
cx = pos(';'code';', m.err.cleanup)
if cx > 0 then
m.err.cleanup = left(m.err.cleanup, cx) ,
|| substr(m.err.cleanup, cx + length(code)+2)
return
endProcedure errRmCleanup
errCleanup: procedure expose m.
call errIni
errCleanup = m.err.cleanup
if errCleanup = ';' then
return
m.err.cleanup = ';'
say 'err cleanup begin' errCleanup
call errInterpret errCleanup
say 'err cleanup end' errCleanup
return
endProcedure errCleanup
/*--- say an errorMessage msg with pref and linesplits --------------*/
errSay: procedure expose m.
parse arg msg, pref
return saySt(errMsg(msg, pref))
/*--- prefix an errormessage with pref,
split it into lines at \n to stem m.err -------------------*/
errMsg: procedure expose m.
parse arg msg, pref
parse source . . ggS3 . /* current rexx */
if pref == 'e' then
msg = 'fatal error in' ggS3':' msg
else if pref == 'w' then
msg = 'warning in' ggS3':' msg
else if pref \== '' then
msg = pref':' msg
/* split lines at \n */
bx = 1
do lx=1 to 20
ex = pos('\n', msg, bx)
if ex < bx then
leave
m.err.lx = substr(msg, bx, ex-bx)
bx = ex+2
end
m.err.lx = substr(msg, bx)
m.err.0 = lx
return err
endProcedure errMsg
/*--- say (part of) the lines of a stem ----------------------------*/
saySt: procedure expose m.
parse arg st, fx, tx
do lx=word(fx 1, 1) to word(tx m.st.0, 1)
say m.st.lx
end
return st
endProcedure saySt
/*--- out (part of) the lines of a stem ----------------------------*/
outSt: procedure expose m.
parse arg st, fx, tx
do lx=word(fx 1, 1) to word(tx m.st.0, 1)
call out m.st.lx
end
return st
endProcedure outSt
/*--- say a trace message if m.trace is set --------------------------*/
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
say 'debug:' msg
return
endProcedure debug
/*--- output a trace if m.trace is set -------------------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
/*--- assert that the passed rexx expression evaluates to true -------*/
assert:
interpret 'assertRes =' arg(1)
if assertRes \==1 then
call err 'assert failed' arg(1) '==>' assertRes':' arg(2)
return
endProcedure assert
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg, op
call errSay msg, 'e'
call help
call err msg, op
endProcedure errHelp
/*--- display the first comment block of the source as help ----------*/
help: procedure expose m.
parse source . . s3 .
say right(' help for rexx' s3, 79, '*')
do ax=1 to arg()
say ' ' arg(ax)
end
do lx=1 by 1
if pos('/*', sourceLine(lx)) > 0 then
leave
else if lx > 10 then do
say 'initial commentblock not found for help'
return
end
end
do lx=lx+1 by 1
li = strip(sourceLine(lx), 't', ' ')
if pos('*/', li) > 0 then
leave
say li
end
say right(' end help for rexx' s3, 79, '*')
return 4
endProcedure help
/* copy err end *****************************************************/
/* copy out begin ******************************************************
out interface simple with say or stem m.out only
***********************************************************************/
outIni: procedure expose m.
return outDst()
/*--- output a message to the current destination -------------------*/
out: procedure expose m.
parse arg msg
if m.out.ini \== 1 then
call outDst
if m.out.say then
say msg
if m.out.out then do
ox = m.out.0 + 1
m.out.0 = ox
m.out.ox = msg
end
return 0
endProcedure out
/*--- set a new out destination and return old one ------------------*/
outDst: procedure expose m.
parse arg d
if m.out.ini == 1 then
old = '-' || left('s', m.out.say) || left('o', m.out.out)
else do
m.out.ini = 1
old = '-s'
end
m.out.say = d == '' | pos('s', d) > 0
m.out.out = verify(d, 'o0', 'm') > 0
if pos('0', d) > 0 | \ datatype(m.out.0, 'n') then
m.out.0 = 0
return old
endProcedure outDst
/* return the contents of a string or std input */
inp2str: procedure expose m.
parse arg rdr, opt
return rdr
endProcedure inp2str
/* copy out end *****************************************************/
/* copy ut begin *****************************************************/
/*--- if function warning all3 arguments get evaluated|
e.g if(x=0, 'infinity', 1/0) will fail| -----------*/
if: procedure expose m.
parse arg co, ifTrue, ifFalse
if co then
return ifTrue
else
return ifFalse
endProcedure if
/*--- embedded ASSignement:
assign the second argument to the variable with name in first arg
and return the value assigned ----------------------------------*/
ass:
call value arg(1), arg(2)
return arg(2)
/*--- embedded ASSignement only if NotNull:
assign the second argument to the variable with name in first arg
if the second arg is not null, return new value ---------------*/
assIf:
if arg(2) == '' then
return value(arg(1))
call value arg(1), arg(2)
return arg(2)
/*--- return first nonNull argument ---------------------------------*/
nn:
if arg(1) \== '' then
return arg(1)
if arg(2) \== '' then
return arg(2)
call err 'nn() both args empty'
/*--- embedded ASSignement return NotNull:
assign the second argument to the variable with name in first arg
and return 1 if value not null, 0 if null ----------------------*/
assNN:
call value arg(1), arg(2)
return arg(2) \== ''
/*--- return current time and cpu usage ------------------------------*/
timing: procedure expose m.
return return time() 'ela='time('E') 'cpu='sysvar('syscpu'),
'su='sysvar('syssrv')
timingTest: procedure expose m.
say 'begin' timing() sysvar('sysnode')
do 30000000
end
say 'end ' timing()
return
/*--- sleep several seconds ------------------------------------------*/
sleep: procedure expose m.
parse arg secs, sayIt
if sayit <> 0 then
say 'sleeping' secs 'secs' time()
CALL SYSCALLS 'ON'
ADDRESS SYSCALL "sleep" secs
CALL SYSCALLS 'OFF'
if sayit <> 0 then
say 'slept' secs 'secs' time()
return
endProcedure sleep
/*--- elongate inp with spaces up to given len -----------------------*/
elong: procedure expose m.
parse arg inp, len
if length(inp) >= len then
return inp
return left(inp, len)
endProcedure elong
/*--- quote string txt using quoteChar qu ("""" ==> ") ---------------*/
quote: procedure expose m.
parse arg txt, qu
if qu = '' then
qu = '"'
res = qu
ix = 1
do forever
qx = pos(qu, txt, ix)
if qx = 0 then
return res || substr(txt, ix) || qu
res = res || substr(txt, ix, qx-ix) || qu || qu
ix = qx + length(qu)
end
endProcedure quote
/*--- return the count of occurrences of needle in heyStack ----------*/
posCount: procedure expose m.
parse arg needle, hayStack, start, fin
if start = '' then
start = 1
if fin = '' then
fin = length(hayStack) + 1 - length(needle)
do cnt = 0 by 1
start = pos(needle, haystack, start)
if start < 1 | start > fin then
return cnt
start = start + length(needle)
end
endProcedure posCount
repAll: procedure expose m.
parse arg src, w, new
res = ''
cx = 1
do forever
nx = pos(w, src, cx)
if nx < 1 then
return res || substr(src, cx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAll
repAllWords: procedure expose m.
parse arg src, w, new
res = ''
wx = 0
cx = 1
do forever
wx = wordPos(w, src, wx+1)
if wx < 1 then
return res || substr(src, cx)
nx = wordindex(src, wx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAllWords
/* copy ut end ********************************************************/
}¢--- A540769.WK.REXX(SPUFO) cre=2010-11-23 mod=2010-11-23-17.14.19 A540769 ----
/* rexx ****************************************************************
spufo: edit macro to reformat spufi input
synopsis SPUFO width?
input: text auf Kolonnen 1-72,
Woerter können über RecordGrenzen lappen
output: Zeilen mit Maximalbreite width (per default 72)
kein Wort lappt über RecordGrenze
Achtung: Strings mit Spaces können zerstückelt werden|||
***********************************************************************/
call errReset 'hI'
parse arg a1
if a1 \== '' then
return errHelp('use as edit macro')
call adrEdit 'macro (args)'
nWi = 72
if args \== '' then
if dataType(args, 'n') & args >= 1 then
nWi = args
else
call errHelp 'bad arg' args
call adrEdit '(lNo) = lineNum .zl'
o1 = left('---spufo width' nWi' ', 72, '-')
call adrEdit 'line_after .zl = (o1)'
src = ''
lx = 0
cx = 1
do forever
do while length(src) < 200 & lx < lNo
lx = lx + 1
call adrEdit '(l1) = line' lx
src = src || left(l1, 72)
end
if pos(' ', substr(src, cx+nWi-1, 2)) > 0 then do
nx = cx+nWi
end
else do
nx = lastPos(' ', src, cx+nWi-1)
if nx <= cx then
nx = cx + nWi
end
o1 = substr(src, cx, nx-cx)
call adrEdit 'line_after .zl = (o1)'
mx = nx // 72
if mx \== 1 then do
ns = nx + (73-mx) // 72
vx = verify(src, ' ', 'n', nx)
if ns <= vx then
nx = ns
else
nx = max(nx, vx-4)
end
do while nx > 72
src = substr(src, 73)
nx = nx-72
end
if src == '' then
leave
cx = nx
end
exit
/* copy adrIsp begin *************************************************/
/**********************************************************************
lmd: catalog read
call sequence: lmdBegin, lmdNext*, lmdEnd
mit lmd service (mit save in file und read,
weil list zu langsam und listcat abstürzt)
1. arg (grp) als group dataset für lmd save
und dd name für file read
***********************************************************************/
lmdBegin: procedure expose m.
parse arg grp, lev
call adrIsp 'lmdinit listid(lmdId) level('lev')'
res = adrIsp('lmdlist listid(&lmdId) option(save) group('grp')', 4)
call adrIsp 'lmdfree listid(&lmdId)'
if res = 0 then do
call trc timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') shr dsn('grp'.datasets)'
end
else do
call trc 'no datasets found' timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') dummy'
end
call readDDBegin grp
return /* end lmdBegin */
lmdNext:
parse arg ggGrp, ggSt, withVolume
if \ readDD(ggGrp, ggSt) then
return 0
if withVolume \== 1 then
do ggIx=1 to value(ggSt'0')
x = value(ggSt || ggIx, word(value(ggSt || ggIx), 1))
end
return 1
endSubroutin lmdNext
lmdEnd: procedure expose m.
parse arg grp
call readDDEnd grp
call adrTso 'free dd('grp')'
return /* end lmdEnd */
lmd: procedure expose m.
parse arg lev, withVol
call lmdBegin gg1, lev
do while lmdNext(gg1, q., withVol)
do x=1 to q.0
call jOut q.x
end
end
call lmdEnd gg1
return
endProcedure lmd
/**********************************************************************
member list of a pds:
call sequence x=lmmBegin(dsn) lmmNext(x) * lmmEnd(x)
***********************************************************************/
lmm: procedure expose m.
parse arg dsn
id = lmmBegin(dsn)
do ix=1 by 1
m = lmmNext(id)
if m = '' then
leave
call jOut m
end
call lmmEnd id
return
endProcedure lmm
lmmBegin: procedure expose m.
parse arg dsn
mbr = dsnGetMbr(dsn)
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET('"pds"') ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(INPUT) "
res = lmmId
if mbr <> '' then
res = res 'pattern('mbr')'
return res
endProcedure lmmBegin
lmmEnd: procedure expose m.
parse arg lmmId opt
call adrIsp "LMMLIST DATAID("lmmId") option(free)", 8
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
return
endProcedure lmmEnd
lmmNext: procedure expose m.
parse arg lmmId opt
if adrIsp("LMMLIST DATAID("lmmid")" ,
"OPTION(LIST) MEMBER(Mbr)" opt, 4 8) = 0 then
return strip(mbr)
else
return ''
endProcedure lmmNext
lmmRm: procedure expose m.
parse arg dsn, mbrs
mbrs = dsnGetMbr(dsn) mbrs
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET("pds") ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(OUTPUT) "
err = ''
do wx=1 to words(mbrs)
m1 = word(mbrs, wx)
rr = adrIsp("lmmDel dataid("lmmId") member("m1")", 0 8 12)
if rc = 0 then
say 'removed' m1 'from' pds
else if rc = 8 then
say 'not found' m1 'in' pds
else do
err = 'error deleting' m1 'in' pds 'rc' rr strip(zerrlm)
say err
leave
end
end
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
if err <> '' then
call err err
return
endProcedure lmmRm
/*--- address ispf with error checking -------------------------------*/
adrIsp:
parse arg ggIspCmd, ggRet
address ispexec ggIspCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr ispExec rc' rc 'in' ggIspCmd':' strip(zerrlm)
endSubroutine adrIsp
/*--- address editor with error checking -----------------------------*/
adrEdit:
parse arg ggEditCmd, ggRet
address isrEdit ggEditCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr isrEdit rc' rc 'for' ggEditCmd
endSubroutine adrEdit
/* copy adrIsp end *************************************************/
/* copy err begin ******************************************************
messages, errorhandling,help
***********************************************************************/
errIni: procedure expose m.
if m.err.ini == 1 then
return
call outIni
m.err.ini = 1
m.err.handler = ''
m.err.cleanup = ';'
m.err.opt = ''
return
endProcedure errIni
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err.opt, m.err.handler
if pos('I', translate(m.err.opt)) > 0 then
if sysVar('sysISPF') = 'ACTIVE' then
call adrIsp 'control errors return'
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
call errIni
drop err handler cleanup opt call return
if ggOpt == '' & m.err.handler \== '' then do
if 1 then do /* no detection of recursive err call loop
--> will anyway fail by stack overflow */
interpret m.err.handler
end
else do
/* avoid recursive err call loop */
drop call return
if symbol('m.err.call') \== 'VAR' then
m.err.call = 1
else
m.err.call = m.err.call + 1
if m.err.call > 10 then do
say 'errHandler loop:' m.err.handler
end
else do
m.err.return = 1
call errInterpret m.err.handler
m.err.call = m.err.call - 1
if m.err.return then
return result
end
end
end
call outPush
call errSay ggTxt, 'e'
call errCleanup
if ggOpt == '' then
ggOpt = m.err.opt
ggOpt = translate(ggOpt)
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 then do
call errSay 'divide by zero to show stackHistory', 'e'
x = 1 / 0
end
call errSay 'exit(12)', 'e'
exit errSetRc(12)
endSubroutine err
errAddCleanup: procedure expose m.
parse arg code
if m.err.ini \== 1 then
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
if m.err.ini \== 1 then
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
cl = m.err.cleanup
if cl = ';' then
return
m.err.cleanup = ';'
call out 'err cleanup begin' cl
call errInterpret cl
call out 'err cleanup end' cl
return
endProcedure errCleanup
errInterpret: procedure expose m.
parse arg code
interpret code
m.err.return = 0
return
endProcedure errInterpret
/*--- assert that the passed rexx expression evaluates to true -------*/
assert:
interpret 'assertRes =' arg(1)
if \ assertRes then
call err 'assert failed' arg(1)':' arg(2)
return
endProcedure assert
/*--- output an errorMessage msg with pref pref
split message in lines at '/n' ---------------------------*/
errSay: procedure expose m.
parse arg msg, pref
parse source . . ggS3 . /* current rexx */
if pref == 'e' then
msg = 'fatal error in' ggS3':' msg
else if pref == 'w' then
msg = 'warning in' ggS3':' msg
else if pref \== '' then
msg = pref':' msg
return outNl(msg)
endProcedure errSay
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg, op
call errSay msg, 'e'
call help
call err msg, op
endProcedure errHelp
/*--- return the Operating System we are running on: TSO or LINUX ---*/
errOS: procedure expose m.
parse source os .
return os
endProcedure errOS
/*--- set rc for ispf: -------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared varible 3IspfRc
back as return code
----------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- output a trace message if m.tr is set -----------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
call out 'debug' msg
return
endProcedure debug
/*--- return current time and cpu usage ------------------------------*/
timing: procedure expose m.
return return time() 'ela='time('E') 'cpu='sysvar('syscpu'),
'su='sysvar('syssrv')
timingTest: procedure expose m.
say 'begin' timing() sysvar('sysnode')
do 30000000
end
say 'end ' timing()
return
/*--- display the first comment block of the source as help ----------*/
help: procedure expose m.
parse source . . s3 .
call out right(' help for rexx' s3, 79, '*')
do lx=1 by 1
if pos('/*', sourceLine(lx)) > 0 then
leave
else if lx > 10 then do
call out '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
call out li
end
call out right(' end help for rexx' s3, 79, '*')
return 4
endProcedure help
/*--- output all lines (separated by '\n') of all args --------------*/
outNl: procedure expose m.
do ax=1 to max(1, arg())
msg = arg(ax)
sx = 0
bx = -1
do lx=1 until bx >= length(msg)
ex = pos('\n', msg, bx+2)
if ex < 1 then
ex = length(msg)+1
call out substr(msg, bx+2, ex-bx-2)
bx = ex
end
end
return 0
endProcedure outNl
/*--- 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
/*--- if function ----------------------------------------------------*/
if: procedure expose m.
parse arg co, ifTrue, ifFalse
if co then
return ifTrue
else
return ifFalse
endProcedure if
/* copy err end *****************************************************/
/* copy out begin ******************************************************
out interface with simplistic implementation
***********************************************************************/
outIni: procedure expose m.
parse arg msg
if m.out.ini == 1 then
return
m.out.ini = 1
m.out.dst = ''
return
endProcedure outIni
/*--- output a message to the current destination -------------------*/
out: procedure expose m.
parse arg msg
if m.out.ini \== 1 then
call outIni
if m.out.dst == '' then do
say msg
end
else do
st = m.out.dst
sx = m.st.0 + 1
m.st.0 = sx
m.st.sx = msg
end
return 0
endProcedure out
/*--- push an out destination ---------------------------------------*/
outPush: procedure expose m.
parse arg m.out.dst
return
endProcedure outPush
/* copy out end *****************************************************/
}¢--- A540769.WK.REXX(SQL) cre=2016-10-28 mod=2016-10-28-14.01.53 A540769 ------
/* copy sql begin ****************************************************/
/*** sql.1: basic interface to dsnRexx *******************************/
/*--- initialize sql ------------------------------------------------*/
sqlIni: procedure expose m.
if m.sql_ini == 1 then
return
m.sql_ini = 1
call utIni
m.sqlNull = '---'
m.sqlInd = 'sqlInd'
m.sql_defCurs= 49
m.sqlCAMsg = 0
m.sqlSuMsg = 2
m.sql_dbSys = ''
m.sql_rzDb = ''
isInProd = wordPos(sysvar(sysNode), 'RZ2') > 0
m.sql_retOk = 'dne' copies('rod', \ isInProd)
m.sql_retOkDef = m.sql_RetOk
m.sql_cursors = left('', 100)
return 0
endProcedure sqlIni
sqlRetDef: procedure expose m.
m.sql_retOk = m.sql_retOkDef
return
/*--- execute sql thru the dsnRexx interface fail if sqlcode <> 0 ---*/
sqlExec0: procedure expose m.
parse arg ggSqlStmt, ePlus
if abbrev(ggSqlStmt, 'disCon') | abbrev(ggSqlStmt, 'connec') then
address dsnRexx ggSqlStmt
else
address dsnRexx 'execSql' ggSqlStmt
if rc == 0 & sqlCode == 0 & sqlWarn.0 == ' ' then
return 0
m.sql_errRet = 1
if \ dataType(sqlCode, 'n') | abs(rc) \== 1 then
ePlus = strip(ePlus 'dsnRexx rc='rc'\n')
if wordPos('ret', m.Sql_retOK) < 1 then
call err ePlus || sqlMsg()
else
call errSay ePlus || sqlMsg()
return sqlCode
endProcedure sqlExec0
/*--- connect to the db2 subsystem sys
cCla = connectionClass
e = rexx local only
r = rexx local only, rdr&objects
s = rexx local only, rdr&objects, stmts (default local)
c = with csmASql , rdr&objects
w = with sqlWsh , rdr&objects, stmts (default remote) ----*/
sqlConnect: procedure expose m.
parse arg sys, cCla
upper sys
if abbrev(sys, '*/') then
sys = substr(sys, 3)
if pos('/', sys) <= 0 then
cCla = firstNS(translate(cCla, 'rs', 'cw'), 's')
else if cCla = '' then
cCla = 'w'
if cCla == 'e' then
m.sql_conCla = 'sql E no connection class'
else
interpret 'm.sql_conCla = sqlConClass_'cCla'(sys, cCla)'
if pos(cCla, 'ers') == 0 then do
m.sql_conRzDB = sys
return
end
call sqlIni /* initialize dsnRexx */
address tso "SUBCOM DSNREXX"
if rc <> 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
if sys = '-' then
return 0
if sys == '' then
if sysvar(sysnode) == 'RZ4' then
sys = 'DP4G'
else if sysvar(sysnode) == 'RZX' then
sys = 'DX0G'
else
call err 'no default dbSys for' sysvar(sysnode)
m.sql_conRzDB = sys
m.sql_dbSys = sys
return sqlExec0('connect' sys)
endProcedure sqlConnect
/*--- diconnect from db2 --------------------------------------------*/
sqlDisconnect: procedure expose m.
parse arg retOk
m.sql_conCla = ''
m.sql_conRzDb = ''
if m.sql_dbSys == '' then
return 0
m.sql_dbSys = ''
m.sql_csmHost = ''
return sqlExec0('disConnect')
endProcedure sqlDisconnect
/*--- execute sql thru the dsnRexx interface
check for handled errors, recover from easy errors -------*/
sqlExec: /* no procedure, to keep variables sql... */
parse arg ggSqlStmt, ggSqlRet0
m.sql_HaHi = '' /* empty error Handler History */
do forever /* for retries */
address dsnRexx 'EXECSQL' ggSqlStmt
if rc == 0 & sqlCode == 0 & sqlWarn.0 == ' ' then
return 0
if \ dataType(sqlCode, 'n') | abs(rc) \== 1 then
return err('dsnRexx rc='rc sqlMsg())
ggSqlRet = ggSqlRet0 m.sql_retOk
if pos('*', ggSqlRet) >0 | wordPos(sqlCode,ggSqlRet) >0 then do
if sqlCode < 0 & pos('say', ggSqlRet) > 0 then
call outNl errMsg(' }'sqlMsg())
return sqlCode
end
if sqlCode >= 0 then do
if (sqlCode > 0 | sqlWarn.0 \== ' ') ,
& pos('w', ggSqlRet) < 1 then
call outNl errMsg(' }'sqlMsg())
return sqlCode
end
if translate(word(ggSqlStmt, 1)) == 'DROP' then do
if (sqlCode == -204 | sqlCode == -458) ,
& wordPos('dne', ggSqlRet) > 0 then
return sqlCode
if sqlCode = -672 & wordPos('rod', ggSqlRet) > 0 ,
& length(m.sql_hahi) < 1000 then do
m.sql_hahi = m.sql_HaHi || sqlMsgLine(sqlCode,
, 'tb='sqlErrMc ,ggSqlStmt)'\n'
m.sql_hahi = m.sql_HaHi || sqlExecHaHi('alter table' ,
SqlErrMc 'drop restrict on drop')'\n'
iterate
end
end
ggSqlEE = ''
if wordPos('rb', ggSqlRet) > 0 then
ggSqlEE = '\n'sqlExecHaHi('rollback')
if wordPos('ret', ggSqlRet) < 1 then do
call err m.sql_hahi || sqlMsg() || ggSqlEE
return sqlCode
end
m.sql_errRet = 1
call errSay errMsg(' }'m.sql_haHi || sqlMsg() || ggSqlEE)
return sqlCode
end
endProcedure sqlExec
/*--- execute sql fail showing haHi or return msgLine ---------------*/
sqlExecHaHi: procedure expose m.
parse arg ggSqlStmt
return sqlMsgLine(sqlExec0(ggSqlStmt, m.sql_hahi) ,
, , ggSqlStmt)
endProcedure sqlExechaHi
/*--- short message for executed sql including count ----------------*/
sqlMsgLine: procedure expose m. sqlErrD.
parse arg res, cnt, src, plus
verb = translate(word(src, 1))
if datatype(res, 'n') then
res = 'sqlCode' res
if cnt \== '' then do
res = res',' cnt
vx = wordPos(translate(word(src,1)), 'DELETE INSERT UPDATE')
if datatype(cnt, 'n') then
if vx > 0 then
res = res 'rows' word('deleted inserted updated', vx)
else if cnt <> 0 then
res = res 'rows updated'
end
if plus \== '' then
res = res',' plus
if abbrev(res, ', ') then
res = substr(res, 3)
if src \== '' then do
ll = 75 - length(res)
aa = strip(src)
if length(aa) > ll then
aa = space(aa, 1)
if length(aa) > ll then
aa = left(aa, ll-3)'...'
res = res':' aa
end
return res
endProcedure sqlMsgLine
/*--- send a command to db2 through the TSO dsn processor -----------*/
sqlDsn: procedure expose m.
parse arg st, sys, cmd, rcOk
x = outtrap('M.'st'.')
push 'END'
push cmd
address tso 'DSN SYSTEM('sys')'
rr = rc
x = outtrap(off)
if rr = 0 | rcOk = '*' | wordPos(rr, rcOk) > 0 then
return rr
fl = max(1, m.st.0 - 10)
em = 'rc' rr 'for DSN SYSTEM('sys') cmd' cmd,
'\nOuputlines' fl '-' m.st.0':'
do lx=fl to m.st.0
em = em '\n' strip(m.st.lx, 't')
end
call err em
endProcedure sqlDsn
/*** sql.2: error Handler and error Reporting ************************/
/*--- return an sql error message (multiline \n) --------------------*/
sqlMsg: /* no procedure, to keep variables sql... */
if \ dataType(sqlCode, 'n') then do
ggRes = 'sqlCode' sqlCode 'not numeric\n'sqlCaMsg()
end
else do
ggRes = sqlDsntiar(sqlRx2CA())
ggWa = sqlMsgWarn()
if ggWa \= '' then
ggRes = ggRes'\nwarnings' ggWa
if m.sqlCAMsg == 1 then
ggRes = ggRes'\n'sqlCaMsg()
end
ggSt = 'SQL_HOST'
ggVa = 'SQL_HOST.VAR'
ggBe = 'SQL_HOST.BEF'
call sqlHostVars ggSqlStmt, 12, ggSt
ggFrom = 'ggSqlStmt'
ggW1 = translate(word(ggSqlStmt, 1))
ggW2 = translate(word(ggSqlStmt, 2))
if ggW1 == 'PREPARE' then
ggFrom = sqlHostVarFind(ggSt, 'FROM')
else if ggW1 ggW2 == 'EXECUTE IMMEDIATE' then
ggFrom = sqlHostVarFind(ggSt, 1)
ggPos = 0
if datatype(sqlErrd.5, 'n') & sqlErrd.5 > 0 then do
ggPos = sqlErrd.5
ggRes = ggRes || sqlMsgSrcPos(value(ggFrom), sqlErrd.5)
end
if ggFrom == 'ggSqlStmt' then do
ggRes = ggRes'\nsql =' sqlShorten(ggSqlStmt, 2000, ggPos)
end
else do
ggRes = ggRes'\nsql =' sqlShorten(value(ggFrom), 2000, ggPos)
ggRes = ggRes'\nstmt =' sqlShorten(ggSqlStmt, 2000)
end
ggPref = '\nwith'
do ggXX=1 to m.ggSt.0
if ggFrom = m.ggVa.ggXX then
iterate
ggRes = ggRes || ggPref m.ggBe.ggXX ':'m.ggVa.ggXX ,
'=' sqlShorten(value(m.ggVa.ggXX), 210)
ggPref = '\n '
end
/* if m.sqlSuMsg == 1 | (m.sqlSuMsg == 2 & m.sql_csmhost \== '') then
ggRes = ggRes'\nsubsys =' m.sql_dbSys ,
|| ', host =' m.sql_csmhost
*/ return ggRes
endSubroutine sqlMsg
sqlShorten: procedure expose m.
parse arg txt, maxL, pos
if length(txt) <= maxL then
return txt
if \ datatype(pos, 'n') | pos < 1 then
pos = 1
ex = pos + min(60, maxL-7)
if ex <= maxL - 4 then
return left(txt, maxL-4) '...'
if ex >= length(txt) then
return left(txt, 67) '...\n'substr(txt, length(txt)-maxL+72)
else
return left(txt, 67) '...\n'substr(txt, ex-maxL+76, maxL-75) ,
'...'
endProcedure sqlShorten
/*--- use dsnTiar to translate sql Info to error text ---------------*/
sqlDsnTiar: procedure expose m.
parse arg ca
if -438 = sqlCa2Rx(ca) then
return '\nSQLCODE = -438:',
'APPLICATION RAISED ERROR WITH sqlState' sqlState ,
'and DIAGNOSTIC TEXT:' sqlErrMc
liLe = 78
msLe = liLe * 10
msg = d2c(msLe,2) || left('', msLe)
len = d2c(liLe, 4)
ADDRESS LINKPGM "DSNTIAR ca msg len"
if rc = 0 then nop
else if rc = 4 then say 'warn linkPgm dsnTiar rc' rc 'sqlCa' ca
else call err 'linkPgm dsnTiar rc' rc 'sqlCa' ca
res = strip(substr(msg, 13, liLe-10))
cx = pos(', ERROR: ', res)
if cx > 0 then
res = left(res, cx-1)':' strip(substr(res, cx+9))
do c=3+liLe by liLe to msLe while substr(msg, c, 10) = ''
res = res'\n 'strip(substr(msg, c+10, liLe-10))
end
return res
endProcedure sqlDsnTiar
/*--- format all rexx sqlCa fields into a message -------------------*/
sqlCaMsg:
return 'sqlCode' sqlCode 'sqlState='sqlState ,
'\n errMC='translate(sqlErrMc, ',', 'ff'x) ,
'\n warnings='sqlWarnCat('+') 'erP='sqlErrP ,
'\n errD.1='sqlErrD.1 '2='sqlErrD.2 '3='sqlErrD.3 ,
'\n errD.4='sqlErrD.4 '5='sqlErrD.5 '6='sqlErrD.6
endProcedure sqlCaMsg
/*--- concat the sql warnings with Separator sep --------------------*/
sqlWarnCat: procedure expose m. sqlWarn.
parse arg sep
return sqlWarn.0 || sep,
|| sqlWarn.1||sqlWarn.2||sqlWarn.3||sqlWarn.4||sqlWarn.5||sep ,
|| sqlWarn.6||sqlWarn.7||sqlWarn.8||sqlWarn.9||sqlWarn.10||sep
endProcedure sqlWarnCat
/*--- format the sqlCA into the dsnTiar SQLCA -----------------------*/
sqlRx2Ca: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
if \ (datatype(sqlcode, 'n') & datatype(sqlErrD.1, 'n') ,
& datatype(sqlErrD.3, 'n')) then
return err('sqlCode etc. not numeric\nsqlCa =' sqlCaMsg())
if digits() < 10 then
numeric digits 10
sqlCa = 'SQLCA ' || d2c(136, 4) || d2c(sqlCode, 4) ,
|| d2c(min(70, length(sqlErrMc)), 2)left(sqlErrMc, 70) ,
|| left(sqlErrP, 8) ,
|| d2c(sqlErrD.1, 4)d2c(sqlErrD.2, 4)d2c(sqlErrD.3, 4) ,
|| d2c(sqlErrD.4, 4)d2c(sqlErrD.5, 4)d2c(sqlErrD.6, 4) ,
|| sqlWarnCat() || sqlState
if length(sqlCa) <> 136 then
call err 'sqlCa length' length(sqlCa) 'not 136' ,
'\n'sqlCaMsg() '==>' ca', hex='c2x(ca)
return sqlCa
endProcedure sqlRx2Ca
/*--- extract the fields from the SqlCA and put it to rexx vars -----*/
sqlCA2Rx: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
parse arg ca
numeric digits 10
if length(ca) < 136 | c2d(substr(ca, 9, 4), 4) <> 136 then
call err 'bad sqlCa len' length(ca) 'not 136:' ca', hex='c2x(ca)
sqlCode = c2d(substr(ca, 13 ,4), 4)
sqlErrMC = substr(ca, 19, c2d(substr(ca, 17, 2), 2))
sqlErrP = substr(ca, 89, 8)
do ix=1 to 6
sqlErrD.ix = c2d(substr(ca, 93 + 4 * ix, 4), 4)
end
do ix=0 to 10
sqlWarn.ix = substr(ca, 121 + ix, 1)
end
sqlState = substr(ca, 132, 5)
return sqlCode
endProcedure sqlCA2Rx
/*--- make the text for sqlWarnings ---------------------------------*/
sqlMsgWarn: procedure expose m. sqlWarn.
r = ''
text =' 1=W var truncated, 1=S scrollable, 1=N nonScrollable,' ,
'2=W nulls in aggregate,' ,
'3=W more cols than vars,' ,
'3=Z more result sets than locators,' ,
'4=W no where, 4=D sensitive dynamic, 4=I insensitive,' ,
'4=S sensitive static,' ,
'5=W not valid sql, 5=1 readOnly, 5=2 readDelete,' ,
'5=3 readDeleteUpdate,' ,
'6=W day changed to month range,' ,
'7=W dec digits truncated,' ,
'8=W char substituted,' ,
'9=W arith excep in count, 9=Z multipe result sets,' ,
'10=W char conversion err in ca,'
do wx = 1 to 10
w = sqlWarn.wx
if w = ' ' then
iterate
t = wx'='w
cx = pos(' 'wx'='w' ', text)
ex = pos(',' , text, cx + 1)
if cx > 0 & ex > cx then
r = r substr(text, cx+1, ex-cx)
else
r = r wx'='w '?,'
end
r = strip(r, 't', ',')
if r = '' & sqlwarn.0 <> '' then
call err 'sqlWarn.0='sqlWarn.0 'but all warns empty'
return r
endProcedure sqlMsgWarn
/*--- show in the source src the point pos (where error occured)
a few lines from src around pos and arrow to pos ----------*/
sqlMsgSrcPos: procedure expose m.
parse arg src, pos
liLe = 68
liCn = 3
afLe = 25
t1 = space(left(src, pos), 1)
t2 = left(' ', substr(src, pos, 1) == ' ' ,
| substr(src, pos+1, 1) == ' ') ,
|| space(substr(src, pos+1), 1)
afLe = min(afLe, length(t2))
if length(t1) + afLe > liLe * liCn then
t1 = '...'right(t1, liLe * liCn - afLe -3)
else if length(t1)+length(t2) > liLe then
t1 = left(' ', (liCn * liLe - length(t1) -afLe) // liLe)||t1
pL = length(t1) // liLe
if length(t2) <= liLe-pL then
tx = t1 || t2
else
tx = t1 || left(t2, liLe-pL-3)'...'
res = '\nsrc' strip(substr(tx, 1, liLe), 't')
do cx=1+liLe by liLe to length(tx)
res = res || '\n +' strip(substr(tx, cx, liLe), 't')
end
loc = 'pos' pos 'of' length(src)
if length(loc)+6 < pL then
return res'\n >' right('>>>'loc'>>>', pL)
else
return res'\n >' left('', pL-1)'<<<'loc'<<<'
endProcdedure sqlMsgSrcPos
/*--- get the hostVars in the sql in src and the word before --------*/
sqlHostVars: procedure expose m.
parse arg src, cnt, st
cx = 1
sx = 1
do cnt
cx = pos(':', src, cx) + 1
if cx < 2 then
leave
if pos(substr(src, cx, 1), m.ut_rxN1) > 0 then
iterate
ex = verify(src, m.ut_rxDot, 'n', cx)
if ex < 1 then
m.st.var.sx = substr(src, cx)
else
m.st.var.sx = substr(src, cx, ex - cx)
if m.st.var.sx == '' | length(m.st.var.sx) > 100 then
iterate
/* search word before */
do bE = cx-2 by -1 to 1 ,
while substr(src, bE, 1) == ' '
end
do bB = bE by -1 to max(1, bE-20),
while pos(substr(src, bB, 1), m.ut_alfa) > 0
end
if bB < bE & bB >= 0 then
m.st.bef.sx = substr(src, bB+1, bE-bB)
else
m.st.bef.sx = ''
sx = sx + 1
end
m.st.0 = sx-1
return sx
endProcedure sqlHostVars
/*--- find the name of hostvar, by index or by before ---------------*/
sqlHostVarFind: procedure expose m.
parse arg st, fnd
if datatype(fnd, 'n') & fnd <= m.st.0 then
return m.st.var.fnd
do ix=1 to m.st.0
if translate(m.st.bef.ix) = fnd then
return m.st.var.ix
end
return ''
endSubroutine sqlHostVarFind
/*** sql.3: query/update/call interface ******************************/
/*--- reset sql cursor 'c'cx fields ---------------------------------*/
sqlReset: procedure expose m.
parse arg cx
m.sql.cx.updateCount = ''
m.sql.cx.fetchCount = 0
m.sql.cx.resultSet = ''
m.sql.cx.resultSet.0 = 0
m.sql.cx.i.sqlD = 'noDescInp'
m.sql.cx.var.0 = 0
return sqlResetCrs(cx)
endProcedue sqlReset
sqlResetCrs: procedure expose m.
parse arg cx
m.sql.cx.d.sqlD = 'noSqlDA'
m.sql.cx.fetchVars = ''
m.sql.cx.fetchFlds = ''
m.sql.cx.fetchClass = ''
m.sql.cx.type = ''
return 0
endProcedue sqlResetCrs
/*--- execute a query from sql, with one resultset ------------------*/
sqlQuery: procedure expose m.
parse arg cx, src, feVa, retOk
res = sqlPreDec(cx, src, feVa, retOk)
if res < 0 then
return res
res = sqlExec('open c'cx, retOk)
if res < 0 then
return res
m.sql.cx.updateCount = sqlErrd.3
m.sql.cx.resultSet = cx
return res
endProcedure sqlQuery
/*--- prepare statement and declare cursor --------------------------*/
sqlPreDec: procedure expose m.
parse arg cx, src, feVa, retOk
call sqlReset cx
s1 = ''
if pos(left(feVa, 1), '?:') < 1 then
s1 = 'into :M.SQL.'cx'.D'
res = sqlExec('prepare s'cx s1 'from :src', retOk)
if res < 0 then
return res
call sqlFetchVars cx, feVa
return sqlExec0('declare c'cx 'cursor for s'cx)
endProcedure sqlPreDec
/*--- prepare a query from sql, with one resultset ------------------*/
sqlQueryPrepare: procedure expose m.
parse arg cx, src, feVa, retOk
res = sqlPreDec(cx, src, feVa, retOk)
if res < 0 then
return res
return sqlExec0('describe input s'cx 'into :M.SQL.'cx'.I')
endProcedure sqlQueryPrepare
/*--- open a prepared query -----------------------------------------*/
sqlQueryExecute: procedure expose m.
parse arg cx retOk
do ix=1 to arg()-1
call sqlDASet cx , 'I', ix, arg(ix+1)
end
res = sqlExec('open c'cx 'using descriptor :M.SQL.'cx'.I', retOk)
if res < 0 then
return res
m.sql.cx.updateCount = sqlErrd.3
m.sql.cx.resultSet = cx
return res
endProcedure sqlQueryExecute
/*--- fetch next row to m.dst.* at end return false -----------------*/
sqlFetch: procedure expose m.
parse arg cx, dst, retOk
fetCode = sqlExec('fetch c'm.sql.cx.resultSet ,
'into' m.sql.cx.fetchVars, 100 retOk)
if fetCode == 100 then
return 0
if fetCode < 0 then
return fetCode
m.sql.cx.fetchCount = m.sql.cx.fetchCount + 1
interpret m.sql.cx.fetchCode
return 1
endProcedure sqlFetch
/*--- close cursor 'c'cx --------------------------------------------*/
sqlClose: procedure expose m.
parse arg cx, retOk
m.sql.cx.sqlClosed = 1
return sqlExec('close c'm.sql.cx.resultSet, retOk)
endProcedure sqlRxClose
/*-- execute an sql with no resultset, but possibly outParms --------*/
sqlUpdate: procedure expose m.
parse arg cx, src, retOk
m.sql.cx.updateCount = ''
m.sql.cx.resultSet = ''
bx = verify(src, '( ')
if bx > 0 then do
parse upper value substr(src, bx) with fun fu2 fu3 .
if fun == 'SET' & \ (fu2=='CURRENT' & left(fu3, 7)=='PACKAGE') ,
then do
w2 = translate(word(substr(src, bx), 2))
if \ abbrev(w2, ':') then
return sqlExec('execute immediate :src', retOk)
ex = pos('=', w2)
if ex = 0 then
ex = length(w2)+1
vn = strip(substr(w2, 2, ex-2))
if vn = '' then
call err 'bad hostVar in' src
m.sql.cx.Var.0 = 1
m.sql.cx.VarName.1 = vn
abc = 'und so weiter'
trace ?r
src2 = 'set :M.sql.'cx'.var.1' substr(w, ex) subword(src, 3)
src2 = 'set :abc' substr(w, ex) subword(src, 3)
return sqlExec('execute immediate :src2', retOk)
end
if fun == 'DECLARE' then do
if 'GLOBAL' == translate(word(substr(src, bx), 2)) then
return sqlExec('execute immediate :src', retOk)
end
res = sqlExec(src, retOk)
if wordPos(fun, 'DELETE INSERT UPDATE') > 0 then
m.sql.cx.updateCount = sqlErrd.3
return res
endProcedure sqlUpdate
/*-- prepare an update ----------------------------------------------*/
sqlUpdatePrepare: procedure expose m.
parse arg cx, src, retOk
res = sqlExec('prepare s'cx 'from :src', retOk)
return sqlExec('describe input s'cx 'into :M.SQL.'cx'.I')
endProcedure sqlUpdatePrepare
/*-- execute a prepared update with the given arguments -------------*/
sqlUpdateExecute: procedure expose m.
parse arg cx retOk
do ix=1 to arg()-1
call sqlDASet cx , 'I', ix, arg(ix+1)
end
res = sqlExec('execute s'cx 'using descriptor :M.SQL.'cx'.I',
, retOk)
m.sql.cx.updateCount = sqlErrd.3
return res
endProcedure sqlUpdateExecute
/*--- sql call statement --------------------------------------------*/
sqlCall: procedure expose m.
parse arg cx, src, retOk
call sqlReset cx
s = scanSrc(sql_call, src)
if \ scanUntil(s, ' ') | translate(m.s.tok) <> 'CALL' then
call scanErr s, 'no call'
if \ scanUntil(s, '(') then
call scanErr s, 'not ( after call'
prc = strip(m.s.tok)
s2 = ''
call scanLit s, '('
do ax=1
call scanSpaceOnly s
if scanString(s, "'") then do
m.sql.cx.var.ax = m.s.tok
call scanSpaceOnly s
end
else if scanUntil(s, ',)') then
m.sql.cx.var.ax = strip(m.s.tok)
else
call scanErr s, 'value expected in call list'
s2 = s2', :m.sql.'cx'.var.'ax
if scanLit(s, ')') then
leave
if \ scanLit(s, ',') then
call scanErr s, 'missing ,) in call list'
end
m.sql.cx.var.0 = ax
call scanSpaceOnly s
if \ scanEnd(s) then
call scanErr s, 'call does not end after )'
say cx 'a1='m.sql.cx.var.1 'a2='m.sql.cx.var.2 'a3='m.sql.cx.var.3
res = sqlExec('call' prc'('substr(s2, 3)')', 466 retOk)
say cx 'a1='m.sql.cx.var.1 'a2='m.sql.cx.var.2 'a3='m.sql.cx.var.3
if res \== 466 then
return res
cC = substr(sqlErrMc, lastPos('ff'x, sqlErrMc)+1)
rs = 'SQL.'cx'.RESULTSET'
m.rs = 100+cx
m.rs.0 = cc
m.rs.act = 0
lc = ''
do rx=1 to cc
lc = lc', :m.'rs'.'rx
end
call sqlExec0 'ASSOCIATE LOCATORS ('substr(lc, 3)')' ,
'WITH PROCEDURE' prc
if sqlNextResultSet(cx) then
return 0
else
return err('no resultset')
endProcedure sqlCall
/*--- switch to next resultset, return false if none ----------------*/
sqlNextResultSet: procedure expose m.
parse arg cx
rs = 'SQL.'cx'.RESULTSET'
if m.rs <= 100 | m.rs.act >= m.rs.0 then
return 0
ax = m.rs.act + 1
m.rs.act = ax
call sqlResetCrs cx
call sqlexec0 'allocate c'm.rs 'cursor for result set :m.'rs'.'ax
CALL SQLEXEC0 'DESCRIBE CURSOR :C'm.rs 'INTO :M.SQL.'cx'.D'
call sqlFetchVars cx
return 1
endProcedure sqlNextResultSet
/*-- execute a query, update or call --------------------------------*/
sqlExecute: procedure expose m.
parse arg cx, src, retOk
f = translate(word(src, 1))
bx = pos('(', f)
if bx > 0 then
f = left(f, max(1, bx-1))
m.sql.cx.fun = f
if f == 'SELECT' | f == 'WITH' | f == '(' then
return sqlQuery(cx, src, , retOk)
else if f == 'CALL' then
return sqlCall(cx, src, retOk)
else
return sqlUpdate(cx, src, retOk)
endProcedure sqlExecute
/*--- describe table and return sqlDA -------------------------------*/
sqlDescribeTable: procedure expose m.
parse upper arg tb, force
if force == 1 | \ datatype(m.sql.table.tb.sqlD, 'n') then
call sqlExec 'describe table :tb into :M.SQL.TABLE.'tb
return 'SQL.TABLE.'tb
endProcedure sqlDescribeTable
/*--- return select column list for table tb
omit Blobs (blobMax < 0) or substr(blob, 1, blobMax) ----------*/
sqlColList: procedure expose m.
parse arg tb al, blobMax
sd = sqlDescribeTable(tb)
bs = ''
lst = ''
if al \== '' & right(al, 1) \== '.' then
al = al'.'
do sx=1 to m.sd.sqld
if wordPos(m.sd.sx.sqlType, '404 405 408 409 412 413') < 1 then
lst = lst',' al || m.sd.sx.sqlName
else do
bs = bs m.sd.sx.sqlName
if blobMax >= 0 then
lst = lst', length('al || m.sd.sx.sqlName')' ,
m.sd.sx.sqlName'Len' ,
|| ', substr('al || m.sd.sx.sqlName ,
|| ', 1,' blobMax')' m.sd.sx.sqlName
end
end
m.sd.colList = substr(lst, 3)
m.sd.blobs = strip(bs)
return substr(lst, 3)
endProcedure sqlColList
/*--- use describe output to generate column names,
'' use names from ca (rexxified)
nms+ use names, check ca for null values
?('?'?nm)+ use names, check for null if preceeded by ?
:... use string as is
fetchVariables and sqlNull names --------------------*/
sqlFetchVars: procedure expose m.
parse arg cx, src, cd
if abbrev(src, ':') then do
m.sql.cx.fetchVars = src
m.sql.cx.fetchCode = cd
m.sql.cx.fetchFlds = ''
return
end
if src <> '' then do
ff = src
end
else do
ff = ''
do kx=1 to m.sql.cx.d.sqlD
ff = sqlNiceVarsApp(ff, m.sql.cx.d.kx.sqlName)
end
end
m.sql.cx.fetchFlds = ff
if m.sql.cx.d.sqlD <> words(ff) then
call err 'sqlFetchVars sqlD='m.sql.cx.d.sqlD ,
'<>' words(ff) 'fields of' ff
sNu = ''
sFe = ''
do kx=1 to m.sql.cx.d.sqlD
nm = word(ff, kx)
sFe = sFe', :m.dst.'nm
if m.sql.cx.d.kx.sqlType // 2 then do
sFe = sFe' :m.dst.'nm'.sqlInd'
sNu = sNu 'if m.dst.'nm'.sqlInd < 0 then' ,
'm.dst.'nm '= m.sqlNull;'
end
end
m.sql.cx.fetchVars = substr(sFe, 3)
m.sql.cx.fetchCode = sNu cd
return
endProcedure sqlFetchVars
/*--- append next column name
ensure name is unique and rexx compatible -----------------*/
sqlNiceVarsApp: procedure expose m.
parse arg old, nx rest
upper nx
cx = verifId(nx)
if cx > 0 then /* avoid bad characters for classNew| */
nx = left(nx, cx-1)
if nx <> '' & wordPos(nx, old) < 1 then
return old nx
else
return old 'COL' || (words(old) + 1)
endProcedure sqlNiceVarsApp
/*--- set one value in a DA, handle nulls ---------------------------*/
sqlDASet: procedure expose m.
parse arg cx, da, ix, val
m.sql.cx.da.ix.sqlData = val
m.sql.cx.da.ix.sqlInd = - (val == m.sqlNull)
/* data types schienen einmal nicht zu funktionieren .......
if wordPos(m.da.ix.sqlType, '384 385 388 389 392 393') > 0 then
m.da.ix.sqlType = 448 + (m.da.ix.sqlType // 2) */
return
endProcedure sqlDASet
sqlCommit: procedure expose m.
return sqlExec0('commit')
endProcedure sqlCommit
/*** sql.4: diverse helpers ******************************************/
/*-- fetch all rows to stem and close -------------------------------*/
sqlFetch2St: procedure expose m.
parse arg cx, dst, retOK
do sx=1 while sqlFetch(cx, dst'.'sx)
end
res = sx-1
m.dst.0 = sx-1
call sqlClose cx
return m.dst.0
endProcedure sqlFetch2St
/*-- execute a query, copy result to stem ---------------------------*/
sql2St: procedure expose m.
parse arg src, dst, feVa, retOK
cx = m.sql_defCurs
res = sqlQuery(cx, src, feVa, retOk)
return sqlFetch2St(cx, dst, retOk)
endProcedure sql2St
/*-- return first column of the only row and close ------------------*/
sqlFetch2One: procedure expose m.
parse arg cx, dst, retNone
f1 = sqlFetch(cx, dst)
if f1 == 1 then
f2 = sqlFetch(cx, dst'.2')
if f1 >= 0 then
call sqlClose cx
else do
say 'sqlFetch2One sqlCode='f1
call sqlClose cx, '*'
end
if f1 \== 1 then
if retNone \== '' then
return substr(retNone, 2)
else
call err 'sqlFetch2One: no row returned'
else if f2 == 1 then
call err 'sqlFetch2One: more than 1 row'
else if f2 \== 0 then
call err 'sqlFetch2One second fetch sqlCode='f2
if m.sql.cx.fetchFlds == '' then do
c1 = substr(word(m.sql.cx.fetchVars, 1), 2)
res = value(c1)
return res
end
c1 = word(m.sql.cx.fetchFlds, 1)
return m.dst.c1
endProcedure sqlFetch2One
/*-- execute a query and return first column of the only row
if > 1 row fail, if 0 rows return arg(3) or fail ---------*/
sql2One: procedure expose m.
parse arg src, dst, feVa, retOk, retNone
cx = m.sql_defCurs
call sqlQuery cx, src, feVa, retOk
return sqlFetch2One(cx, dst, retNone)
endProcedure sql2One
/*--- execute the given sql plus a commit
until no more rows are updated -----------------------------*/
sqlUpdComLoop: procedure expose m.
parse arg src, retOk
cx = m.sql_defCurs
upds = 0
if retOk == '' then
retOk = 100
do coms=0
cd = sqlExecute(crs, src, retOk)
if m.sql.crs.updateCount < 1 then do
return sqlMsgLine( , upds, src, coms 'commits')
end
upds = upds + m.sql.crs.updateCount
call sqlCommit
if coms // 20 = 19 then
say sqlMsgLine(time(), upds, src, (coms+1) 'commits')
end
endProcedure sqlUpdComLoop
/*** sql.5: manage cursors *******************************************/
/*--- return a free cursor ------------------------------------------*/
sqlGetCursor: procedure expose m.
parse arg rng
if rng == '' then
return sqlGetCursorRng(rng, 10, 48)
else if rng == 'h' then
return sqlGetCursorRng(rng, 60, 99)
else
call err 'bad cursor range' rng
endProcedure sqlGetCursor
sqlGetCursorRng: procedure expose m.
parse arg rng, fr, to
cx = pos(' ', m.sql_cursors, fr)
if cx < fr & cx > to then
call err "no more '"rng"' cursors between" fr "and" to,
":"m.sql_cursors
m.sql_cursors = overlay('u', m.sql_cursors, cx)
return cx
endProcedure sqlGetCursorRNG
/*--- mark a cursor as closed ---------------------------------------*/
sqlFreeCursor: procedure expose m.
parse arg cx
if substr(m.sql_cursors, cx, 1) \== 'u' then
call err 'sqlFreeCursor('cx') not in use :'m.sql_cursors
m.sql_cursors = overlay(' ', m.sql_cursors, cx)
return
endProcedure sqlFreeCursor
/* copy sql end ****************************************************/
}¢--- A540769.WK.REXX(SQLC) cre=2013-01-23 mod=2013-01-23-11.46.32 A540769 -----
/* copy sqlC begin ***************************************************
sql interface Compatibility mode
***********************************************************************/
/*--- prepare and declare 'c'cx from sql src -------------------------*/
sqlPreDeclare: procedure expose m.
parse arg cx, src, ggRetOk, descOut
m.sql.cx.type = ''
res = sqlPrepare(cx, src, ggRetOk, descOut)
if res >= 0 then
return sqlExec('declare c'cx 'cursor for s'cx)
return res
endProcedure sqlPreDeclare
/*--- prepare, declare and open 'c'cx from sql src -------------------*/
sqlPreOpen: procedure expose m.
parse arg cx, src, descOut, descInp
res = sqlPreDeclare(cx, src, descOut, descInp)
if res >= 0 then
return sqlOpen(cx)
return res
endProcedure sqlPreOpen
/*--- fetch cursor 'c'cx into variables ggVars -----------------------*/
sqlFetchInto:
parse arg ggCx, ggVars
if ggVars == '' then
ggVars = 'descriptor :M.SQL.'ggCX'.D'
/* accept sqlCodes > 0 except 100 */
ggRes = sqlExec('fetch c'ggCx 'into' ggVars, 100)
if ggRes == 0 then
return 1
if ggRes == 100 then
return 0
return ggRes
endProcedure sqlFetchInto
/*--- return sql variable list for stem st and fields the word in vars
if withInd == 1 then with sqlIndicator variables
sqlVars('S', 'A B') --> ':S.A, :S.B'
sqlVars('S', 'A B', 1) --> ':S.A :S.A.SQLIND, :S.B :S.B.SQLIND'
----------------------------------------------------------------------*/
sqlVars: procedure expose m.
parse arg st, vars, withInd
res = ''
if st ^== '' then
st = st'.'
do ix=1 to words(vars)
res = res', :'st || word(vars, ix)
if withInd == 1 then
res = res ':'st || word(vars, ix)'.sqlInd'
end
return substr(res, 3)
endProcedure sqlVars
/*--- open cursor 'c'cx fetch all into variables vars and close
st = passed stem, sx = row number
return number of rows fetched ----------------------------------*/
sqlOpAllCl:
parse arg ggCx, st, ggVars
if arg() >= 4 then do
call sqlDescribeInput ggCx
do ggAx=4 to arg()
call sqlDASet ggCx, 'I', ggAx-3, arg(ggAx)
end
ggRes = sqlOpen(ggCx use)
end
else do
ggRes = sqlOpen(ggCx)
end
if ggRes < 0 then
return ggRes
do sx = 1 until ggRes \== 1
ggRes = sqlFetchInto(ggCx, ggVars)
end
m.st.0 = sx - 1
call sqlRxClose ggCx
if ggRes == 0 then
return m.st.0
return ggRes
endProcedure sqlOpAllCl
/*--- prepare, declare open cursor 'c'cx, fetch all and close
return number of rows fetched ----------------------------------*/
sqlPreAllCl:
parse arg ggCx, ggSrc, st, ggVars
ggRes = sqlPreDeclare(ggCx, ggSrc)
if ggRes >= 0 then
return sqlOpAllCl(ggCx, st, ggVars)
return ggRes
endProcedure sqlPreAllCl
/*--- execute statement 's'cx using arguments arg(2), arg(3)... ------*/
sqlExecStmt:
parse arg ggCx ggRetOk /* no , for ggRetOk, arg(2) is used already| */
if ggAx > 1 then
call sqlDescribeInput ggCx
do ggAx=2 to arg()
call sqlDASet ggCx, 'I', ggAx-1, arg(ggAx)
end
return sqlExec('execute s'ggCx 'using descriptor :M.SQL.'ggCx'.I',
, ggRetOk)
endProcedure execStmt
/*--- execute immediate the sql src ----------------------------------*/
/* copy sqlC end **************************************************/
}¢--- A540769.WK.REXX(SQLCAT) cre=2016-07-11 mod=2016-07-11-15.37.44 A540769 ---
tstCatTb:
/*
$=/tstCatTb/
### start tst tstCatTb ############################################
..
select * from sysibm.SYSDUMMY1 .
IBMREQD
I .
Y .
I .
IBMREQD
$/tstCatTb/
*/
call sqlConnect
call tst t, 'tstCatTb'
call sqlCatTb 'sysDummy1'
call sqlCatTb 'SYSTableSpaceStats',
, "name = 'A403A1' and dbName = 'DA540769'"
call tstEnd t
return
endProcedure tstCatTb
sqlCatIni: procedure expose m.
if m.sqlCat_ini == 1 then
return
m.sqlCat_ini = 1
m.sqlCat_rbaF = '%-20H'
return
endProcedure sqlCatIni
sqlCatTb: procedure expose m.
parse arg ty gOnly, wh, ord, fTab, paPlus
tb = tkrTable(, ty)
if gOnly == 1 then
edFun = ''
else
edFun = tkrTable(, ty, 'e')
cx = 1
ft = 'ft'm.tb.alias
call sqlFTabReset ft, cx, 'c 1', '1 c', 12, if(fTab, , 2000)
call sqlFTabDef ft, 492, '%7e'
call FTabSet ft, 'CONTOKEN' , '%-16H'
call FTabSet ft, 'DCONTOKEN' , '%-16H'
call FTabSet ft, 'DBNAME' , '%-8C', 'db'
call FTabSet ft, 'DSNAME' , '%-44C'
call FTabSet ft, 'DSNUM' , '%5i'
call FTabSet ft, 'PARTITION' ,'%5i' , 'part'
call FTabSet ft, 'PIT_RBA' , m.sqlCat_rbaF
call FTabSet ft, 'RBA1' , m.sqlCat_rbaF
call FTabSet ft, 'RBA2' , m.sqlCat_rbaF
call FTabSet ft, 'START_RBA' , m.sqlCat_rbaF
call FTabSet ft, 'TSNAME' , '%-8C', 'ts'
call FTabSet ft, 'VERSION' , '%-28C'
if edFun \== '' then do
interpret 'sq =' edFun'(ft, tb, wh, ord)'
end
else do
cl = sqlColList(m.tb.table, m.ft.blobMax)
sq = 'select' cl tkrTable( , tb, 'f') wh ,
'order by' if(ord=='', m.tb.order, ord)
call sqlPreOpen cx, sq
call sqlFTabOthers ft
call sqlCatTbVl ft, tb
end
if fTab then
call sqlFTab ft
else
call sqlFTabCol ft
call sqlRxClose cx
call sqlCatTbTrailer space(m.TKR.path paPlus, 1), sq
return 0
endProcedure sqlCatTb
sqlCatTbVlsep:
return '+++'
sqlCatTbVl: procedure expose m.
parse arg ft, tb, sep
if sep == '' then
sep = sqlCatTbVLsep()
if m.tb.vlKey == '' then
return
ky = m.tb.vlKey
ff = ''
tt = ''
do kx=1 to m.ky.0
tt = tt || sep || m.ky.kx.col
ff = ff || sep'@'m.ky.kx.col'%S'
end
call fTabAdd ft, substr(tt,length(sep)+1), substr(ff,length(sep)+1)
return
endProcedure sqlCatTbVl
sqlCatTbTrailer: procedure expose m.
parse arg pa, sq
ox = lastPos(' order by ', sq)
if ox < 1 then
call err 'order by not found in' sq
ord = substr(sq, ox+10)
sq = left(sq, ox-1)
sqUp = translate(sq)
call out ''
call out 'dbSys:' m.sql.conDbSys
call out 'path:' pa
int = ''
iNx = ' '
br = ''
cx = 1
lx = 1
plus = 0
stops = '/*-*/ (select from where'
do while cx < length(sq)
nx = -1
do sx=1 to words(stops)
n2 = pos(word(stops, sx), sq, cx+1)
if n2 > cx & (nx < 1 | n2 < nx) then
nx = n2
end
if nx < 0 then
leave
if substr(sq, nx, 5) == '/*-*/' then do
sq = delStr(sq, nx, 5)
plus = plus + 1
cx = nx
iterate
end
call out int || substr(sq, lx, nx-lx)
int = iNx
if substr(sq, nx, 3) = '(se' then do
iNx = iNx' '
br = left(br, length(int))')'
end
cx = nx
lx = nx
end
ll = strip(substr(sq, cx))
bq = strip(br)
do while bq <> ''
if right(bq, 1) \== ')' | right(ll, 1) \== ')' then
call err 'missing ) bq:' bq', ll:' ll
ll = strip(left(ll, length(ll) - 1))
bq = strip(left(bq, length(bq) - 1))
end
call out int || ll
if br <> '' then
call out br
if ord <> '' then
call out ' order by' ord
return
endProcedure sqlCatTbTrailer
sqlCatCopy: procedure expose m.
parse arg ft, tb, wh, ord
al = m.tb.alias
sq = "select substr('' ||" al".instance || case" ,
"when" al".instance = 1 and s.clone = 'N' then ''" ,
"when s.clone = 'N' then 'only'" ,
"when s.instance =" al".instance then 'base'" ,
"else 'clone' end, 1, 6) insTxt" ,
", icType || case icType" ,
"when 'A' then '=alter'" ,
"when 'B' then '=rebuiIx'" ,
"when 'C' then '=create'" ,
"when 'D' then '=checkData'" ,
"when 'E' then '=recovToCu'" ,
"when 'F' then '=fulCopy'" ,
"when 'I' then '=incCopy'" ,
"when 'J' then '=comprDict'" ,
"when 'L' then '=sql'" ,
"when 'M' then '=modifyRec'" ,
"when 'P' then '=recovPIT'" ,
"when 'Q' then '=quiesce'" ,
"when 'R' then '=loaRpLog'" ,
"when 'S' then '=loaRpLoNo'" ,
"when 'T' then '=termUtil'" ,
"when 'V' then '=repairVer'" ,
"when 'W' then '=reorgLoNo'" ,
"when 'X' then '=reorgLog'" ,
"when 'Y' then '=loaRsLoNo'" ,
"when 'Z' then '=loaLog'" ,
"else '=???' end icTyTx" ,
',' al'.*' ,
'from' tkrTable( , tb, 't') 'join sysibm.sysTableSpace s' ,
'on' al'.dbName = s.dbName and' al'.tsName = s.name' ,
'where' wh 'order by' if(ord == '', m.tb.order, ord)
call sqlPreOpen m.ft.sqlX, sq
call sqlFTabAdd ft, dbName , '%-8C', 'db'
call sqlFTabAdd ft, tsName , '%-8C', 'ts'
call sqlFTabAdd ft, dsNum , '%4i', 'part'
call sqlFTabAdd ft, insTxt , '%6C', 'instan'
call sqlFTabAdd ft, icTyTx , '%-11C', 'icType'
call sqlFTabAdd ft, sType
call sqlFTabAdd ft, oType
call sqlFTabAdd ft, jobName
call sqlFTabAdd ft, timestamp
call sqlFTabAdd ft, dsName
call sqlFTabOthers ft
call sqlCatTbVl ft, tb
return sq
endProcedure sqlCatCOPY
sqlCatIxKeys: procedure expose m.
parse arg ft, tb, wh, ord
sq = 'select ikK.colSeq, ikK.colName, ikK.ordering, ikK.period' ,
', ik.creator, ik.name, ik.tbCreator, ik.tbName, ikC.*' ,
tkrTable(, tb ,'f') wh,
'order by' if(ord == '', m.tb.order, ord)
call sqlPreOpen m.ft.sqlX, sq
call sqlFTabAdd ft, CREATOR, '%-8C', 'creator'
call sqlFTabAdd ft, NAME , '%-16C','index'
call sqlFTabAdd ft, colSeq , '%5i', 'coSeq'
call sqlFTabAdd ft, colName, '%-16C', 'column'
call sqlFTabAdd ft, ordering
call sqlFTabAdd ft, period
call sqlFTabAdd ft, COLNO
call sqlFTabAdd ft, COLTYPE
call sqlFTabAdd ft, LENGTH
call sqlFTabAdd ft, SCALE
call sqlFTabAdd ft, NULLS
call sqlFTabOthers ft, 'COL9 COL10 COL11 COL47'
call sqlCatTbVl ft, tb
return sq
endProcedure sqlCatIxKeys
sqlCatIXStats: procedure expose m.
parse arg ft, tb, wh, ord
sq = 'select *' tkrTable( , tb, 'f') wh ,
'order by' if(ord == '', m.tb.order, ord)
call sqlPreOpen m.ft.sqlX, sq
call sqlFTabAdd ft, CREATOR, '%-8C', 'creator'
call sqlFTabAdd ft, NAME , , 'index'
call sqlFTabAdd ft, INSTANCE , '%1i' , 'i'
call sqlFTabAdd ft, PARTITION , , 'part'
call sqlFTabOthers ft
call sqlCatTbVl ft, tb
return sq
endProcedure sqlCatIXStats
sqlCatRec: procedure expose m.
parse arg ft, tb, pWh, ord
wh = sqlWhereResolve(pWh)
al = m.tb.alias
vw = catRecView('cat')
if m.recView.unl then
sq = "select fun, recover, lok || ' ' || load loadText"
else
sq = "select case when left(recover, 2) = 'ok'",
"then 'r' else '?' end fun" ,
", '' stage, 'noXDocs' loadText" ,
", '' unlTst, '' unl, '' punTst, '' pun"
sq = sq", lPad(strip(basPa), 4) || basTy|| char(basTst) basPTT",
", ( select case when count(*) <> 1" ,
"then '|' || count(*) || 'tables'",
"else max(strip(creator) ||'.'|| name) end",
"/*-*/from sysibm.sysTables t" ,
"/*-*/where t.dbName =" al".db" ,
"and t.tsName="al".ts and type not in ('A', 'V')) tb",
"," al".*",
"from" vw al,
'where' m.tb.cond wh ,
'order by' if(ord == '', m.tb.order, ord)
call sqlPreOpen m.ft.sqlX, sq
call sqlFTabAdd ft, db , '%-8C', 'db'
call sqlFTabAdd ft, ts , '%-8C', 'ts'
call sqlFTabAdd ft, pa , '%4i', 'part'
call sqlFTabAdd ft, insTxt , '%-5C', 'insta'
call sqlFTabAdd ft, fun , '%-2C', 'fun'
call sqlFTabAdd ft, stage , '%-2C', 'sta'
call sqlFTabAdd ft, recover , '%-7C', '?recov?'
call sqlFTabAdd ft, basPTT , '%-18C','part copytime'
call sqlFTabAdd ft, loadText , '%-70C', '?load?'
call sqlFTabAdd ft, unlTst , '%-19C', 'unloadTime'
call sqlFTabAdd ft, unl , '%-44C', 'unloadDSN'
call sqlFTabAdd ft, punTst , '%-19C', 'punchTime'
call sqlFTabAdd ft, pun , '%-44C', 'punch'
call sqlFTabAdd ft, 'TB' , '%-40C', 'table'
call sqlFTabOthers ft
call sqlCatTbVl ft, tb
return sq
endProcedure sqlCatRec
sqlWhereResolve: procedure expose m.
parse arg wh
wh = strip(wh)
l1 = pos('(', wh)
l2 = pos('(', wh, l1+1)
l3 = pos('(', wh, l2+1)
r1 = pos(')', wh)
r2 = pos('FROM', translate(wh))
if r2 <= 0 then
if pos('SELECT', translate(wh)) < 1 then
return wh
else
call err 'select without from in where:' wh
if l1 <= 0 | l2 <= 0 | r1 <= 0 then
call err 'bad missing first 2 brackets where:' wh
if l1 <> 1 | r1 > l2 then
call err 'bad first bracket pair in where:' wh
if l2 >= r2 | (l3 <= r2 & l3 > 0) then
call err 'bad second bracket / from in where:' wh
if translate(strip(substr(wh, r1+1, l2-r1-1))) \== 'IN' then
call err 'in missing in where:' wh
li = translate(substr(wh, 2, r1-2), ' ', ',')
ci = substr(wh, l2+1, r2-l2-1)
if translate(word(ci, 1)) \== 'SELECT' then
call err 'missing select in where:' wh
ci = subWord(ci, 2)
cj = translate(ci, ' ', ',')
c0 = words(cj)
if c0 <> words(li) then
call err 'list 1&2 not equal len in where:' wh
do cx=1 to words(cj)
lA = word(cj, cx)
c.cx = translate(substr(lA, pos('.', lA) + 1))
l.cx = word(li, cx)
end
call sql2St substr(wh, l2+1, length(wh)-l2-1),
'group by' ci 'order by' ci, rr
c1 = c.1
c2 = c.2
r = ''
do rx=1 to m.rr.0
if rx = 1 then
ex = 0
else do
ry = rx - 1
do ex=1 to c0
cA = c.ex
if m.rr.rx.cA <> m.rr.ry.cA then
leave
end
ex = ex-1
if ex < c0 - 1 then
r = r copies(')', c0-ex)
end
do dx=ex+1 to c0
cA = c.dx
if dx = ex + 1 then
r = r 'or' left('(', dx < c0)
else
r = r 'and ('
r = r l.dx "= '"m.rr.rx.cA"'"
end
end
return substr(r, 4) copies(copies(')', c0), c0>1)
endProcedure sqlWhereResolve
catRecView: procedure expose m.
parse arg m
m.recView.unl = wordPos(m.m.dbSy, 'DBOF DVBP') > 0
if \ m.recView.unl then
return 'oa1p.vqz005Recover'
call sql2St "select punTst tst, err" ,
", case when punTst < current timestamp - 1 hour" ,
"then 1 else 0 end att" ,
"from oa1p.tQZ005TecSvUnload" ,
"where stage = '-r'", recView
call out ' '
t = 'Recovery Unloads aus oa1p.tQZ005TecSvUnload'
if m.m.dbSy = 'DVBP' then
call out ' ELAR XB' t
else
call out ' EOS und eRet (XC, XR)' t
t = 'refresh='m.recView.1.tst 'err='m.recView.1.err
if m.recView.0 < 1 then
call out ' Achtung: ist leer'
else if m.recView.0 > 1 then
call out ' Achtung: zuviele ('m.recView.0') -r rows'
else if m.recView.1.att = 1 then
call out ' Achtung: älter 1h:' t
else
call out ' ' t
call out ' cx -ru ... für refresh unload'
call out ' '
return 'oa1p.vqz005RecovLoad'
endProcedure catRecView
sqlCatTables: procedure expose m.
parse arg ft, tb, wh, ord
al = m.tb.alias
sq = 'select' al'.*, tsX.type tsType, tsX.partitions',
', tsX.pgSize, tsX.dsSize' ,
',' sqlLrsn2tst('rba1') 'rba1Tst' ,
',' sqlLrsn2tst('rba2') 'rba2Tst' ,
'from' m.tb.table 'left join sysibm.sysTablespace tsX',
'on' al'.dbName = tsx.dbName and' al'.tsName = tsX.name',
'where' m.tb.cond wh ,
'order by' if(ord == '', m.tb.order, ord)
call sqlPreOpen m.ft.sqlX, sq
call sqlFTabAdd ft, creator , '%-8C', 'creator'
call sqlFTabAdd ft, NAME , '%-24C', 'table'
call sqlFTabAdd ft, type
call sqlFTabAdd ft, dbNAME , '%-8C', 'db'
call sqlFTabAdd ft, tsNAME , '%-8C', 'ts'
call sqlFTabAdd ft, tsType
call sqlFTabAdd ft, partitions, , 'parts'
call sqlFTabAdd ft, pgSize
call sqlFTabAdd ft, dsSize
call sqlFTabOthers ft, 'RBA1 RBA1TST RBA2 RBA2TST'
call sqlFTabAdd ft, rba1 , m.sqlCat_rbaF
call sqlFTabAdd ft, rba1Tst , , 'rba1Timestamp:GMT'
call sqlFTabAdd ft, rba2 , m.sqlCat_rbaF
call sqlFTabAdd ft, rba2Tst , , 'rba2Timestamp:GMT'
call sqlCatTbVl ft, tb
return sq
endProcedure sqlCatTables
sqllrsn2tst: procedure expose m.
parse arg f /* sql fails in v10 without concat | */
return "timestamp(case when length("f") = 6 then" f "|| x'0000'" ,
"when substr("f", 1, 4) = x'00000000' then" ,
"substr("f" || X'000000000000', 5, 8)" ,
"else substr("f" || X'00000000', 2, 8) end)"
sqlCatTSStats: procedure expose m.
parse arg ft, tb, wh, ord
sq = 'select' m.tb.alias'.*' ,
tkrTable( , tb, 'f') wh ,
'order by' if(ord == '', m.tb.order , ord)
call sqlPreOpen m.ft.sqlX, sq
call sqlFTabAdd ft, DBNAME, '%-8C', 'db'
call sqlFTabAdd ft, NAME , '%-8C', 'ts'
call sqlFTabAdd ft, INSTANCE , '%1i' , 'i'
call sqlFTabAdd ft, PARTITION , , 'part'
call sqlFTabAdd ft, NACTIVE , , 'nActive'
call sqlFTabAdd ft, NPAGES , , 'nPages'
call sqlFTabAdd ft, SPACE , , 'spaceKB'
call sqlFTabAdd ft, TOTALROWS , , 'totRows'
call sqlFTabAdd ft, DATASIZE , , 'dataSz'
call sqlFTabAdd ft, LOADRLASTTIME , , 'loadRLasttime'
call sqlFTabAdd ft, REORGLASTTIME , , 'reorgLasttime'
call sqlFTabAdd ft, REORGINSERTS , , 'inserts'
call sqlFTabAdd ft, REORGDELETES , , 'deletes'
call sqlFTabAdd ft, REORGUPDATES , , 'updates'
call sqlFTabAdd ft, REORGUNCLUSTINS , , 'unClIns'
call sqlFTabAdd ft, REORGDISORGLOB , , 'disorgL'
call sqlFTabAdd ft, REORGMASSDELETE , , 'massDel'
call sqlFTabAdd ft, REORGNEARINDREF , , 'nearInd'
call sqlFTabAdd ft, REORGFARINDREF , , 'farInd'
call sqlFTabAdd ft, REORGCLUSTERSENS , , 'cluSens'
call sqlFTabAdd ft, REORGSCANACCESS , , 'scanAcc'
call sqlFTabAdd ft, REORGHASHACCESS , , 'hashAcc'
call sqlFTabAdd ft, STATSLASTTIME , , 'statsLasttime'
call sqlFTabAdd ft, STATSINSERTS , , 'inserts'
call sqlFTabAdd ft, STATSDELETES , , 'deletes'
call sqlFTabAdd ft, STATSUPDATES , , 'updates'
call sqlFTabAdd ft, STATSMASSDELETE , , 'massDel'
call sqlFTabAdd ft, COPYLASTTIME , , 'copyLasttime'
call sqlFTabAdd ft, COPYUPDATETIME , , 'copyUpdatetime'
call sqlFTabAdd ft, COPYUPDATELRSN , m.sqlCat_rbaF ,
, 'updateLRSN'
call sqlFTabAdd ft, COPYUPDATEDPAGES , , 'updaPgs'
call sqlFTabAdd ft, COPYCHANGES , , 'changes'
call sqlFTabOthers ft
call sqlCatTbVl ft, tb
return sq
endProcedure sqlCatTSStats
}¢--- A540769.WK.REXX(SQLCODET) cre=2009-05-11 mod=2016-10-24-21.17.08 A540769 ---
/* rexx ****************************************************************
translate an sqlCode and Warnings to text
synopsis
sqlCodeT(sqlCode, sqlErrMC, warn, version, expEq
* return text for sqlCode with expanded arguments&warnings
sqlCodeT('/w', warn)
* return text for warnings
sqlCodeT '/g'
* generate rexx source for v8 and v9 messages
sqlCodeT '/t'
* issue some test translations
arguments:
sqlCode from sqlCA
sqlErrMC from sqlCA
warn '' or from sqlCA
sqlwarn.0':' ,
|| sqlwarn.1||sqlwarn.2||sqlwarn.3||sqlwarn.4||sqlwarn.5',' ,
|| sqlwarn.6||sqlwarn.7||sqlwarn.8||sqlwarn.9||sqlwarn.10
expEx 1 for expand arguments as ${argumentName=argumentValue}
version: 'V8', 'V9' or '' (for default, currently V8)
***********************************************************************/
/**** History **********************************************************
01.05.08 W.Keller, KIUT 23 - neu
***********************************************************************/
call errReset h
parse arg sqlCode, sqlErrMc, warn, version, expEq
if ^ abbrev(sqlCode, '/') then
return sqlCodeText(sqlCode, sqlErrMc, warn, version, expEq)
if sqlCode = '/w' then
return sqlCodeWarn(sqlErrMc)
if sqlCode = '/g' then do
call mIni
m.pref = '~wk.texv(sqlCod'
call sqlCodeConvertV8
call sqlCodeConvertV9
call sqlCodeMerge 'V8 V9', 'VV'
end
else if sqlCode = '/t' then do
call mIni
say sqlCodeText(0)
say sqlCodeText(-152)
say sqlCodeText(-152, , , 'V7')
say sqlCodeText(-152, 'eins', 'W: WWW,WWWZW', 'V8')
say sqlCodeText(-152, 'eins' || 'ff'x || 'zwei')
say sqlCodeText(-152, 'eins' || 'ff'x || 'zwei'||'ff'x||'drei')
say sqlCodeText(-152, 'eins' || 'ff'x || 'zwei'||'ff'x||'drei',
||'ff'x||'vier')
end
else do
call errHelp 'bad argument sqlCode' sqlCode
end
exit
sqlCodeText: procedure expose m.
parse arg co, mc, warn, rel, expEq
if rel = '' then
rel = 'V9'
expEq = expEq = 1
st = sqlCodeT'.'rel
if symbol('m.st') <> 'VAR' then do
call sqlCodeFromSource st, 'sqlCodes', rel
if m.st = 0 then
say 'warning no sql Message for release' rel
end
cc = co+0
if symbol('m.st.co') = 'VAR' then
li = m.st.co
else
li = "<<text for sqlCode" co "not found>>"
cx = 1
px = 1
res = ''
do forever
nx = pos('${', li, cx)
if nx < 1 then
leave
ex = pos('}', li, nx)
if ex < cx then
call err 'closing } missing in' li
if ^ expEq then
res = res || substr(li, cx, nx - cx)
else
res = res || substr(li, cx, ex - cx) || '='
cx = ex+(^expEq)
if px > length(mc) then do
res = res || '<missingErrMC>'
end
else do
qx = pos('FF'x, mc, px)
if qx < 1 then
qx = length(mc)+1
res = res || substr(mc, px, qx-px)
px = qx + 1
end
end
res = res || substr(li, cx)
do while px <= length(mc)
qx = pos('FF'x, mc, px)
if qx < 1 then
qx = length(mc)+1
res = res '${extraErrMc =' substr(mc, px, qx-px)'}'
px = qx + 1
end
ww = sqlCodeWarn(warn)
if ww \= '' then
res = res '\nwarnings' ww
return strip(res)
endProcedure sqlCodeText
/*--- return the text for the passed warnings
in format 0:12345,6789A ---------------------------*/
sqlCodeWarn: procedure expose m.
parse arg warn
if warn = '' | abbrev(warn, 'SQLWARN.') then
return ''
wAll = substr(warn, 3, 5)substr(warn, 9, 5)
if substr(warn, 2, 1) ^== ':' | substr(warn, 8, 1) ^== ',' ,
| length(warn) > 13 ,
| ((left(warn, 1) = '') <> (wAll = '')) then
return 'bad warn' warn
if wAll = '' then
return ''
r = ''
text =' 1=W var truncated, 1=S scrollable, 1=N nonScrollable,' ,
'2=W nulls in aggregate,' ,
'3=W more cols than vars,' ,
'3=Z more result sets than locators,' ,
'4=W no where, 4=D sensitive dynamic, 4=I insensitive,' ,
'4=S sensitive static,' ,
'5=W not valid sql, 5=1 readOnly, 5=2 readDelete,' ,
'5=3 readDeleteUpdate,' ,
'6=W day changed to month range,' ,
'7=W dec digits truncated,' ,
'8=W char substituted,' ,
'9=W arith excep in count, 9=Z multipe result sets,' ,
'10=W char conversion err in ca,'
do wx = 1 to 10
w = substr(wAll, wx, 1)
if w = ' ' then
iterate
t = wx'='w
cx = pos(' 'wx'='w' ', text)
ex = pos(',' , text, cx + 1)
if cx < 1 then
r = r wx'='w '?,'
else
r = r substr(text, cx+1, ex-cx)
end
return strip(r, 't', ',')
endProcedure sqlCodeWarn
sqlCodeMerge: procedure expose m.
parse arg inSu, outSu
do wx=1 to words(inSu)
su = word(inSu, wx)
call sqlCodeFromPds mCut(su, 0), su
say 'read' su m.su.0
end
call mCut all, 0
do wx=1 to words(inSu) /* each list */
su = word(inSu, wx) /* each msg in one list */
do sx=1 to m.su.0
suffs = ''
k = word(m.su.sx, 1) + 0
do qx=1 to words(inSu) /* each list */
qu = word(inSu, qx)
qy = m.qu.key.k
if symbol('m.qu.key.k') == 'VAR' ,
& m.su.sx = m.qu.qy then
suffs = suffs qu
end /* each list */
suffs = strip(suffs)
if wordPos(su, suffs) < 1 then
call err 'self missing wx' wx 'su' su 'sx' sx 'k' k
else if wordPos(su, suffs) > 1 then
iterate
if symbol('all.suffs') ^== 'VAR' then do
all.suffs = 1
call mAdd all, suffs
call mCut 'ALL.'suffs, 0
end
call mAdd 'ALL.'suffs, m.su.sx
end /* each msg in one list */
end /* each list */
call mCut o, 0
do lx=1 to m.all.0
li = m.all.lx
say 'list' li m.all.li.0
call sqlCodeConvertFormat all'.'li, o, 'sqlCodes' li
end
call writeDsn m.pref'VV)', m.o., , 1
return
endProcedure sqlCodeMerge
sqlCodeFromSource: procedure expose m.
parse arg o, mark, rel
sta = '/*<<<' mark
sto = '>>>>>' mark
sx = 0
ox = 0
do forever
do sx=sx+1 to sourceline() while ^abbrev(sourceline(sx), sta)
end
if sx > sourceline() then
leave
if wordPos(rel, sourceline(sx)) < 1 then
iterate
do sx=sx+1 to sourceline() while ^abbrev(sourceline(sx), sto)
if abbrev(sourceline(sx), ' ') then do
m.o.cd = m.o.cd || substr(sourceline(sx), 3, 70)
end
else do
if ox > 0 then
m.o.cd = strip(m.o.cd)
cd = word(sourceline(sx), 1) + 0
if symbol('m.o.cd') == 'VAR' then
call err 'duplicate sqlCodeFromSource' rel,
'line' sx sourceline(sx)
ox = ox+ 1
m.o.cd = substr(sourceline(sx), 1, 72)
end
end
end
m.o = ox
if ox > 0 then
m.o.cd = strip(m.o.cd)
return
endProcedure sqlCodeFromSource
sqlCodeFromPDS: procedure expose m.
parse arg o, suf
ox = m.o.0
sta = '/*<<<'
sto = '>>>>>'
call readDsn m.pref || suf || ')', i.
do sx=1 to i.0
if abbrev(i.sx, sta) then
iterate
if abbrev(i.sx, sto) then
iterate
if abbrev(i.sx, ' ') then do
m.o.ox = m.o.ox || substr(i.sx, 3, 70)
end
else do
ox = ox+ 1
m.o.ox = substr(i.sx, 1, 72)
k = word(m.o.ox, 1) + 0
m.o.key.k = ox
end
end
m.o.0 = ox
return
endProcedure sqlCodeFromPds
sqlCodeConvertV9: procedure expose m.
call readDsn m.pref'S9)', m.i.
call sqlCodeConvertV9Lines i, mCut(ll, 0)
call sqlCodeConvertSplitLines ll, mCut(mm, 0)
call sqlCodeConvertParameter mm
call sqlCodeConvertFormat mm, mCut(o, 0), 'sqlCodes V9'
call writeDsn m.pref'V9)', m.o., , 1
return
endProcedure sqlCodeConvertV9
sqlCodeConvertV8: procedure expose m.
call readDsn m.pref'S8)', m.i.
call sqlCodeConvertV8Lines i, mCut(ll, 0)
call sqlCodeConvertSplitLines ll, mCut(mm, 0)
call sqlCodeConvertParameter mm
call sqlCodeConvertFormat mm, mCut(o, 0), 'sqlCodes V8'
call writeDsn m.pref'V8)', m.o., , 1
return
endProcedure sqlCodeConvertV8
/*--- input sqlCode textes from db2 reference summary:
copy pasted from pdf and transfered to vb member
output lines without header footer etc. ------------------------*/
sqlCodeConvertV9lines: procedure expose m.
parse arg i, o
do ix=1 to m.i.0
li = strip(m.i.ix)
if right(li, 16) = 'SQL return codes' then
li = left(li, length(li) - 16)
if abbrev(li, 'Warning SQL codes') ,
| li = '¨' | li = '' ,
| subword(li, 2) == 'Reference Summary' ,
| abbrev(li, 'Chapter 4. SQL return codes') ,
| li = 'SQL return codes' then
iterate
if pos('opyrigh', li) > 0 then
call err 'remove copyright in line' ix,
'pos' pos('opyrigh', li),
substr(li, pos('opyrigh', li), 30)
call mAdd o, strip(li)
end
return
endProcedure sqlCodeConvertV9lines
/*--- input sqlCode textes from db2 reference summary:
copy pasted from pdf and transfered to vb member
output lines without header footer etc. ------------------------*/
sqlCodeConvertV8lines: procedure expose m.
parse arg i, o
do ix=1 to m.i.0
li = strip(m.i.ix)
if words(li) = 1 then do
w = strip(li)
if wordpos(w, 'Copyright IBM CORP Corp. Chapter SQL' ,
'1982, return codes Reference Summary') > 0 then
iterate
if datatype(w, n) then
iterate
end
if right(li, 4) = ' SQL' then
li = strip(left(li, length(li) - 4))
if pos('opyrigh', li) > 0 then
call err 'remove copyright in line' ix,
'pos' pos('opyrigh', li),
substr(li, pos('opyrigh', li), 30)
call mAdd o, strip(li)
end
return
endProcedure sqlCodeConvertV8lines
/*--- split the lines into single sql messages -----------------------*/
sqlCodeConvertSplitLines: procedure expose m.
parse arg i, o
do ix=1 to m.i.0
li = m.i.ix
catIt = ^ datatype(word(li, 1), n)
cx = 1
do while cx <= length(li)
e0 = cx+1
do forever
e1 = pos(' -', li, e0)
e2 = pos(' +', li, e0)
if e1 < 1 then do
if e2 < 1 then do
ex = length(li) +1
leave
end
ex = e2
end
else if e2 < 1 then
ex = e1
else
ex = min(e1, e2)
if datatype(word(substr(li, ex), 1), n) then
leave
e0 = ex+1
end
if catIt then do
ox = m.o.0
m.o.ox = m.o.ox substr(li, cx, ex-cx)
catIt = 0
end
else do
msg = substr(li, cx, ex-cx)
k = word(msg, 1)
if symbol('k.k') = 'VAR' then do
kkxx = k.k
if m.o.kkxx <> k & m.o.kkxx <> msg then
call err 'duplicate msg' msg
say 'duplicate msg' m.o.kkxx
say ' new msg' msg
m.kkxx = msg
end
else do
call mAdd o, substr(li, cx, ex-cx)
k.k = m.o.0
end
end
cx = ex+1
end
end
return
endProcedure sqlCodeConvertSplitLines
/*--- add parameter markers ${ and } ---------------------------------*/
sqlCodeConvertParameter: procedure expose m.
parse arg o
do ox=1 to m.o.0
li = strip(m.o.ox)
cx = 1
res = ''
do forever
nx = verify(li, m.mAlfLc, 'm', cx)
do while nx > 0
if nx < 1 then
leave
else if substr(li, nx, 9) = 'he XML NA' then
nx = verify(li, m.mAlfLc, 'm', nx+5)
else if substr(li, nx,25) ,
= 'he decimal number is used' then
nx = 0
else
leave
end
if nx < 1 then
leave
qx = verify(li, m.mAlfNum'-#.', 'n', nx)
if qx < 1 then
qx = length(li) + 1
res = res || substr(li, cx, nx-cx) ,
|| '${' || substr(li, nx, qx-nx) || '}'
if right(res, 2) == '.}' then
res = left(res, length(res) - 2)'}.'
cx = qx
end
m.o.ox = res || substr(li, cx)
end
return
endProcedure sqlCodeConvertParameter
/*--- split the sql messages into 72 byte lines ----------------------*/
sqlCodeConvertFormat: procedure expose m.
parse arg i, o, mark
call mAdd o, left('/*<<<' mark' ', 72, '<')
do ix=1 to m.i.0
li = strip(m.i.ix)
pr = ''
cx = 1
do forever
l = 72 - length(pr)
if cx + l > length(li) then
leave
call mAdd o, pr || substr(li, cx, l)
cx = cx + l
pr = ' '
end
call mAdd o, pr || substr(li, cx)
end
call mAdd o, left('>>>>>' mark' ', 70, '>')'*/'
return
endProcedure sqlCodeConvertFormat
m.x.xx = m.x.xx li
say 'cat' (ix-1) 'and' ix left(tt m.i.ix, 50)
end
fx = posM(li, 1, ' 000 ', ' +', ' -') + 1
if fx < 2 then
iterate
end
do xx=1 to m.xx.0
return
call adrEdit 'macro (mArgs)'
call adrEdit "(zl) = lineNum .zl"
say 'zl' zl
call mAdd mCut(o, 0), '****************'
s = 0
bef = ''
do lx = 1 to zl
call adrEdit "(li) = line" lx
li = strip(li ,'t')
if li = 'return' & (lx-1)=laLx & right(bef, 4) = ' SQL' then
bef = left(bef, length(bef)-4)
if abbrev(li, '-') | abbrev(li, '+') then do
fx = 1
end
else do
fx = posM(li, 1, ' 000 ', ' +', ' -') + 1
if fx < 2 then
iterate
end
if bef ^== '' then do
if fx > 2 then
call mAdd o, bef left(li, fx-2)
else
call mAdd o, bef
bef = ''
end
laLx = lx
do forever
tx = posM(li, fx + 3, ' 000 ', ' +', ' -')
do while tx > fx & ^ datatype(substr(li, tx+1, 3), 'n')
tx = posM(li, tx + 1, ' 000 ', ' +', ' -')
end
if tx < 1 then
leave
call mAdd o, substr(li, fx, tx+1-fx)
fx = tx + 1
end
bef = substr(li, fx)
end
if bef ^== '' then
call mAdd o, bef
do ox=1 to m.o.0
li = m.o.ox
cx = 1
res = ''
do forever
nx = verify(li, m.mAlfLc, 'm', cx)
do while nx > 0
say 'nx' nx length(li)
if nx < 1 then
leave
else if substr(li, nx, 9) = 'he XML NA' then
nx = verify(li, m.mAlfLc, 'm', nx+5)
else if substr(li, nx,25) ,
= 'he decimal number is used' then
nx = 0
else
leave
end
if nx < 1 then
leave
qx = verify(li, m.mAlfNum'-', 'n', nx)
if qx < 1 then
qx = length(li) + 1
res = res || substr(li, cx, nx-cx) ,
|| '${' || substr(li, nx, qx-nx) || '}'
cx = qx
end
m.o.ox = res || substr(li, cx)
end
do ox=1 to m.o.0
li = m.o.ox
ec = adrEdit("line_after .zl = (li)", '*')
if ec <> 0 then
say 'line_after rc' ec 'le' length(li) li
end
exit
posM: procedure expose m.
parse arg src, fx
res = 0
do ax=3 to arg()
p = pos(arg(ax), src, fx)
if p ^= 0 & (res = 0 | p < res) then
res = p
end
return res
endProcedure mPos
/* copy m begin ********************************************************
stem handling
***********************************************************************/
/*--- increase m.a and return it (fail if undefined) -----------------*/
mInc: procedure expose m.
parse arg a
m.a = m.a + 1
return m.a
endProcedure mInc
/*--- cut stem a to length len ---------------------------------------*/
mCut: procedure expose m.
parse arg a, len
m.a.0 = len
return a
endProcedure mCut
/*--- add one or several arguments to stem m.a -----------------------*/
mAdd: procedure expose m.
parse arg a
ix = m.a.0
do ax = 2 to arg()
ix = ix + 1
m.a.ix = arg(ax)
end
m.a.0 = ix
return a'.'ix
endProcedure mAdd
/*--- add to m.dst.* a (sub)sequence of m.src.* ----------------------*/
mAddSt: procedure expose m.
parse arg dst, src
dx = m.dst.0
do sx = 1 to m.src.0
dx = dx + 1
m.dst.dx = m.src.sx
end
m.dst.0 = dx
return
endProcedure mAddAt
/*--- strip all elements of a stem -----------------------------------*/
mStrip: procedure expose m.
parse arg st, opt
if opt == '' then
opt = 'b'
do x=1 to m.st.0
m.st.x = strip(m.st.x, opt)
end
return st
endProcedure mStrip
/*--- cat all elements of a stem together ----------------------------*/
mCat: procedure expose m.
parse arg st, mid
if m.st.0 < 1 then
return ''
res = m.st.1
do x=2 to m.st.0
res = res || mid || m.st.x
end
return res
endProcedure mCat
mIni: procedure expose m.
if m.m.ini = 1 then
return
m.m.ini = 1
m.mAlfLC = 'abcdefghijklmnopqrstuvwxyz'
m.mAlfUC = translate(m.mAlfLC)
m.mAlfa = m.mAlfLC || m.mAlfUC
m.mAlfNum = m.mAlfa || '0123456789'
m.mAlfDot = m.mAlfNum || '.'
return
endProcedure mIni
/* copy m 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', "'")
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
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 -------------------------------------------*/
dsnAlloc: procedure expose m.
parse upper arg spec, disp, dd
ds = ''
m.dsnAlloc.dsn = ds
if left(spec, 1) = '-' then
return strip(substr(spec, 2))
if left(spec, 1) = '&' then /* external spec is handled ok */
spec = strip(substr(spec, 2))
rest = ''
do wx=1 by 1
w = word(spec, wx)
if w = '' then
leave
if abbrev(w, '.') then do
rest = substr(subword(spec, wx), 2)
leave
end
if abbrev(w, ':') then do
nn = substr(subword(spec, wx), 2)
leave
end
if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
disp = w
else if w = 'CATALOG' then
disp = disp w
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
ds = strip(substr(w, 5, length(w)-5))
else if ds = '' then
ds = dsn2jcl(w)
else
leave
end
if dd <> '' & ds = '' & rest = '' & ^ abbrev(disp, 'SYSO') then
return dd
if dd = '' then do
if symbol('m.adrTso.ddNum') = 'VAR' then
dd = m.adrTso.ddNum + 1
else
dd = 1
m.adrTso.ddNum = dd
dd = 'DD' || dd
end
if disp = '' then
disp = 'SHR'
else if pos('(', ds) < 1 then
nop
else if disp = 'MOD' then
call err 'disp mod for' ds
else
disp = 'SHR'
m.dsnAlloc.dsn = ds
if ds <> '' then
ds = "DSN('"ds"')"
alRc = adrTso('alloc dd('dd')' disp ds rest, '*')
if alRc ^== 0 then do
if nn = 'NN' | wordPos(disp, 'OLD SHR') < 1 ,
| sysDsn("'"m.dsnAlloc.dsn"'") ^== 'DATASET NOT FOUND' then
call err 'tsoAlloc rc' alRc 'for alloc dd('dd')' disp ds rest
say 'tsoAlloc rc' alRc 'for alloc dd('dd')' disp ds rest ,
'...trying to create'
call dsnAllocCreate m.dsnAlloc.dsn, nn
call adrTso 'alloc dd('dd')' disp ds rest
end
return dd 'call adrTso "free dd('dd')";'
endProcedure dsnAlloc
dsnAllocCreate: procedure expose m.
parse arg dsn, atts
if abbrev(atts, ':') then do
rl = substr(atts, 3)
if abbrev(atts, ':F') then do
if rl = '' then
rl = 80
atts = 'recfm(f b) lrecl('rl')' ,
'block(' (32760 - 32760 // rl)')'
end
else do
if rl = '' then
rl = 32756
atts = 'recfm('substr(atts, 2, 1) 'b) lrecl('rl')' ,
'block(32760)'
end
if pos('(', dsn) > 0 then
atts = atts 'dsntype(library) dsorg(po)' ,
"dsn('"dsnSetMbr(dsn)"')"
else
atts = atts "dsn('"dsn"')"
atts = 'new catalog' atts 'mgmtclas(s005y000) space(10, 1000)'
end
call adrTso 'alloc dd(dsnAlloc)' atts
call adrTso 'free dd(dsnAlloc)'
return
endProcedure dsnAllocCreate
/*--- read the dataset specified in ggDsnSpec to stem ggSt -----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
interpret subword(ggAlloc, 2)
return
endSubroutine readDsn
/*--- write the dataset specified in ggDsnSpec from stem ggSt
write ggCnt records if not empty otherwise ggst0
if ggSay 1 then say ... records written to ... -------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt '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
***********************************************************************/
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
parse arg oo, ha
m.err.opt = translate(oo, 'h', 'H')
if ha == '' then
drop m.err.handler
else
m.err.handler = ha
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggStem, ggOpt
drop err handler opt
if ggOpt == '' & symbol('m.err.handler') == 'VAR' then do
interpret m.err.handler
return 12
end
say 'fatal error:' ggTxt
if ggOpt == '' | ggOpt == '*' then
ggOpt = translate(value('m.err.opt'), 'ht', 'HT')
if ggStem ^== '' then do
do ggXX=1 to m.ggStem.0
say ' ' m.ggStem.ggXX
end
if ggXX > 3 then
say 'fatal error in' ggS3':' ggTxt
end
parse source . . ggS3 . /* current rexx */
if ggOpt == 'h' then do
say 'fatal error in' ggS3': divide by zero to show stackHistory'
x = 1 / 0
end
say 'fatal error in' ggS3': exit(12)'
exit setRc(12)
endSubroutine err
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg, st, op
say 'fatal error:' msg
call help
call err msg, st, op
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
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
/*<<< sqlCodes V8 V9 <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
000 SUCCESSFUL EXECUTION
+012 THE UNQUALIFIED COLUMN NAME ${column-name} WAS INTERPRETED AS A COR
RELATED REFERENCE
+098 A DYNAMIC SQL STATEMENT ENDS WITH A SEMICOLON.
+100 ROW NOT FOUND FOR FETCH, UPDATE OR DELETE, OR THE RESULT OF A QUERY
IS AN EMPTY TABLE
+110 SQL UPDATE TO A DATA CAPTURE TABLE NOT SIGNALED TO ORIGINATING SUBS
YSTEM
+111 THE SUBPAGES OPTION IS NOT SUPPORTED FOR TYPE 2 INDEXES
+117 THE NUMBER OF INSERT VALUES IS NOT THE SAME AS THE NUMBER OF OBJECT
COLUMNS
+162 TABLESPACE ${database-name.tablespace-name} HAS BEEN PLACED IN CHEC
K PENDING
+203 THE QUALIFIED COLUMN NAME ${column-name} WAS RESOLVED USING A NON-U
NIQUE OR UNEXPOSED NAME
+204 ${name} IS AN UNDEFINED NAME
+218 THE SQL STATEMENT REFERENCING A REMOTE OBJECT CANNOT BE EXPLAINED
+219 THE REQUIRED EXPLANATION TABLE ${table-name} DOES NOT EXIST
+220 THE COLUMN ${column-name} IN EXPLANATION TABLE ${table-name} IS NOT
DEFINED PROPERLY
+222 HOLE DETECTED USING CURSOR ${cursor-name}
+223 UPDATE HOLE DETECTED USING ${cursor-name}
+236 SQLDA INCLUDES ${integer1} SQLVAR ENTRIES, BUT ${integer2} ARE REQU
IRED FOR ${integer3} COLUMNS
+238 SQLDA INCLUDES ${integer1} SQLVAR ENTRIES, BUT ${integer2} SQLVAR E
NTRIES ARE NEEDED FOR ${integer3} COLUMNS BECAUSE AT LEAST ONE OF THE
COLUMNS BEING DESCRIBED IS A LOB
+239 SQLDA INCLUDES ${integer1} SQLVAR ENTRIES, BUT ${integer2} ARE REQU
IRED FOR ${integer3} COLUMNS BECAUSE AT LEAST ONE OF THE COLUMNS BEING
DESCRIBED IS A DISTINCT TYPE
+304 A VALUE WITH DATA TYPE ${data-type1} CANNOT BE ASSIGNED TO A HOST V
ARIABLE BECAUSE THE VALUE IS NOT WITHIN THE RANGE OF THE HOST VARIABLE
IN POSITION ${position-number} WITH DATA TYPE ${data-type2}
+335 DB2 CONVERTED A HOST VARIABLE, PARAMETER, OR COLUMN NUMBER ${var-nu
m} ${var-name-or-num} TO COLUMN NAME, HOST VARIABLE, OR EXPRESSION NUM
BER ${col-name-or-num} FROM ${from} ${ccsid} TO ${to-ccsid}, AND RESUL
TING IN SUBSTITUTION CHARACTERS.
+339 THE SQL STATEMENT HAS BEEN SUCCESSFULLY EXECUTED, BUT THERE MAY BE
SOME CHARACTER CONVERSION INCONSISTENCIES
+347 THE RECURSIVE COMMON TABLE EXPRESSION ${name} MAY CONTAIN AN INFINI
TE LOOP
+402 LOCATION ${location} IS UNKNOWN
+403 THE LOCAL OBJECT REFERENCED BY THE CREATE ALIAS STATEMENT DOES NOT
EXIST
+445 VALUE ${value} HAS BEEN TRUNCATED
+462 EXTERNAL FUNCTION OR PROCEDURE ${name} (SPECIFIC NAME ${specific-na
me}) HAS RETURNED A WARNING SQLSTATE, WITH DIAGNOSTIC TEXT ${text}
+464 PROCEDURE ${proc} RETURNED ${num} QUERY RESULT SETS, WHICH EXCEEDS
THE DEFINED LIMIT ${integer}
+466 PROCEDURE ${proc} RETURNED ${num} QUERY RESULTS SETS
+494 NUMBER OF RESULT SETS IS GREATER THAN NUMBER OF LOCATORS
+495 ESTIMATED PROCESSOR COST OF ${estimate-amount1} PROCESSOR SECONDS (
${estimate-amount2} SERVICE UNITS) IN COST CATEGORY ${cost-category} E
XCEEDS A RESOURCE LIMIT WARNING THRESHOLD OF ${limit-} ${amount} SERVI
CE UNITS
+535 THE RESULT OF THE POSITIONED UPDATE OR DELETE MAY DEPEND ON THE ORD
ER OF THE ROWS
+541 THE REFERENTIAL OR UNIQUE CONSTRAINT ${name} HAS BEEN IGNORED BECAU
SE IT IS A DUPLICATE
+551 ${auth-id} DOES NOT HAVE THE PRIVILEGE TO PERFORM OPERATION ${opera
tion} ON OBJECT ${object-name}
+552 ${auth-id} DOES NOT HAVE THE PRIVILEGE TO PERFORM OPERATION ${opera
tion}
+558 THE WITH GRANT OPTION IS IGNORED
+561 THE ALTER, INDEX, REFERENCES, AND TRIGGER PRIVILEGES CANNOT BE GRAN
TED PUBLIC AT ALL LOCATIONS
+562 A GRANT OF A PRIVILEGE WAS IGNORED BECAUSE THE GRANTEE ALREADY HAS
THE PRIVILEGE FROM THE GRANTOR
+599 COMPARISON FUNCTIONS ARE NOT CREATED FOR A DISTINCT TYPE BASED ON A
LONG STRING DATA TYPE
+610 A CREATE/ALTER ON OBJECT ${object-name} HAS PLACED OBJECT IN ${util
ity} PENDING
+650 THE TABLE BEING CREATED OR ALTERED CANNOT BECOME A DEPENDENT TABLE
+653 TABLE ${table-name} IN PARTITIONED TABLESPACE ${tspace-name} IS NOT
AVAILABLE BECAUSE ITS PARTITIONED INDEX HAS NOT BEEN CREATED
+655 STOGROUP ${stogroup}_${name} HAS BOTH SPECIFIC AND NON-SPECIFIC VOL
UME IDS. IT WILL NOT BE ALLOWED IN FUTURE RELEASES
+658 THE SUBPAGES VALUE IS IGNORED FOR THE CATALOG INDEX ${index-name}
+738 DEFINITION CHANGE OF ${object} ${object}_${name} MAY REQUIRE SIMILA
R CHANGE ON READ-ONLY SYSTEMS
+799 A SET STATEMENT REFERENCES A SPECIAL REGISTER THAT DOES NOT EXIST A
T THE SERVER SITE
+802 EXCEPTION ERROR ${exception-type} HAS OCCURRED DURING ${operation-t
ype} OPERATION ON ${data-type} DATA, POSITION ${position-number}
+806 BIND ISOLATION LEVEL RR CONFLICTS WITH TABLESPACE LOCKSIZE PAGE OR
LOCKSIZE ROW AND LOCKMAX 0
+807 THE RESULT OF DECIMAL MULTIPLICATION MAY CAUSE OVERFLOW
+863 THE CONNECTION WAS SUCCESSFUL BUT ONLY SBCS WILL BE SUPPORTED
+883 ROLLBACK TO SAVEPOINT OCCURED WHEN THERE WERE OPERATIONS THAT CANNO
T BE UNDONE, OR AN OPERATION THAT CANNOT BE UNDONE OCCURRED WHEN THERE
WAS A SAVEPOINT OUTSTANDING
+2000 TYPE 1 INDEXES WITH SUBPAGES GREATER THAN 1 CANNOT BECOME GROUP BU
FFER POOL DEPENDENT IN A DATA SHARING ENVIRONMENT
+20122 DEFINE NO OPTION IS NOT APPLICABLE IN THE CONTEXT SPECIFIED
-007 STATEMENT CONTAINS THE ILLEGAL CHARACTER ${character}
-010 THE STRING CONSTANT BEGINNING ${string} IS NOT TERMINATED
-016 ${token} REQUIRED
-029 INTO CLAUSE REQUIRED
-060 INVALID ${type} SPECIFICATION : ${spec}
-084 UNACCEPTABLE SQL STATEMENT
-097 THE USE OF LONG VARCHAR OR LONG VARGRAPHIC IS NOT ALLOWED IN THIS C
ONTEXT
-104 ILLEGAL SYMBOL ?${token}?. SOME SYMBOLS THAT MIGHT BE LEGAL ARE: ${
token-list}
-105 INVALID STRING
-107 THE NAME ${name} IS TOO LONG. MAXIMUM ALLOWABLE SIZE IS ${size}
-108 THE NAME ${name} IS QUALIFIED INCORRECTLY
-109 ${clause} CLAUSE IS NOT PERMITTED
-111 A COLUMN FUNCTION DOES NOT INCLUDE A COLUMN NAME
-114 THE LOCATION NAME ${location} DOES NOT MATCH THE CURRENT SERVER
-115 A PREDICATE IS INVALID BECAUSE THE COMPARISON OPERATOR ${operator}
IS FOLLOWED BY A PARENTHESIZED LIST OR BY ANY OR ALL WITHOUT A SUBQUER
Y
-117 THE NUMBER OF VALUES ASSIGNED IS NOT THE SAME AS THE NUMBER OF SPEC
IFIED OR IMPLIED COLUMNS
-118 THE OBJECT TABLE OR VIEW OF THE DELETE OR UPDATE STATEMENT IS ALSO
IDENTIFIED IN A FROM CLAUSE
-123 THE PARAMETER IN POSITION ${n} IN THE FUNCTION ${name} MUST BE A CO
NSTANT OR KEYWORD
-125 AN INTEGER IN THE ORDER BY CLAUSE DOES NOT IDENTIFY A COLUMN OF THE
RESULT
-126 THE SELECT STATEMENT CONTAINS BOTH AN UPDATE CLAUSE AND AN ORDER BY
CLAUSE
-128 INVALID USE OF NULL IN A PREDICATE
-129 THE STATEMENT CONTAINS TOO MANY TABLE NAMES
-130 THE ESCAPE CLAUSE CONSISTS OF MORE THAN ONE CHARACTER, OR THE STRIN
G PATTERN CONTAINS AN INVALID OCCURRENCE OF THE ESCAPE CHARACTER
-131 STATEMENT WITH LIKE PREDICATE HAS INCOMPATIBLE DATA TYPES
-132 AN OPERAND OF ${value} IS NOT VALID
-133 AN AGGREGATE FUNCTION IN A SUBQUERY OF A HAVING CLAUSE IS INVALID B
ECAUSE ALL COLUMN REFERENCES IN ITS ARGUMENT ARE NOT CORRELATED TO THE
GROUP BY RESULT THAT THE HAVING CLAUSE IS APPLIED TO
-137 THE LENGTH RESULTING FROM ${operation} IS GREATER THAN ${maximum-le
ngth}
-142 THE SQL STATEMENT IS NOT SUPPORTED
-144 INVALID SECTION NUMBER ${number}
-152 THE DROP ${clause} CLAUSE IN THE ALTER STATEMENT IS INVALID BECAUSE
${constraint-name} IS A ${constraint-type}
-153 THE STATEMENT IS INVALID BECAUSE THE VIEW OR TABLE DEFINITION DOES
NOT INCLUDE A UNIQUE NAME FOR EACH COLUMN
-154 THE STATEMENT FAILED BECAUSE VIEW OR TABLE DEFINITION IS NOT VALID
-156 THE STATEMENT DOES NOT IDENTIFY A TABLE
-157 ONLY A TABLE NAME CAN BE SPECIFIED IN A FOREIGN KEY CLAUSE. ${objec
t-name} IS NOT THE NAME OF A TABLE.
-158 THE NUMBER OF COLUMNS SPECIFIED FOR THE VIEW OR TABLE IS NOT THE SA
ME AS THE NUMBER OF COLUMNS SPECIFIED BY THE FULLSELECT, OR THE NUMBER
OF COLUMNS SPECIFIED IN THE CORRELATION CLAUSE IN A FROM CLAUSE IS NO
T THE SAME AS THE NUMBER OF COLUMNS IN THE CORRESPONDING TABLE, VIEW,
TABLE EXPRESSION, OR TABLE FUNCTION
-161 THE INSERT OR UPDATE IS NOT ALLOWED BECAUSE A RESULTING ROW DOES NO
T SATISFY THE VIEW DEFINITION
-164 ${auth-id1} DOES NOT HAVE THE PRIVILEGE TO CREATE A VIEW WITH QUALI
FICATION ${authorization-ID}
-170 THE NUMBER OF ARGUMENTS SPECIFIED FOR ${function-name} IS INVALID
-171 THE DATA TYPE, LENGTH, OR VALUE OF ARGUMENT ${nn} OF ${function-nam
e} IS INVALID
-173 UR IS SPECIFIED ON THE WITH CLAUSE BUT THE CURSOR IS NOT READ-ONLY
-180 THE DATE, TIME, OR TIMESTAMP VALUE ${value} IS INVALID
-181 THE STRING REPRESENTATION OF A DATETIME VALUE IS NOT A VALID DATETI
ME VALUE
-182 AN ARITHMETIC EXPRESSION WITH A DATETIME VALUE IS INVALID
-183 AN ARITHMETIC OPERATION ON A DATE OR TIMESTAMP HAS A RESULT THAT IS
NOT WITHIN THE VALID RANGE OF DATES
-184 AN ARITHMETIC EXPRESSION WITH A DATETIME VALUE CONTAINS A PARAMETER
MARKER
-185 THE LOCAL FORMAT OPTION HAS BEEN USED WITH A DATE OR TIME AND NO LO
CAL EXIT HAS BEEN INSTALLED
-186 THE LOCAL DATE LENGTH OR LOCAL TIME LENGTH HAS BEEN INCREASED AND E
XECUTING PROGRAM RELIES ON THE OLD LENGTH
-188 THE STRING REPRESENTATION OF A NAME IS INVALID
-191 A STRING CANNOT BE USED BECAUSE IT IS INVALID MIXED DATA
-198 THE OPERAND OF THE PREPARE OR EXECUTE IMMEDIATE STATEMENT IS BLANK
OR EMPTY
-199 ILLEGAL USE OF KEYWORD ${keyword}. TOKEN ${token-list} WAS EXPECTED
-203 A REFERENCE TO COLUMN ${column-name} IS AMBIGUOUS
-204 ${name} IS AN UNDEFINED NAME
-205 ${column-name} IS NOT A COLUMN OF TABLE ${table-name}
-208 THE ORDER BY CLAUSE IS INVALID BECAUSE COLUMN ${name} IS NOT PART O
F THE RESULT TABLE
-212 ${name} IS SPECIFIED MORE THAN ONCE IN THE REFERENCING CLAUSE OF A
TRIGGER DEFINITION
-214 AN EXPRESSION IN THE FOLLOWING POSITION, OR STARTING WITH ${positio
n-or-expression-start} IN THE ${clause-type} CLAUSE IS NOT VALID. REAS
ON CODE = ${reason-code}
-216 THE NUMBER OF ELEMENTS ON EACH SIDE OF A PREDICATE OPERATOR DOES NO
T MATCH. PREDICATE OPERATOR IS ${operator}.
-219 THE REQUIRED EXPLANATION TABLE ${table-name} DOES NOT EXIST
-220 THE COLUMN ${column-name} IN EXPLANATION TABLE ${table-name} IS NOT
DEFINED PROPERLY
-221 SET OF OPTIONAL COLUMNS IN EXPLANATION TABLE ${table-name} IS INC
OMPLETE. OPTIONAL COLUMN ${column-name} IS MISSING
-223 AN UPDATE OR DELETE OPERATION WAS ATTEMPTED AGAINST AN UPDATE HOLE
USING ${cursor-name}
-224 THE RESULT TABLE DOES NOT AGREE WITH THE BASE TABLE USING ${cursor-
name}
-227 FETCH ${fetch-orientation} IS NOT ALLOWED, BECAUSE CURSOR ${cursor-
name} HAS AN UNKNOWN POSITION (${sqlcode},${sqlstate})
-228 FOR UPDATE CLAUSE SPECIFIED FOR READ-ONLY CURSOR ${cursor-name}
-243 SENSITIVE CURSOR ${cursor-name} CANNOT BE DEFINED FOR THE SPECIFIED
SELECT STATEMENT
-244 SENSITIVITY ${sensitivity} SPECIFIED ON THE FETCH IS NOT VALID FOR
CURSOR ${cursor-name}
-246 STATEMENT USING CURSOR ${cursor-name} SPECIFIED NUMBER OF ROWS ${nu
m-rows} WHICH IS NOT VALID WITH ${dimension}
-247 A HOLE WAS DETECTED ON A MULTIPLE ROW FETCH STATEMENT USING CURSOR
${cursor-name}, BUT INDICATOR VARIABLES WERE NOT PROVIDED TO DETECT TH
E CONDITION
-248 A POSITIONED DELETE OR UPDATE STATEMENT FOR CURSOR ${cursor-name} S
PECIFIED ROW ${n} OF A ROWSET, BUT THE ROW IS NOT CONTAINED WITHIN THE
CURRENT ROWSET
-249 DEFINITION OF ROWSET ACCESS FOR CURSOR ${cursor-name} IS INCONSISTE
NT WITH THE FETCH ORIENTATION CLAUSE ${clause} SPECIFIED
-250 THE LOCAL LOCATION NAME IS NOT DEFINED WHEN PROCESSING A THREE-PART
OBJECT NAME
-251 TOKEN ${name} IS NOT VALID
-270 FUNCTION NOT SUPPORTED
-300 THE STRING CONTAINED IN HOST VARIABLE OR PARAMETER ${position-numbe
r} IS NOT NUL-TERMINATED
-301 THE VALUE OF INPUT HOST VARIABLE OR PARAMETER NUMBER ${position-num
ber} CANNOT BE USED AS SPECIFIED BECAUSE OF ITS DATA TYPE
-302 THE VALUE OF INPUT VARIABLE OR PARAMETER NUMBER ${position-number}
IS INVALID OR TOO LARGE FOR THE TARGET COLUMN OR THE TARGET VALUE
-303 A VALUE CANNOT BE ASSIGNED TO OUTPUT HOST VARIABLE NUMBER ${positio
n-number} BECAUSE THE DATA TYPES ARE NOT COMPARABLE
-304 A VALUE WITH DATA TYPE ${data-type1} CANNOT BE ASSIGNED TO A HOST V
ARIABLE BECAUSE THE VALUE IS NOT WITHIN THE RANGE OF THE HOST VARIABLE
IN POSITION ${position-number} WITH DATA TYPE ${data-type2}
-305 THE NULL VALUE CANNOT BE ASSIGNED TO OUTPUT HOST VARIABLE NUMBER ${
position-number} BECAUSE NO INDICATOR VARIABLE IS SPECIFIED
-309 A PREDICATE IS INVALID BECAUSE A REFERENCED HOST VARIABLE HAS THE N
ULL VALUE
-310 DECIMAL HOST VARIABLE OR PARAMETER ${number} CONTAINS NON-DECIMAL D
ATA
-311 THE LENGTH OF INPUT HOST VARIABLE NUMBER ${position-number} IS NEGA
TIVE OR GREATER THAN THE MAXIMUM
-313 THE NUMBER OF HOST VARIABLES SPECIFIED IS NOT EQUAL TO THE NUMBER O
F PARAMETER MARKERS
-314 THE STATEMENT CONTAINS AN AMBIGUOUS HOST VARIABLE REFERENCE
-327 THE ROW CANNOT BE INSERTED BECAUSE IT IS OUTSIDE THE BOUND OF THE P
ARTITION RANGE FOR THE LAST PARTITION
-332 CHARACTER CONVERSION BETWEEN CCSID ${from-ccsid} TO ${to-ccsid} REQ
UESTED BY ${reason-code} IS NOT SUPPORTED
-338 AN ON CLAUSE IS INVALID
-339 THE SQL STATEMENT CANNOT BE EXECUTED FROM AN ASCII BASED DRDA APPLI
CATION REQUESTOR TO A V2R2 DB2 SUBSYSTEM
-340 THE COMMON TABLE EXPRESSION ${name} HAS THE SAME IDENTIFIER AS ANOT
HER OCCURRENCE OF A COMMON TABLE EXPRESSION DEFINITION WITHIN THE SAME
STATEMENT
-341 A CYCLIC REFERENCE EXISTS BETWEEN THE COMMON TABLE EXPRESSIONS ${na
me1} AND ${name2}
-343 THE COLUMN NAMES ARE REQUIRED FOR THE RECURSIVE COMMON TABLE EXPRES
SION ${name}
-346 AN INVALID REFERENCE TO COMMON TABLE EXPRESSION ${name} OCCURS IN T
HE FIRST FULLSELECT, AS A SECOND OCCURRENCE IN THE SAME FROM CLAUSE, O
R IN THE FROM CLAUSE OF A SUBQUERY
-351 AN UNSUPPORTED SQLTYPE WAS ENCOUNTERED IN POSITION ${position-numbe
r} OF THE SELECT-LIST
-352 AN UNSUPPORTED SQLTYPE WAS ENCOUNTERED IN POSITION ${position-numbe
r} OF THE INPUT-LIST
-355 A LOB COLUMN IS TOO LARGE TO BE LOGGED
-359 THE RANGE OF VALUES FOR THE IDENTITY COLUMN OR SEQUENCE IS EXHAUSTE
D
-392 SQLDA PROVIDED FOR CURSOR ${cursor} HAS BEEN CHANGED FROM THE PREVI
OUS FETCH
-393 THE CONDITION OR CONNECTION NUMBER IS INVALID
-396 ${object-type} ${object-name} ATTEMPTED TO EXECUTE AN SQL STATEMENT
DURING FINAL CALL PROCESSING
-398 A LOCATOR WAS REQUESTED FOR HOST VARIABLE NUMBER ${position-number}
BUT THE VARIABLE IS NOT A LOB
-400 THE CATALOG HAS THE MAXIMUM NUMBER OF USER DEFINED INDEXES
-401 THE OPERANDS OF AN ARITHMETIC OR COMPARISON OPERATION ARE NOT COMPA
RABLE
-402 AN ARITHMETIC FUNCTION OR OPERATOR ${arith-fop} IS APPLIED TO CHARA
CTER OR DATETIME DATA
-404 THE SQL STATEMENT SPECIFIES A STRING THAT IS TOO LONG
-406 A CALCULATED OR DERIVED NUMERIC VALUE IS NOT WITHIN THE RANGE OF IT
S OBJECT COLUMN
-407 AN UPDATE, INSERT, OR SET VALUE IS NULL, BUT THE OBJECT COLUMN ${co
lumn-name} CANNOT CONTAIN NULL VALUES
-409 INVALID OPERAND OF A COUNT FUNCTION
-411 CURRENT SQLID CANNOT BE USED IN A STATEMENT THAT REFERENCES REMOTE
OBJECTS
-412 THE SELECT CLAUSE OF A SUBQUERY SPECIFIES MULTIPLE COLUMNS
-413 OVERFLOW OCCURRED DURING NUMERIC DATA TYPE CONVERSION
-414 A LIKE PREDICATE IS INVALID BECAUSE THE FIRST OPERAND IS NOT A STRI
NG
-417 A STATEMENT STRING TO BE PREPARED INCLUDES PARAMETER MARKERS AS THE
OPERANDS OF THE SAME OPERATOR
-418 A STATEMENT STRING TO BE PREPARED CONTAINS AN INVALID USE OF PARAME
TER MARKERS
-419 THE DECIMAL DIVIDE OPERATION IS INVALID BECAUSE THE RESULT WOULD HA
VE A NEGATIVE SCALE
-420 THE VALUE OF A STRING ARGUMENT WAS NOT ACCEPTABLE TO THE ${function
-name} FUNCTION
-423 INVALID VALUE FOR LOCATOR IN POSITION ${position-#}
-426 DYNAMIC COMMIT NOT VALID AT AN APPLICATION SERVER WHERE UPDATES ARE
NOT ALLOWED
-427 DYNAMIC ROLLBACK NOT VALID AT AN APPLICATION SERVER WHERE UPDATES A
RE NOT ALLOWED
-430 ${routine-type} ${routine-name} (SPECIFIC NAME ${specific-name}) HA
S ABNORMALLY TERMINATED
-433 VALUE ${value} IS TOO LONG
-438 APPLICATION RAISED ERROR WITH DIAGNOSTIC TEXT: ${text}
-444 USER PROGRAM ${name} COULD NOT BE FOUND
-449 CREATE OR ALTER STATEMENT FOR FUNCTION OR PROCEDURE ${routine-name}
CONTAINS AN INVALID FORMAT OF THE EXTERNAL NAME CLAUSE OR IS MISSING
THE EXTERNAL NAME CLAUSE
-450 USER-DEFINED FUNCTION OR STORED PROCEDURE ${name}, PARAMETER NUMBER
${parmnum}, OVERLAYED STORAGE BEYOND ITS DECLARED LENGTH.
-453 THERE IS A PROBLEM WITH THE RETURNS CLAUSE IN THE CREATE FUNCTION S
TATEMENT FOR ${function-name}
-454 THE SIGNATURE PROVIDED IN THE CREATE FUNCTION STATEMENT FOR ${funct
ion-name} MATCHES THE SIGNATURE OF SOME OTHER FUNCTION ALREADY EXISTIN
G IN THE SCHEMA
-455 IN CREATE FUNCTION FOR ${function-name}, THE SCHEMA NAME ${schema-n
ame1} PROVIDED FOR THE SPECIFIC NAME DOES NOT MATCH THE SCHEMA NAME ${
schema-name2} OF THE FUNCTION
-456 IN CREATE FUNCTION FOR ${function-name}, THE SPECIFIC NAME ${specif
ic-name} ALREADY EXISTS IN THE SCHEMA
-457 A FUNCTION OR DISTINCT TYPE CANNOT BE CALLED ${name} SINCE IT IS RE
SERVED FOR SYSTEM USE
-458 IN A REFERENCE TO FUNCTION ${function-name} BY SIGNATURE, A MATCHIN
G FUNCTION COULD NOT BE FOUND
-461 A VALUE WITH DATA TYPE ${source-data-type} CANNOT BE CAST TO TYPE $
{target-data-type}
-469 SQL CALL STATEMENT MUST SPECIFY AN OUTPUT HOST VARIABLE FOR PARAMET
ER ${number}
-470 SQL CALL STATEMENT SPECIFIED A NULL VALUE FOR INPUT PARAMETER ${num
ber}, BUT THE STORED PROCEDURE DOES NOT SUPPORT NULL VALUES.
-471 INVOCATION OF FUNCTION OR PROCEDURE ${name} FAILED DUE TO REASON ${
rc}
-472 CURSOR ${cursor-name} WAS LEFT OPEN BY EXTERNAL FUNCTION ${function
-name} (SPECIFIC NAME ${specific-name})
-473 A USER DEFINED DATA TYPE CANNOT BE CALLED THE SAME NAME AS A SYSTEM
PREDEFINED TYPE (BUILT-IN TYPE)
-475 THE RESULT TYPE ${type-1} OF THE SOURCE FUNCTION CANNOT BE CAST TO
THE RETURNS TYPE ${type-2} OF THE USER-DEFINED FUNCTION ${function-nam
e}
-476 REFERENCE TO FUNCTION ${function-name} WAS NAMED WITHOUT A SIGNATUR
E, BUT THE FUNCTION IS NOT UNIQUE WITHIN ITS SCHEMA
-478 DROP OR REVOKE ON OBJECT TYPE ${type1} CANNOT BE PROCESSED BECAUSE
OBJECT ${name} OF TYPE ${type2} IS DEPENDENT ON IT
-480 THE PROCEDURE ${procedure-name} HAS NOT YET BEEN CALLED
-482 THE PROCEDURE ${procedure-name} RETURNED NO LOCATORS
-483 IN CREATE FUNCTION FOR ${function-name} STATEMENT, THE NUMBER OF PA
RAMETERS DOES NOT MATCH THE NUMBER OF PARAMETERS OF THE SOURCE FUNCTIO
N
-487 ${object-type} ${object-name} ATTEMPTED TO EXECUTE AN SQL STATEMENT
WHEN THE DEFINITION OF THE FUNCTION OR PROCEDURE DID NOT SPECIFY THIS
ACTION
-490 NUMBER ${number} DIRECTLY SPECIFIED IN AN SQL STATEMENT IS OUTSIDE
THE RANGE OF ALLOWABLE VALUES IN THIS CONTEXT (${minval}, ${maxval})
-491 CREATE STATEMENT FOR USER-DEFINED FUNCTION ${function-name} MUST HA
VE A RETURNS CLAUSE AND: THE EXTERNAL CLAUSE WITH OTHER REQUIRED KEYWO
RDS; THE RETURN STATEMENT AND PARAMETER NAMES; OR THE SOURCE CLAUSE
-492 THE CREATE FUNCTION FOR ${function-name} HAS A PROBLEM WITH PARAMET
ER NUMBER ${number}. IT MAY INVOLVE A MISMATCH WITH A SOURCE FUNCTION
-495 ESTIMATED PROCESSOR COST OF ${estimate-amount1} PROCESSOR SECONDS (
${estimate-amount2} SERVICE UNITS) IN COST CATEGORY ${cost-category} E
XCEEDS A RESOURCE LIMIT ERROR THRESHOLD OF ${limit-} ${amount} SERVICE
UNITS
-496 THE SQL STATEMENT CANNOT BE EXECUTED BECAUSE IT REFERENCES A RESULT
SET THAT WAS NOT CREATED BY THE CURRENT SERVER
-497 THE MAXIMUM LIMIT OF INTERNAL IDENTIFIERS HAS BEEN EXCEEDED FOR DAT
ABASE ${database-name}
-499 CURSOR ${cursor-name} HAS ALREADY BEEN ASSIGNED TO THIS OR ANOTHER
RESULT SET FROM PROCEDURE ${procedure-name}.
-500 THE IDENTIFIED CURSOR WAS CLOSED WHEN THE CONNECTION WAS DESTROYED
-501 THE CURSOR IDENTIFIED IN A FETCH OR CLOSE STATEMENT IS NOT OPEN
-502 THE CURSOR IDENTIFIED IN AN OPEN STATEMENT IS ALREADY OPEN
-503 A COLUMN CANNOT BE UPDATED BECAUSE IT IS NOT IDENTIFIED IN THE UPDA
TE CLAUSE OF THE SELECT STATEMENT OF THE CURSOR
-507 THE CURSOR IDENTIFIED IN THE UPDATE OR DELETE STATEMENT IS NOT OPEN
-508 THE CURSOR IDENTIFIED IN THE UPDATE OR DELETE STATEMENT IS NOT POSI
TIONED ON A ROW OR ROWSET THAT CAN BE UPDATED OR DELETED
-509 THE TABLE IDENTIFIED IN THE UPDATE OR DELETE STATEMENT IS NOT THE S
AME TABLE DESIGNATED BY THE CURSOR
-510 THE TABLE DESIGNATED BY THE CURSOR OF THE UPDATE OR DELETE STATEMEN
T CANNOT BE MODIFIED
-512 STATEMENT REFERENCE TO REMOTE OBJECT IS INVALID
-513 THE ALIAS ${alias-name} MUST NOT BE DEFINED ON ANOTHER LOCAL OR REM
OTE ALIAS
-514 THE CURSOR ${cursor-name} IS NOT IN A PREPARED STATE
-517 CURSOR ${cursor-name} CANNOT BE USED BECAUSE ITS STATEMENT NAME DOE
S NOT IDENTIFY A PREPARED SELECT STATEMENT
-518 THE EXECUTE STATEMENT DOES NOT IDENTIFY A VALID PREPARED STATEMENT
-519 THE PREPARE STATEMENT IDENTIFIES THE SELECT STATEMENT OF THE OPENED
CURSOR ${cursor-name}
-530 THE INSERT OR UPDATE VALUE OF FOREIGN KEY ${constraint-name} IS INV
ALID
-531 PARENT KEY IN A PARENT ROW CANNOT BE UPDATED BECAUSE IT HAS ONE OR
MORE DEPENDENT ROWS IN RELATIONSHIP ${constraint-name}
-533 INVALID MULTIPLE-ROW INSERT
-534 THE PRIMARY KEY CANNOT BE UPDATED BECAUSE OF MULTIPLE-ROW UPDATE
-536 THE DELETE STATEMENT IS INVALID BECAUSE TABLE ${table-name} CAN BE
AFFECTED BY THE OPERATION
-537 THE PRIMARY KEY, FOREIGN KEY, UNIQUE, OR PARTITIONING KEY CLAUSE ID
ENTIFIES COLUMN ${column-name} MORE THAN ONCE
-538 FOREIGN KEY ${name} DOES NOT CONFORM TO THE DESCRIPTION OF A PARENT
KEY OF TABLE ${table-name}
-539 TABLE ${table-name} DOES NOT HAVE A PRIMARY KEY
-540 THE DEFINITION OF TABLE ${table-name} IS INCOMPLETE BECAUSE IT LACK
S A PRIMARY INDEX OR A REQUIRED UNIQUE INDEX
-542 ${column-name} CANNOT BE A COLUMN OF A PRIMARY KEY, A UNIQUE CONSTR
AINT, OR A PARENT KEY BECAUSE IT CAN CONTAIN NULL VALUES
-543 A ROW IN A PARENT TABLE CANNOT BE DELETED BECAUSE THE CHECK CONSTRA
INT ${check-constraint} RESTRICTS THE DELETION
-544 THE CHECK CONSTRAINT SPECIFIED IN THE ALTER TABLE STATEMENT CANNOT
BE ADDED BECAUSE AN EXISTING ROW VIOLATES THE CHECK CONSTRAINT
-545 THE REQUESTED OPERATION IS NOT ALLOWED BECAUSE A ROW DOES NOT SATIS
FY THE CHECK CONSTRAINT ${check-constraint}
-546 THE CHECK CONSTRAINT ${constraint-name} IS INVALID
-548 A CHECK CONSTRAINT THAT IS DEFINED WITH ${column-name} IS INVALID
-549 THE ${statement} STATEMENT IS NOT ALLOWED FOR ${object}_${type1} ${
object}_${name} BECAUSE THE BIND OPTION DYNAMICRULES(RUN) IS NOT IN EF
FECT FOR ${object}_${type2}
-551 ${auth-id} DOES NOT HAVE THE PRIVILEGE TO PERFORM OPERATION ${opera
tion} ON OBJECT ${object-name}
-552 ${auth-id} DOES NOT HAVE THE PRIVILEGE TO PERFORM OPERATION ${opera
tion}
-556 ${authid2} CANNOT HAVE THE ${privilege} PRIVILEGE ${on}_${object} R
EVOKED BY ${authid1} BECAUSE THE REVOKEE DOES NOT POSSESS THE PRIVILEG
E OR THE REVOKER DID NOT MAKE THE GRANT
-557 INCONSISTENT GRANT/REVOKE KEYWORD ${keyword}. PERMITTED KEYWORDS AR
E ${keyword-list}
-558 INVALID CLAUSE OR COMBINATION OF CLAUSES ON A GRANT OR REVOKE
-559 ALL AUTHORIZATION FUNCTIONS HAVE BEEN DISABLED
-567 ${bind-type} AUTHORIZATION ERROR USING ${auth-id} AUTHORITY PACKAGE
= ${package-name} PRIVILEGE = ${privilege}
-571 THE STATEMENT WOULD RESULT IN A MULTIPLE SITE UPDATE
-573 TABLE ${table-name} DOES NOT HAVE A UNIQUE KEY WITH THE SPECIFIED C
OLUMN NAMES
-574 THE SPECIFIED DEFAULT VALUE OR IDENTITY ATTRIBUTE VALUE CONFLICTS W
ITH THE DEFINITION OF COLUMN ${column-name}
-577 ${object-type} ${object-name} ATTEMPTED TO MODIFY DATA WHEN THE DEF
INITION OF THE FUNCTION OR PROCEDURE DID NOT SPECIFY THIS ACTION
-579 ${object-type} ${object-name} ATTEMPTED TO READ DATA WHEN THE DEFIN
ITION OF THE FUNCTION OR PROCEDURE DID NOT SPECIFY THIS ACTION
-580 THE RESULT-EXPRESSIONS OF A CASE EXPRESSION CANNOT ALL BE NULL
-581 THE DATA TYPES OF THE RESULT-EXPRESSIONS OF A CASE EXPRESSION ARE N
OT COMPATIBLE
-582 THE SEARCH-CONDITION IN A SEARCHED-WHEN-CLAUSE CANNOT BE A QUANTIFI
ED PREDICATE, IN PREDICATE, OR AN EXISTS PREDICATE.
-587 A LIST OF ${item-references} ARE NOT IN THE SAME FAMILY
-589 A POSITIONED DELETE OR UPDATE STATEMENT FOR CURSOR ${cursor-name} S
PECIFIED A ROW OF A ROWSET, BUT THE CURSOR IS NOT POSITIONED ON A ROWS
ET
-592 NOT AUTHORIZED TO CREATE FUNCTIONS OR PROCEDURES IN WLM ENVIRONMENT
${env-name}
-594 ATTEMPT TO CREATE A NULLABLE ROWID OR DISTINCT TYPE COLUMN ${column
-name}
-603 A UNIQUE INDEX CANNOT BE CREATED BECAUSE THE TABLE CONTAINS ROWS WH
ICH ARE DUPLICATES WITH RESPECT TO THE VALUES OF THE IDENTIFIED COLUMN
S
-604 A DATA TYPE DEFINITION SPECIFIES AN INVALID LENGTH, PRECISION, OR S
CALE ATTRIBUTE
-607 OPERATION OR OPTION ${operation} IS NOT DEFINED FOR THIS OBJECT
-611 ONLY LOCKMAX 0 CAN BE SPECIFIED WHEN THE LOCK SIZE OF THE TABLESPAC
E IS TABLESPACE OR TABLE
-613 THE PRIMARY KEY OR A UNIQUE CONSTRAINT IS TOO LONG OR HAS TOO MANY
COLUMNS
-614 THE INDEX CANNOT BE CREATED OR ALTERED, OR THE LENGTH OF A COLUMN C
ANNOT BE CHANGED BECAUSE THE SUM OF THE INTERNAL LENGTHS OF THE COLUMN
S FOR THE INDEX IS GREATER THAN THE ALLOWABLE MAXIMUM
-615 ${operation-type} IS NOT ALLOWED ON A PACKAGE IN USE
-616 ${obj-type1} ${obj-name1} CANNOT BE DROPPED BECAUSE IT IS REFERENCE
D BY ${obj-type2} ${obj-name2}
-617 A TYPE 1 INDEX IS NOT VALID FOR TABLE ${table-name}
-618 OPERATION ${operation} IS NOT ALLOWED ON SYSTEM DATABASES
-619 OPERATION DISALLOWED BECAUSE THE DATABASE IS NOT STOPPED
-621 DUPLICATE DBID ${dbid} WAS DETECTED AND PREVIOUSLY ASSIGNED TO ${da
tabase-name}
-622 FOR MIXED DATA IS INVALID BECAUSE THE MIXED DATA INSTALL OPTION IS
NO
-623 A CLUSTERING INDEX ALREADY EXISTS ON TABLE ${table-name}
-625 TABLE ${table-name} DOES NOT HAVE AN INDEX TO ENFORCE THE UNIQUENES
S OF THE PRIMARY OR UNIQUE KEY
-626 THE ALTER STATEMENT IS NOT EXECUTABLE BECAUSE THE PAGE SET IS NOT S
TOPPED
-628 THE CLAUSES ARE MUTUALLY EXCLUSIVE
-629 SET NULL CANNOT BE SPECIFIED BECAUSE FOREIGN KEY ${name} CANNOT CON
TAIN NULL VALUES
-630 THE WHERE NOT NULL SPECIFICATION IS INVALID FOR TYPE 1 INDEXES
-631 FOREIGN KEY ${name} IS TOO LONG OR HAS TOO MANY COLUMNS
-632 THE TABLE CANNOT BE DEFINED AS A DEPENDENT OF ${table-name} BECAUSE
OF DELETE RULE RESTRICTIONS
-633 THE DELETE RULE MUST BE ${delete-rule}
-634 THE DELETE RULE MUST NOT BE CASCADE
-635 THE DELETE RULES CANNOT BE DIFFERENT OR CANNOT BE SET NULL
-638 TABLE ${table-name} CANNOT BE CREATED BECAUSE COLUMN DEFINITION IS
MISSING
-639 A NULLABLE COLUMN OF A FOREIGN KEY WITH A DELETE RULE OF SET NULL C
ANNOT BE A COLUMN OF THE KEY OF A PARTITIONED INDEX
-640 LOCKSIZE ROW CANNOT BE SPECIFIED BECAUSE TABLE IN THIS TABLESPACE H
AS TYPE 1 INDEX
-646 TABLE ${table-name} CANNOT BE CREATED IN SPECIFIED TABLE SPACE ${ta
ble-space-name} BECAUSE IT ALREADY CONTAINS A TABLE
-650 THE ALTER STATEMENT CANNOT BE EXECUTED, REASON ${reason}
-651 TABLE DESCRIPTION EXCEEDS MAXIMUM SIZE OF OBJECT DESCRIPTOR.
-652 VIOLATION OF INSTALLATION DEFINED EDIT OR VALIDATION PROCEDURE ${pr
oc-name}
-653 TABLE ${table-name} IN PARTITIONED TABLE SPACE ${tspace-name} IS NO
T AVAILABLE BECAUSE ITS PARTITIONED INDEX HAS NOT BEEN CREATED
-655 THE CREATE OR ALTER STOGROUP IS INVALID BECAUSE THE STORAGE GROUP W
OULD HAVE BOTH SPECIFIC AND NON-SPECIFIC VOLUME IDS
-658 A ${object-type} CANNOT BE DROPPED USING THE ${statement} STATEMENT
-660 INDEX ${index-name} CANNOT BE CREATED OR ALTERED ON PARTITIONED TAB
LE SPACE ${tspace-name} BECAUSE KEY LIMITS ARE NOT SPECIFIED
-663 THE NUMBER OF KEY LIMIT VALUES IS EITHER ZERO, OR GREATER THAN THE
NUMBER OF COLUMNS IN THE KEY OF INDEX ${index-name}
-666 ${stmt-verb} ${object} CANNOT BE EXECUTED BECAUSE ${function} IS IN
PROGRESS
-667 THE CLUSTERING INDEX FOR A PARTITIONED TABLE SPACE CANNOT BE EXPLIC
ITLY DROPPED
-668 THE COLUMN CANNOT BE ADDED TO THE TABLE BECAUSE THE TABLE HAS AN ED
IT PROCEDURE
-669 THE OBJECT CANNOT BE EXPLICITLY DROPPED. REASON ${reason-code}
-670 THE RECORD LENGTH OF THE TABLE EXCEEDS THE PAGE SIZE LIMIT
-671 THE BUFFERPOOL ATTRIBUTE OF THE TABLE SPACE CANNOT BE ALTERED AS SP
ECIFIED BECAUSE IT WOULD CHANGE THE PAGE SIZE OF THE TABLE SPACE
-672 OPERATION DROP NOT ALLOWED ON TABLE ${table}_${name}
-677 INSUFFICIENT VIRTUAL STORAGE FOR BUFFERPOOL EXPANSION
-679 THE OBJECT ${name} CANNOT BE CREATED BECAUSE A DROP IS PENDING ON T
HE OBJECT
-680 TOO MANY COLUMNS SPECIFIED FOR A TABLE, VIEW OR TABLE FUNCTION
-681 COLUMN ${column-name} IN VIOLATION OF INSTALLATION DEFINED FIELD PR
OCEDURE. RT: ${return-code}, RS: ${reason-code}, MSG: ${message-token}
-682 FIELD PROCEDURE ${procedure-name} COULD NOT BE LOADED
-683 THE SPECIFICATION FOR COLUMN, DISTINCT TYPE, FUNCTION, OR PROCEDURE
${data-item} CONTAINS INCOMPATIBLE CLAUSES
-685 INVALID FIELD TYPE, ${column-name}
-686 COLUMN DEFINED WITH A FIELD PROCEDURE CAN NOT COMPARE WITH ANOTHER
COLUMN WITH DIFFERENT FIELD PROCEDURE
-687 FIELD TYPES INCOMPARABLE
-688 INCORRECT DATA RETURNED FROM FIELD PROCEDURE, ${column-name}, ${msg
no}
-689 TOO MANY COLUMNS DEFINED FOR A DEPENDENT TABLE
-690 THE STATEMENT IS REJECTED BY DATA DEFINITION CONTROL SUPPORT. REASO
N ${reason-code}
-691 THE REQUIRED REGISTRATION TABLE ${table-name} DOES NOT EXIST
-692 THE REQUIRED UNIQUE INDEX ${index-name} FOR DDL REGISTRATION TABLE
${table-name} DOES NOT EXIST
-696 THE DEFINITION OF TRIGGER ${trigger-name} INCLUDES AN INVALID USE O
F CORRELATION NAME OR TRANSITION TABLE NAME ${name}. REASON CODE=${rea
son-code}
-697 OLD OR NEW CORRELATION NAMES ARE NOT ALLOWED IN A TRIGGER DEFINED W
ITH THE FOR EACH STATEMENT CLAUSE. OLD_TABLE OR NEW_TABLE NAMES ARE NO
T ALLOWED IN A TRIGGER WITH THE BEFORE CLAUSE.
-715 PROGRAM ${program-name} WITH MARK ${release-dependency-mark} FAILED
BECAUSE IT DEPENDS ON FUNCTIONS OF THE RELEASE FROM WHICH FALLBACK HA
S OCCURRED
-716 PROGRAM ${program-name} PRECOMPILED WITH INCORRECT LEVEL FOR THIS R
ELEASE
-717 ${bind-type} FOR ${object-type} ${object-name} WITH MARK ${release-
dependency-mark} FAILED BECAUSE ${object-type} DEPENDS ON FUNCTIONS OF
THE RELEASE FROM WHICH FALLBACK HAS OCCURRED
-718 REBIND OF PACKAGE ${package-name} FAILED BECAUSE IBMREQD OF ${ibmre
qd} IS INVALID
-719 BIND ADD ERROR USING ${auth-id} AUTHORITY PACKAGE ${package-name} A
LREADY EXISTS
-720 BIND ERROR, ATTEMPTING TO REPLACE PACKAGE = ${package}_${name} WITH
VERSION = ${version2} BUT THIS VERSION ALREADY EXISTS
-721 BIND ERROR FOR PACKAGE = ${pkg-id} CONTOKEN = ${contoken} X IS NOT
UNIQUE SO IT CANNOT BE CREATED
-722 ${bind-type} ERROR USING ${auth-id} AUTHORITY PACKAGE ${package-nam
e} DOES NOT EXIST
-723 AN ERROR OCCURRED IN A TRIGGERED SQL STATEMENT IN ${trigger-name}.
INFORMATION RETURNED: SQLCODE: ${sqlerror}, SQLSTATE: ${sqlstate}, MES
SAGE TOKENS ${token-list}, SECTION NUMBER ${section-number}
-724 THE ACTIVATION OF THE ${object-type} OBJECT ${object-name} WOULD EX
CEED THE MAXIMUM LEVEL OF INDIRECT SQL CASCADING
-725 THE SPECIAL REGISTER ${register} AT LOCATION ${location} WAS SUPPLI
ED AN INVALID VALUE
-726 BIND ERROR ATTEMPTING TO REPLACE PACKAGE = ${package-name}. THERE A
RE ENABLE OR DISABLE ENTRIES CURRENTLY ASSOCIATED WITH THE PACKAGE
-728 DATA TYPE ${data-type} IS NOT ALLOWED IN DB2 PRIVATE PROTOCOL PROCE
SSING
-729 A STORED PROCEDURE SPECIFYING COMMIT ON RETURN CANNOT BE THE TARGET
OF A NESTED CALL STATEMENT
-730 THE PARENT OF A TABLE IN A READ-ONLY SHARED DATABASE MUST ALSO BE A
TABLE IN A READ-ONLY SHARED DATABASE
-731 USER-DEFINED DATASET ${dsname} MUST BE DEFINED WITH SHAREOPTIONS(1,
3)
-732 THE DATABASE IS DEFINED ON THIS SUBSYSTEM WITH THE ROSHARE READ ATT
RIBUTE BUT THE TABLE SPACE OR INDEX SPACE HAS NOT BEEN DEFINED ON THE
OWNING SUBSYSTEM
-733 THE DESCRIPTION OF A TABLE SPACE, INDEX SPACE, OR TABLE IN A ROSHAR
E READ DATABASE MUST BE CONSISTENT WITH ITS DESCRIPTION IN THE OWNER S
YSTEM
-734 THE ROSHARE ATTRIBUTE OF A DATABASE CANNOT BE ALTERED FROM ROSHARE
READ
-735 DATABASE ${dbid} CANNOT BE ACCESSED BECAUSE IT IS NO LONGER A SHARE
D DATABASE
-736 INVALID OBID ${obid} SPECIFIED
-737 IMPLICIT TABLE SPACE NOT ALLOWED
-739 CREATE OR ALTER FUNCTION ${function-name} FAILED BECAUSE FUNCTIONS
CANNOT MODIFY DATA WHEN THEY ARE PROCESSED IN PARALLEL.
-740 FUNCTION ${name} IS DEFINED WITH THE OPTION MODIFIES SQL DATA WHICH
IS NOT VALID IN THE CONTEXT IN WHICH IT WAS INVOKED
-741 A ${database-type} DATABASE IS ALREADY DEFINED FOR MEMBER ${member-
name}
-742 DSNDB07 IS THE IMPLICIT WORK FILE DATABASE
-746 THE SQL STATEMENT IN AN EXTERNAL FUNCTION, TRIGGER, OR IN STORED PR
OCEDURE ${name} VIOLATES THE NESTING SQL RESTRICTION
-747 TABLE ${table-name} IS NOT AVAILABLE UNTIL THE AUXILIARY TABLES AND
INDEXES FOR ITS EXTERNALLY STORED COLUMNS HAVE BEEN CREATED
-751 ${object-type} ${object-name} (SPECIFIC NAME ${specific} ${name}) A
TTEMPTED TO EXECUTE AN SQL STATEMENT ${statement} THAT IS NOT ALLOWED
-752 THE CONNECT STATEMENT IS INVALID BECAUSE THE PROCESS IS NOT IN THE
CONNECTABLE STATE
-763 INVALID TABLE SPACE NAME ${table-space-name}
-764 A LOB TABLE SPACE AND ITS ASSOCIATED BASE TABLE SPACE MUST BE IN TH
E SAME DATABASE
-765 TABLE IS NOT COMPATIBLE WITH DATABASE
-766 THE OBJECT OF A STATEMENT IS AN AUXILIARY TABLE FOR WHICH THE REQUE
STED OPERATION IS NOT PERMITTED
-767 MISSING OR INVALID COLUMN SPECIFICATION FOR INDEX ${index-name}
-768 AN AUXILIARY TABLE ALREADY EXISTS FOR THE SPECIFIED COLUMN OR PARTI
TION
-769 SPECIFICATION OF CREATE AUX TABLE DOES NOT MATCH THE CHARACTERISTIC
S OF THE BASE TABLE
-771 INVALID SPECIFICATION OF A ROWID COLUMN
-772 ATTEMPTED TO CAST AN INVALID VALUE TO A ROW ID TYPE
-802 EXCEPTION ERROR ${exception-type} HAS OCCURRED DURING ${operation-t
ype} OPERATION ON ${data-type} DATA, POSITION ${position-number}
-804 AN ERROR WAS FOUND IN THE APPLICATION PROGRAM INPUT PARAMETERS FOR
THE SQL STATEMENT, REASON ${reason}
-805 DBRM OR PACKAGE NAME ${location-name.collection-id.dbrm-name.consis
tency-token} NOT FOUND IN PLAN ${plan-name}. REASON ${reason}
-807 ACCESS DENIED: PACKAGE ${package-name} IS NOT ENABLED FOR ACCESS FR
OM ${connection-type} ${connection-name}
-808 THE CONNECT STATEMENT IS NOT CONSISTENT WITH THE FIRST CONNECT STAT
EMENT
-811 THE RESULT OF AN EMBEDDED SELECT STATEMENT OR A SUBSELECT IN THE SE
T CLAUSE OF AN UPDATE STATEMENT IS A TABLE OF MORE THAN ONE ROW, OR TH
E RESULT OF A SUBQUERY OF A BASIC PREDICATE IS MORE THAN ONE VALUE
-812 THE SQL STATEMENT CANNOT BE PROCESSED BECAUSE A BLANK COLLECTION-ID
WAS FOUND IN THE CURRENT PACKAGESET SPECIAL REGISTER WHILE TRYING TO
FORM A QUALIFIED PACKAGE NAME FOR PROGRAM ${program-name.consistency-t
oken} USING PLAN ${plan-name}
-815 A GROUP BY OR HAVING CLAUSE IS IMPLICITLY OR EXPLICITLY SPECIFIED I
N A SUBSELECT OF A BASIC PREDICATE OR THE SET CLAUSE OF AN UPDATE STAT
EMENT
-817 THE SQL STATEMENT CANNOT BE EXECUTED BECAUSE THE STATEMENT WILL RES
ULT IN A PROHIBITED UPDATE OPERATION.
-818 THE PRECOMPILER-GENERATED TIMESTAMP ${x} IN THE LOAD MODULE IS DIFF
ERENT FROM THE BIND TIMESTAMP ${y} BUILT FROM THE DBRM ${z}
-819 THE VIEW CANNOT BE PROCESSED BECAUSE THE LENGTH OF ITS PARSE TREE I
N THE CATALOG IS ZERO
-820 THE SQL STATEMENT CANNOT BE PROCESSED BECAUSE ${catalog-table} CONT
AINS A VALUE THAT IS NOT VALID IN THIS RELEASE
-822 THE SQLDA CONTAINS AN INVALID DATA ADDRESS OR INDICATOR VARIABLE AD
DRESS
-840 TOO MANY ITEMS RETURNED IN A SELECT OR INSERT LIST
-842 A CONNECTION TO ${location-name} ALREADY EXISTS
-843 THE SET CONNECTION OR RELEASE STATEMENT MUST SPECIFY AN EXISTING CO
NNECTION
-846 INVALID SPECIFICATION OF AN IDENTITY COLUMN OR SEQUENCE OBJECT ${ob
ject}_${type} ${object}_${name}. REASON CODE = ${reason}_${code}
-867 INVALID SPECIFICATION OF A ROWID COLUMN
-870 THE NUMBER OF HOST VARIABLES IN THE STATEMENT IS NOT EQUAL TO THE N
UMBER OF DESCRIPTORS
-872 A VALID CCSID HAS NOT YET BEEN SPECIFIED FOR THIS SUBSYSTEM
-874 THE ENCODING SCHEME SPECIFIED FOR THE ${object-type} MUST BE THE SA
ME AS THE CONTAINING TABLE SPACE OR OTHER PARAMETERS
-875 ${operand} CANNOT BE USED WITH THE ASCII DATA REFERENCED
-877 CCSID ASCII OR CCSID UNICODE IS NOT ALLOWED FOR THIS DATABASE OR TA
BLE SPACE
-879 CREATE ${or} ALTER STATEMENT FOR ${obj-name} CANNOT DEFINE A COLUMN
, DISTINCT TYPE, FUNCTION OR STORED PROCEDURE PARAMETER AS MIXED OR GR
APHIC WITH ENCODING SCHEME ${encoding-scheme}
-880 SAVEPOINT ${savepoint-name} DOES NOT EXIST OR IS INVALID IN THIS CO
NTEXT
-881 A SAVEPOINT WITH NAME ${savepoint-name} ALREADY EXISTS, BUT THIS SA
VEPOINT NAME CANNOT BE REUSED
-882 SAVEPOINT DOES NOT EXIST
-901 UNSUCCESSFUL EXECUTION CAUSED BY A SYSTEM ERROR THAT DOES NOT PRECL
UDE THE SUCCESSFUL EXECUTION OF SUBSEQUENT SQL STATEMENTS
-902 POINTER TO THE ESSENTIAL CONTROL BLOCK (CT/RDA) HAS VALUE 0, REBIND
REQUIRED
-904 UNSUCCESSFUL EXECUTION CAUSED BY AN UNAVAILABLE RESOURCE. REASON ${
reason-code}, TYPE OF RESOURCE ${resource-type}, AND RESOURCE NAME ${r
esource-name}
-905 UNSUCCESSFUL EXECUTION DUE TO RESOURCE LIMIT BEING EXCEEDED, RESOUR
CE NAME = ${resource-name} LIMIT = ${limit-amount1} CPU SECONDS (${lim
it-amount2} SERVICE UNITS) DERIVED FROM ${limit-source}
-906 THE SQL STATEMENT CANNOT BE EXECUTED BECAUSE THIS FUNCTION IS DISAB
LED DUE TO A PRIOR ERROR
-908 ${bind-type} ERROR USING ${auth-id} AUTHORITY. BIND, REBIND OR AUTO
-REBIND OPERATION IS NOT ALLOWED
-909 THE OBJECT HAS BEEN DELETED
-911 THE CURRENT UNIT OF WORK HAS BEEN ROLLED BACK DUE TO DEADLOCK OR TI
MEOUT. REASON ${reason-code}, TYPE OF RESOURCE ${resource-type}, AND R
ESOURCE NAME ${resource-name}
-913 UNSUCCESSFUL EXECUTION CAUSED BY DEADLOCK OR TIMEOUT. REASON CODE $
{reason-code}, TYPE OF RESOURCE ${resource-type}, AND RESOURCE NAME ${
resource-name}
-917 BIND PACKAGE FAILED
-918 THE SQL STATEMENT CANNOT BE EXECUTED BECAUSE A CONNECTION HAS BEEN
LOST
-919 A ROLLBACK OPERATION IS REQUIRED
-922 AUTHORIZATION FAILURE: ${error-type} ERROR. REASON ${reason-code}
-923 CONNECTION NOT ESTABLISHED: DB2 ${condition} REASON ${reason-code},
TYPE ${resource-type}, NAME ${resource-name}
-924 DB2 CONNECTION INTERNAL ERROR, ${function-code}, ${return-code}, ${
reason-code}
-925 COMMIT NOT VALID IN IMS, CICS OR RRSAF ENVIRONMENT
-926 ROLLBACK NOT VALID IN IMS, CICS OR RRSAF ENVIRONMENT
-927 THE LANGUAGE INTERFACE (LI) WAS CALLED WHEN THE CONNECTING ENVIRONM
ENT WAS NOT ESTABLISHED. THE PROGRAM SHOULD BE INVOKED UNDER THE DSN C
OMMAND
-929 FAILURE IN A DATA CAPTURE EXIT: ${token}
-939 ROLLBACK REQUIRED DUE TO UNREQUESTED ROLLBACK OF A REMOTE SERVER
-947 THE SQL STATEMENT FAILED BECAUSE IT WILL CHANGE A TABLE DEFINED WIT
H DATA CAPTURE CHANGES, BUT THE DATA CANNOT BE PROPAGATED
-948 DISTRIBUTED OPERATION IS INVALID
-950 THE LOCATION NAME SPECIFIED IN THE CONNECT STATEMENT IS INVALID OR
NOT LISTED IN THE COMMUNICATIONS DATABASE
-952 PROCESSING WAS INTERRUPTED BY A CANCEL REQUEST FROM A CLIENT PROGRA
M
-965 STORED PROCEDURE OR FUNCTION ${name} TERMINATED ABNORMALLY
-981 THE SQL STATEMENT FAILED BECAUSE THE RRSAF CONNECTION IS NOT IN A S
TATE THAT ALLOWS SQL OPERATIONS, REASON ${reason-code}.
-991 CALL ATTACH WAS UNABLE TO ESTABLISH AN IMPLICIT CONNECT OR OPEN TO
DB2. RC1= ${rc1} RC2= ${rc2}
-1760 CREATE PROCEDURE FOR ${procedure-name} MUST HAVE VALID LANGUAGE AN
D EXTERNAL CLAUSES
-2001 THE NUMBER OF HOST VARIABLE PARAMETERS FOR A STORED PROCEDURE IS N
OT EQUAL TO THE NUMBER OF EXPECTED HOST VARIABLE PARAMETERS. ACTUAL NU
MBER ${sqldanum}, EXPECTED NUMBER ${opnum}
-4700 ATTEMPT TO USE NEW FUNCTION BEFORE NEW FUNCTION MODE
-20003 GBPCACHE NONE CANNOT BE SPECIFIED FOR TABLESPACE OR INDEX IN GREC
P
-20004 8K ${or} 16K BUFFERPOOL PAGESIZE INVALID FOR A WORKFILE OBJECT
-20005 THE INTERNAL ID LIMIT OF ${limit} HAS BEEN EXCEEDED FOR OBJECT TY
PE ${object-type}
-20008 UNSUPPORTED OPTION ${keyword} SPECIFIED
-20058 THE FULLSELECT SPECIFIED FOR MATERIALIZED QUERY TABLE ${table-nam
e} IS NOT VALID.
-20070 AUXILIARY TABLE ${table-name} CANNOT BE CREATED BECAUSE COLUMN ${
column-name} IS NOT A LOB COLUMN
-20071 WLM ENVIRONMENT NAME MUST BE SPECIFIED ${function-name}
-20073 THE FUNCTION ${function-name} CANNOT BE ALTERED BECAUSE IT IS REF
ERENCED IN EXISTING VIEW OR MATERIALIZED QUERY TABLE DEFINITIONS
-20074 THE OBJECT ${object-name} CANNOT BE CREATED BECAUSE THE FIRST THR
EE CHARACTERS ARE RESERVED FOR SYSTEM OBJECTS
-20091 A VIEW NAME WAS SPECIFIED AFTER LIKE IN ADDITION TO THE INCLUDING
IDENTITY COLUMN ATTRIBUTES CLAUSE
-20093 THE TABLE ${table-name} CANNOT BE CONVERTED TO OR FROM A MATERIAL
IZED QUERY TABLE, OR THE MATERIALIZED QUERY TABLE PROPERTY CANNOT BE A
LTERED. REASON CODE = ${reason-code}.
-20100 AN ERROR OCCURRED WHEN BINDING A TRIGGERED SQL STATEMENT. INFORMA
TION RETURNED: SECTION NUMBER : ${section-number} SQLCODE ${sqlerror},
SQLSTATE ${sqlstate}, AND MESSAGE TOKENS ${token-list}
-20101 THE FUNCTION ${function} FAILED WITH REASON ${rc}
-20102 CREATE OR ALTER STATEMENT FOR ROUTINE ${routine-name} SPECIFIED T
HE ${option} OPTION WHICH IS NOT ALLOWED FOR THE TYPE OF ROUTINE
-20104 AN ATTEMPT TO ALTER A CCSID FROM ${from-ccsid} TO ${to-ccsid} FAI
LED
-20107 HOST VARIABLE OR PARAMETER NUMBER ${position-number} CANNOT BE US
ED AS SPECIFIED BECAUSE REASON ${reason}
-20108 A RESULT SET CONTAINS AN UNSUPPORTED DATA TYPE IN POSITION NUMBER
${position-number} FOR CURSOR ${cursor-name} OPENED BY STORED PROCEDU
RE ${procedure-name}
-20110 CANNOT IMPLICITLY CONNECT TO A REMOTE SITE WITH A SAVEPOINT OUTST
ANDING
-20111 CANNOT ISSUE SAVEPOINT, RELEASE SAVEPOINT, ROLLBACK TO SAVEPOINT
FROM A TRIGGER, FROM A USER-DEFINED FUNCTION, OR FROM A GLOBAL TRANSAC
TION
-20123 CALL TO STORED PROCEDURE ${procedure} FAILED BECAUSE THE RESULT S
ET RETURNED FOR CURSOR ${cursor} IS SCROLLABLE, BUT THE CURSOR IS NOT
POSITIONED BEFORE THE FIRST ROW
-20124 OPEN CURSOR ${cursor} FAILED BECAUSE THE CURSOR IS SCROLLABLE BUT
THE CLIENT DOES NOT SUPPORT THIS
-20125 CALL TO STORED PROCEDURE ${procedure} FAILED BECAUSE THE RESULT S
ET FOR CURSOR ${cursor} IS SCROLLABLE, BUT THE CLIENT DOES NOT SUPPORT
THIS
-20126 CURSOR ${cursor} IS DEFINED AS SCROLLABLE, BUT THE ENVIRONMENT IN
VOLVES A HOP SITE
-20127 VALUE SPECIFIED ON FETCH STATEMENT FOR ABSOLUTE OR RELATIVE IS TO
O LARGE FOR DRDA
-20129 LOCAL SPECIAL REGISTER IS NOT VALID AS USED
-20142 SEQUENCE ${sequence-name} CANNOT BE USED AS SPECIFIED
-20163 HEXADECIMAL CONSTANT GX IS NOT ALLOWED
-20164 SENSITIVE CURSOR ${cursor-name} IS DEFINED FOR A SELECT STATEMENT
CONTAINING AN INSERT STATEMENT
-20174 ALTER TABLE STATEMENT FOR ${table-name} SPECIFIED A PRECISION AND
SCALE THAT IS NOT AS LARGE AS THE EXISTING PRECISION AND SCALE
-20177 SET DATA TYPE CLAUSE ON ALTER TABLE SPECIFIED FLOATING POINT, BUT
THIS CHANGE IS DISALLOWED
-20180 COLUMN ${column-name} IN TABLE ${table-name} CANNOT BE ALTERED AS
SPECIFIED
-20181 COLUMN CANNOT BE ADDED TO INDEX ${index-name}
-20185 CURSOR ${cursor-name} IS NOT DEFINED TO ACCESS ROWSETS, BUT A CLA
USE WAS SPECIFIED THAT IS VALID ONLY WITH ROWSET ACCESS
-20203 USER-DEFINED FUNCTION OR PROCEDURE ${name} HAS A JAVA METHOD WITH
AN INVALID SIGNATURE. THE ERROR IS AT OR NEAR PARAMETER ${number}. TH
E SIGNATURE IS ${signature}.
-20204 THE USER-DEFINED FUNCTION OR PROCEDURE ${routine-name} WAS UNABLE
TO MAP TO A SINGLE JAVA METHOD
-20207 THE INSTALL OR REMOVE OF ${jar-name} SPECIFIED THE USE OF A DEPLO
YMENT DESCRIPTOR.
-20227 REQUIRED CLAUSE IS MISSING FOR ARGUMENT ${number} OF ${expression
}
-20276 The XML NAMESPACE PREFIX ${xml-namespace-prefix} IS NOT VALID. RE
ASON CODE = ${reason-code}.
-30000 EXECUTION FAILED DUE TO A DISTRIBUTION PROTOCOL ERROR THAT WILL N
OT AFFECT THE SUCCESSFUL EXECUTION OF SUBSEQUENT COMMANDS OR SQL STATE
MENTS: REASON ${reason-code} (${sub-code})
-30002 THE SQL STATEMENT CANNOT BE EXECUTED DUE TO A PRIOR CONDITION IN
A CHAIN OF STATEMENTS
-30021 EXECUTION FAILED DUE TO A DISTRIBUTION PROTOCOL ERROR THAT WILL A
FFECT THE SUCCESSFUL EXECUTION OF SUBSEQUENT COMMANDS OR SQL STATEMENT
S: MANAGER ${manager} AT LEVEL ${level} NOT SUPPORTED ERROR
-30030 COMMIT REQUEST WAS UNSUCCESSFUL, A DISTRIBUTION PROTOCOL VIOLATIO
N HAS BEEN DETECTED, THE CONVERSATION HAS BEEN DEALLOCATED. ORIGINAL S
QLCODE=${original-sqlcode} AND ORIGINAL SQLSTATE=${original-sqlstate}
-30040 EXECUTION FAILED DUE TO UNAVAILABLE RESOURCES THAT WILL NOT AFFEC
T THE SUCCESSFUL EXECUTION OF SUBSEQUENT COMMANDS OR SQL STATEMENTS. R
EASON ${reason-code} TYPE OF RESOURCE ${resource-type} RESOURCE NAME $
{resource-name} PRODUCT ID ${pppvvrrm} RDBNAME ${rdbname}
-30051 BIND PROCESS WITH SPECIFIED PACKAGE NAME AND CONSISTENCY TOKEN NO
T ACTIVE
-30052 PROGRAM PREPARATION ASSUMPTIONS ARE INCORRECT
-30053 OWNER AUTHORIZATION FAILURE
-30060 RDB AUTHORIZATION FAILURE
-30061 RDB NOT FOUND
-30070 ${command} COMMAND NOT SUPPORTED ERROR
-30071 ${object-type} OBJECT NOT SUPPORTED ERROR
-30072 ${parameter} ${subcode} PARAMETER NOT SUPPORTED ERROR
-30073 ${parameter} ${subcode} PARAMETER VALUE NOT SUPPORTED ERROR
-30074 REPLY MESSAGE WITH ${codepoint} (${svrcod}) NOT SUPPORTED ERROR
-30080 COMMUNICATION ERROR ${code} (${subcode})
-30082 CONNECTION FAILED FOR SECURITY REASON ${reason-code} (${reason-st
ring})
-30090 REMOTE OPERATION INVALID FOR APPLICATION EXECUTION ENVIRONMENT
-30104 ERROR IN BIND OPTION ${option} AND BIND VALUE ${value}.
-30105 BIND OPTION ${option1} IS NOT ALLOWED WITH BIND OPTION ${option2}
-30106 INVALID INPUT DATA DETECTED FOR A MULTIPLE ROW INSERT OPERATION.
INSERT PROCESSING IS TERMINATED
>>>>> sqlCodes V8 V9 >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>*/
/*<<< sqlCodes V8 <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+206 ${column-name} IS NOT A COLUMN OF AN INSERTED TABLE, UPDATED TABLE,
OR ANY TABLE IDENTIFIED IN A FROM CLAUSE
+231 CURRENT POSITION OF CURSOR ${cursor-name} IS NOT VALID FOR FETCH OF
THE CURRENT ROW
+237 SQLDA INCLUDES ${integer1} SQLVAR ENTRIES, BUT ${integer2} ARE @ RE
QUIRED BECAUSE AT LEAST ONE OF THE COLUMNS BEING DESCRIBED IS A DISTIN
CT TYPE
+331 THE NULL VALUE HAS BEEN ASSIGNED TO A HOST VARIABLE BECAUSE THE STR
ING CANNOT BE TRANSLATED. REASON ${reason-code}, CHARACTER ${code-poin
t}, HOST VARIABLE ${position-number}
+394 USER SPECIFIED OPTIMIZATION HINTS USED DURING ACCESS PATH SELECTION
+395 USER SPECIFIED OPTIMIZATION HINTS ARE INVALID (REASON CODE = ${reas
on-code}). THE OPTIMIZATION HINTS ARE IGNORED.
+434 OPTION ${keyword} IS A DEPRECATED FEATURE
+585 THE COLLECTION ${collectoin-id} APPEARS MORE THAN ONCE IN THE SET $
{special-register}
+645 WHERE NOT NULL IS IGNORED BECAUSE THE INDEX KEY CANNOT CONTAIN NULL
VALUES
+664 THE INTERNAL LENGTH OF THE LIMIT-KEY FIELDS FOR THE PARTITIONED IND
EX ${index-name} EXCEEDS THE LENGTH IMPOSED BY DB2
+20002 THE GBPCACHE SPECIFICATION IS IGNORED, ${bpname} DOES NOT ALLOW C
ACHING
+20007 USE OF OPTIMIZATION HINTS IS DISALLOWED BY A DB2 SUBSYSTEM PARAME
TER. THE SPECIAL REGISTER OPTIMIZATION HINT IS SET TO THE DEFAULT VA
LUE OF BLANKS.
+30100 OPERATION COMPLETED SUCCESSFULLY BUT A DISTRIBUTION PROTOCOL VIOL
ATION HAS BEEN DETECTED. ORIGINAL SQLCODE=${original-sqlcode} AND ORIG
INAL SQLSTATE=${original-sqlstate}
-079 QUALIFIER FOR DECLARED GLOBAL TEMPORARY TABLE ${table-name} MUST BE
SESSION, NOT ${qualifier}
-102 LITERAL STRING IS TOO LONG. STRING BEGINS ${string}
-103 ${literal} IS AN INVALID NUMERIC LITERAL
-110 INVALID HEXADECIMAL LITERAL BEGINNING ${string}
-112 THE OPERAND OF A AGGREGATE FUNCTION INCLUDES A AGGREGATE FUNCTION O
R A SCALAR FULLSELECT
-113 INVALID CHARACTER FOUND IN ${string}, REASON CODE ${nnn}
-119 A COLUMN IDENTIFIED IN A HAVING CLAUSE IS NOT INCLUDED IN THE GROUP
BY CLAUSE
-120 AN AGGREGATE FUNCTION IS NOT VALID IN THE CONTEXT IN WHICH IT WAS I
NVOKED
-121 THE COLUMN ${name} IS IDENTIFIED MORE THAN ONCE IN THE INSERT OR UP
DATE OR SET TRANSITION VARIABLE STATEMENT
-122 A SELECT STATEMENT WITH NO GROUP BY CLAUSE CONTAINS A COLUMN NAME A
ND A${n} AGGREGATE FUNCTION IN THE SELECT CLAUSE OR A COLUMN NAME IS C
ONTAINED IN THE SELECT CLAUSE BUT NOT IN THE GROUP BY CLAUSE
-134 IMPROPER USE OF LONG STRING COLUMN ${column-name} OR AN EXPRESSION
THAT RESOLVES TO A LONG STRING
-136 SORT CANNOT BE EXECUTED BECAUSE THE SORT KEY LENGTH IS GREATER THAN
4000 BYTES
-138 THE SECOND OR THIRD ARGUMENT OF THE SUBSTR FUNCTION IS OUT OF RANGE
-147 ALTER FUNCTION ${function-name} FAILED BECAUSE SOURCE FUNCTIONS CAN
NOT BE ALTERED
-148 THE SOURCE TABLE ${source-name} CANNOT BE RENAMED OR ALTERED
-150 THE OBJECT OF THE INSERT, DELETE, OR UPDATE STATEMENT IS A VIEW, SY
STEM-MAINTAINED MATERIALIZED QUERY TABLE, OR TRANSITION TABLE FOR WHIC
H THE REQUESTED OPERATION IS NOT PERMITTED
-151 THE UPDATE STATEMENT IS INVALID BECAUSE THE CATALOG DESCRIPTION OF
COLUMN ${column-name} INDICATES THAT IT CANNOT BE UPDATED
-159 THE STATEMENT REFERENCES ${object-name} WHICH IDENTIFIES A(N) ${obj
ect-type1} RATHER THAN A(N) ${object-type2}
-160 THE WITH CHECK OPTION CANNOT BE USED FOR THE SPECIFIED VIEW
-187 A REFERENCE TO A CURRENT DATE/TIME SPECIAL REGISTER IS INVALID BECA
USE THE MVS TOD CLOCK IS BAD OR THE MVS PARMTZ IS OUT OF RANGE
-189 CCSID ${ccsid} IS UNKNOWN OR INVALID FOR THE DATA TYPE OR SUBTYPE
-190 THE ATTRIBUTES SPECIFIED FOR THE OF COLUMN ${table-name.column-name
} ARE NOT COMPATIBLE WITH THE EXISTING COLUMN
-197 QUALIFIED COLUMN NAMES IN ORDER BY CLAUSE NOT PERMITTED WHEN UNION
OR UNION ALL SPECIFIED
-206 ${column-name} IS NOT A COLUMN OF AN INSERTED TABLE, UPDATED TABLE,
OR ANY TABLE IDENTIFIED IN A FROM CLAUSE, OR IS NOT A COLUMN OF THE T
RIGGERING TABLE OF A TRIGGER
-222 AN UPDATE OR DELETE OPERATION WAS ATTEMPTED AGAINST A HOLE USING ${
cursor-name}
-225 FETCH STATEMENT FOR ${cursor-name} IS NOT VALID BECAUSE THE CURSOR
IS NOT DEFINED AS SCROLL
-229 THE LOCALE ${locale} SPECIFIED IN A SET LOCALE OR OTHER STATEMENT T
HAT IS LOCALE SENSITIVE WAS NOT FOUND
-240 THE PART CLAUSE OF A LOCK TABLE STATEMENT IS INVALID
-242 THE OBJECT NAMED ${object-name} OF TYPE ${object-type} WAS SPECIFIE
D MORE THAN ONCE IN THE LIST OF OBJECTS.
-245 THE INVOCATION OF FUNCTION ROUTINE-NAME IS AMBIGUOUS
-312 ${variable-name} IS AN UNDEFINED OR UNUSABLE HOST VARIABLE OR IS US
ED IN A DYNAMIC SQL STATEMENT OR A TRIGGER DEFINITION
-330 A STRING CANNOT BE USED BECAUSE IT CANNOT BE TRANSLATED. REASON ${r
eason-code}, CHARACTER ${code-point}, HOST VARIABLE ${position-number}
-331 A STRING CANNOT BE ASSIGNED TO A HOST VARIABLE BECAUSE IT CANNOT BE
TRANSLATED. REASON ${reason-code}, CHARACTER ${code-point}, POSITION
${position-number}
-333 THE SUBTYPE OF A STRING VARIABLE IS NOT THE SAME AS THE SUBTYPE KNO
WN AT BIND TIME AND THE DIFFERENCE CANNOT BE RESOLVED BY TRANSLATION
-336 The decimal number is used in a context where the scale must be zer
o. This can occur when a decimal number is specified in a CREATE or AL
TER SEQUENCE statement for START WITH, INCREMENT BY, MINVALUE, MAXVALU
E, or RESTART WITH.
-342 THE COMMON TABLE EXPRESSION ${name} CANNOT USE SELECT DISTINCT AND
MUST USE UNION ALL BECAUSE IT IS RECURSIVE
-344 THE RECURSIVE COMMON TABLE EXPRESSION ${name} HAS MISMATCHED DATA T
YPES OR LENGTHS FOR COLUMN ${column-name}
-345 THE FULLSELECT OF THE RECURSIVE COMMON TABLE EXPRESSION ${name} MUS
T BE THE UNION OF TWO OR MORE FULLSELECTS AND CANNOT INCLUDE COLUMN FU
NCTIONS, GROUP BY CLAUSE, HAVING CLAUSE, OR AN EXPLICIT JOIN INCLUDING
AN ON CLAUSE
-348 ${sequence-expression} FOR ${sequence-name} CANNOT BE SPECIFIED IN
THIS CONTEXT
-350 INVALID SPECIFICATION OF A LARGE OBJECT COLUMN
-372 ONLY ONE ROWID OR IDENTITY COLUMN IS ALLOWED IN A TABLE
-373 DEFAULT CANNOT BE SPECIFIED FOR IDENTITY COLUMN ${column-name}
-390 THE FUNCTION ${function-name}, SPECIFIC NAME ${specific-name}, IS N
OT VALID IN THE CONTEXT IN WHICH IT OCCURS
-397 THE OPTION GENERATED IS SPECIFIED WITH A COLUMN THAT IS NOT A ROW I
D OR DISTINCT TYPE BASED ON A ROW ID
-399 ATTEMPTED TO INSERT AN INVALID VALUE INTO A ROWID COLUMN
-405 THE NUMERIC LITERAL ${literal} CANNOT BE USED AS SPECIFIED BECAUSE
IT IS OUT OF RANGE
-408 THE VALUE IS NOT COMPATIBLE WITH THE DATA TYPE OF ITS TARGET
-410 THE FLOATING POINT LITERAL ${literal} CONTAINS MORE THAN 30 CHARACT
ERS
-415 THE CORRESPONDING COLUMNS, ${column-number}, OF THE OPERANDS OF A U
NION OR A UNION ALL DO NOT HAVE COMPARABLE COLUMN DESCRIPTIONS
-416 AN OPERAND OF A UNION CONTAINS A LONG STRING COLUMN
-421 THE OPERANDS OF A UNION OR UNION ALL DO NOT HAVE THE SAME NUMBER OF
COLUMNS
-435 AN INVALID SQLSTATE ${sqlstate} IS SPECIFIED IN THE FUNCTION RAISE_
ERROR OR IN A SIGNAL SQLSTATE STATEMENT
-440 NO ${routine-type} BY THE NAME ${routine-name} HAVING COMPATIBLE AR
GUMENTS WAS FOUND
-441 INVALID USE OF DISTINCT OR ALL WITH SCALAR FUNCTION ${function-
name}
-451 THE ${data-item} DEFINITION, IN THE CREATE FUNCTION FOR ${function-
name} CONTAINS DATA TYPE ${type} WHICH IS NOT APPROPRIATE FOR AN EXTER
NAL FUNCTION WRITTEN IN THE GIVEN LANGUAGE
-504 THE CURSOR NAME ${cursor-name} IS NOT DEFINED
-511 THE FOR UPDATE CLAUSE CANNOT BE SPECIFIED BECAUSE THE TABLE DESIGNA
TED BY THE CURSOR CANNOT BE MODIFIED
-516 THE DESCRIBE FOR STATIC STATEMENT DOES NOT IDENTIFY A PREPARED STAT
EMENT
-525 THE SQL STATEMENT CANNOT BE EXECUTED BECAUSE IT WAS IN ERROR AT BIN
D TIME FOR SECTION = ${sectno} PACKAGE = ${pkgname} CONSISTENCY TOKEN
= X'${contoken}'
-526 THE REQUESTED OPERATION OR USAGE DOES NOT APPLY TO ${table} ${type}
TEMPORARY TABLE ${table} ${name}
-532 THE RELATIONSHIP ${constraint-name} RESTRICTS THE DELETION OF ROW W
ITH RID X'${rid-number}'
-553 ${auth-id} SPECIFIED IS NOT ONE OF THE VALID AUTHORIZATION IDS
-554 AN AUTHORIZATION ID CANNOT GRANT A PRIVILEGE TO ITSELF
-555 AN AUTHORIZATION ID CANNOT REVOKE A PRIVILEGE FROM ITSELF
-583 THE USE OF FUNCTION ${function-name} IS INVALID BECAUSE IT IS NOT D
ETERMINISTIC OR HAS AN EXTERNAL ACTION
-585 THE COLLECTION ID ${collection-id} APPEARS MORE THAN ONCE IN THE SE
T ${special-register} STATEMENT
-586 THE TOTAL LENGTH OF THE CURRENT PATH SPECIAL REGISTER CANNOT EXCEED
254 CHARACTERS
-590 PARAMETER NAME ${parameter-name} IS NOT UNIQUE IN THE CREATE FOR RO
UTINE ${routine-name}
-593 NOT NULL MUST BE SPECIFIED FOR ROWID OR DISTINCT TYPE COLUMN ${colu
mn-name}
-601 THE NAME OF THE OBJECT TO BE CREATED OR THE TARGET OF A RENAME STAT
EMENT IS IDENTICAL TO THE EXISTING NAME ${name} OF THE OBJECT TYPE ${o
bj-type}
-602 TOO MANY COLUMNS SPECIFIED IN A CREATE INDEX OR ALTER INDEX STATEME
NT
-612 ${column-name} IS A DUPLICATE COLUMN NAME
-620 KEYWORD ${keyword} IN ${stmt} ${type} STATEMENT IS NOT PERMITTED FO
R A ${space} ${type} SPACE IN THE ${database} ${type} DATABASE
-624 TABLE ${table-name} ALREADY HAS A PRIMARY KEY OR UNIQUE KEY CONSTRA
INT WITH SPECIFIED COLUMNS
-627 THE ALTER STATEMENT IS INVALID BECAUSE THE PAGESET HAS USER-MANAGED
DATA SETS
-636 THE PARTITIONING KEYS FOR PARTITION ${part-num} ARE NOT SPECIFIED I
N ASCENDING OR DESCENDING ORDER
-637 DUPLICATE ${keyword} KEYWORD
-643 CHECK CONSTRAINT EXCEEDS MAXIMUM ALLOWABLE LENGTH
-644 INVALID VALUE SPECIFIED FOR KEYWORD ${keyword} IN ${stmt-type} STAT
EMENT
-647 BUFFERPOOL ${bp-name} CANNOT BE SPECIFIED BECAUSE IT HAS NOT BEEN A
CTIVATED
-661 INDEX ${index-name} CANNOT BE CREATED ON PARTITIONED TABLE SPACE ${
tspace-name} BECAUSE THE NUMBER OF PART SPECIFICATIONS IS NOT EQUAL TO
THE NUMBER OF PARTITIONS OF THE TABLE SPACE
-662 A PARTITIONED INDEX CANNOT BE CREATED ON A NON-PARTITIONED TABLE SP
ACE ${tspace-name}
-665 THE PART CLAUSE OF AN ALTER STATEMENT IS OMITTED OR INVALID
-676 ONLY A 4K PAGE BUFFERPOOL CAN BE USED FOR AN INDEX
-678 THE LITERAL ${literal} SPECIFIED FOR THE INDEX LIMIT KEY MUST CONFO
RM TO THE DATA TYPE ${data-type} OF THE CORRESPONDING COLUMN ${column-
name}
-684 THE LENGTH OF LITERAL LIST BEGINNING ${string} IS TOO LONG
-693 THE COLUMN ${column-name} IN DDL REGISTRATION TABLE OR INDEX ${tabl
e-name} (${index-name}) IS NOT DEFINED PROPERLY
-694 THE DDL STATEMENT CANNOT BE EXECUTED BECAUSE A DROP IS PENDING ON T
HE DDL REGISTRATION TABLE ${table-name}
-713 THE REPLACEMENT VALUE ${value} FOR ${special-register} IS INVALID
-748 AN INDEX ALREADY EXISTS ON AUXILIARY TABLE ${table-name}
-750 THE SOURCE TABLE ${source-name} CANNOT BE RENAMED BECAUSE IT IS REF
ERENCED IN EXISTING VIEW, MATERIALIZED QUERY TABLE, OR TRIGGER DEFINIT
IONS
-770 TABLE ${table-name} CANNOT HAVE A LOB COLUMN UNLESS IT ALSO HAS A R
OWID COLUMN
-797 ATTEMPT ${to} CREATE TRIGGER ${trigger-name} WITH AN UNSUPPORTED TR
IGGERED SQL STATEMENT
-798 YOU CANNOT INSERT A VALUE INTO A COLUMN THAT IS DEFINED WITH THE OP
TION GENERATED ALWAYS COLUMN ${column-name}
-803 AN INSERTED OR UPDATED VALUE IS INVALID BECAUSE THE INDEX IN INDEX
SPACE ${indexspace-name} CONSTRAINS COLUMNS OF THE TABLE SO NO TWO ROW
S CAN CONTAIN DUPLICATE VALUES IN THOSE COLUMNS. RID OF EXISTING ROW I
S X${rid}
-845 A PREVVAL EXPRESSION CANNOT BE USED BEFORE THE NEXTVAL EXPRESSION G
ENERATES A VALUE IN THE CURRENT SESSION FOR SEQUENCE ${sequence-name}
-873 DATA ENCODED WITH DIFFERENT ENCODING SCHEMES CANNOT BE REFERENCED I
N THE SAME SQL STATEMENT
-876 '${object}' CANNOT BE CREATED, REASON '${reason}'
-878 THE PLAN_TABLE USED FOR EXPLAIN CANNOT BE ASCII OR UNICODE
-900 THE SQL STATEMENT CANNOT BE EXECUTED BECAUSE THE APPLICATION PROCES
S IS NOT CONNECTED TO AN APPLICATION SERVER
-910 THE SQL STATEMENT CANNOT ACCESS AN OBJECT ON WHICH A DROP OR ALTER
IS PENDING
-989 AFTER TRIGGER ${trigger-name} ATTEMPTED TO MODIFY A ROW IN TABLE ${
table-name} THAT WAS INSERTED BY AN INSERT STATEMENT WITHIN A SELECT S
TATEMENT
-1403 THE USERNAME AND/OR PASSQWORD SUPPLIED IS INCORRECT
-4701 :THE COMBINATION OF THE NUMBER OF TABLE SPACE PARTITIONS AND THE C
ORRESPONDING LENGTH OF THE PARTITIONING LIMIT KEY EXCEEDS THE SYSTEM L
IMIT
-4702 TABLE HAS HAD THE MAXIMUM NUMBER OF ALTERS ALLOWED
-4703 THE ALTER TABLE STATEMENT CANNOT BE EXECUTED BECAUSE COLUMN ${name
} ${column} IS MIXED DATA, OR THE DATA TYPE OR LENGTH SPECIFIED DOES N
OT AGREE WITH THE EXISTING DATA TYPE OR LENGTH.
-5011 HOST STRUCTURE ARRAY ${host-structure-array} IS EITHER NOT DEFINED
OR IS NOT USABLE
-5012 HOST VARIABLE ${host-variable} IS NOT EXACT NUMERIC WITH SCALE ZER
O -${skel}
-20006 LOBS CANNOT BE SPECIFIED AS PARAMETERS WHEN NO WLM ENVIRONMENT IS
SPECIFIED
-20072 ${csect-name} ${bind-type} ${bind-subtype} ERROR USING ${auth-id}
AUTHORITY OPERATION IS NOT ALLOWED ON A TRIGGER PACKAGE ${package-nam
e}
-20092 A VIEW WAS SPECIFIED FOR LIKE BUT IT INCLUDES A ROWID COLUMN
-20106 THE CCSID FOR TABLE SPACE OR DATABASE CANNOT BE CHANGED BECAUSE T
HE TABLE SPACE OR DATABASE ALREADY CONTAINS A TABLE THAT IS REFERENCED
IN EXISTING VIEW DEFINITIONS
-20165 INSERT STATEMENT WITHIN A SELECT IS NOT ALLOWED IN THE CONTEXT IN
WHICH IT WAS SPECIFIED
-20166 INSERT STATEMENT WITHIN A SELECT SPECIFIED VIEW ${view-name} WHIC
H IS NOT A SYMMETRIC VIEW
-20182 ${values} PARTITIONING CLAUSE ON ${stmt-type} STATEMENT FOR ${ind
ex-name} IS NOT VALID
-20183 THE PARITIONED, ADD PART, ADD PARTITIONING KEY, OR ALTER PART CLA
USE SPECIFIED ON CREATE OR ALTER FOR ${name} IS NOT VALID
-20186 A CLAUSE WAS SPECIFIED THAT IS NOT VALID FOR THE STATEMENT BEING
PREPARED OR EXECUTED
-20200 THE INSTALL OR REPLACE OF ${jar-id} WITH URL ${url} FAILED DUE TO
REASON ${reason-code} (${reason-string}).
-20201 THE INSTALL, REPLACE OR REMOVE OF ${jar-name} FAILED DUE TO REASO
N ${reason-code} (${reason-string})
-20202 THE REPLACE OR REMOVE OF ${jar-name} FAILED AS ${class} IS IN USE
-20210 THE SQL STATEMENT CANNOT BE EXECUTED BECAUSE IT WAS AT A LEVEL TH
AT IS INCOMPATIBLE WITH THE CURRENT VALUE OF THE ENCODING BIND OPTION
OR SPECIAL REGISTER
-20212 USER-DEFINED ROUTINE ${name} ENCOUNTERED AN EXCEPTION ATTEMPTING
TO LOAD JAVA CLASS ${class-name} FROM JAR ${jar-name}. ORIGINAL EXCEPT
ION: ${exception-string}.
-20213 STORED PROCEDURE ${procedure-name} HAS RETURNED A DYNAMIC RESULT
SET OF AN INVALID CLASS. PARAMETER ${number} IS NOT A DB2 RESULT SET
-20248 ATTEMPTED TO EXPLAIN A CACHED STATEMENT WITH STMTID OR STMTTOKEN
ID-${token} BUT THE REQUIRED EXPLAIN INFORMATION IS NOT ACCESSIBLE.
-20275 The XML NAME ${xml-name} IS NOT VALID. REASON CODE = ${reason-cod
e}.
-30005 EXECUTION FAILED BECAUSE FUNCTION NOT SUPPORTED BY THE SERVER: LO
CATION ${location} PRODUCT ID ${pppvvrr} REASON CODE ${reason-code} ($
{sub-code})
-30020 EXECUTION FAILED DUE TO A DISTRIBUTION PROTOCOL ERROR THAT CAUSED
DEALLOCATION OF THE CONVERSATION: REASON <${reason-code} (${sub-code}
)>
-30025 EXECUTION FAILED BECAUSE FUNCTION IS NOT SUPPORTED BY THE SERVER
WHICH CAUSED TERMINATION OF THE CONNETION: LOCATION ${location} PRODUC
T ID ${pppvvrr} REASON CODE ${reason-code} (${sub-code})
-30041 EXECUTION FAILED DUE TO UNAVAILABLE RESOURCES THAT WILL AFFECT TH
E SUCCESSFUL EXECUTION OF SUBSEQUENT COMMANDS AND SQL STATEMENTS. REAS
ON <${reason-code}> TYPE OF RESOURCE <${resource-type}> RESOURCE NAME
<${resource-name}> PRODUCT ID <${pppvvrrm}> RDBNAME <${rdbname}>
-30050 <${command-or-SQL-statement-type} COMMAND OR SQL STATEMENT INVALI
D WHILE BIND PROCESS IN PROGRESS
-30081 ${prot} COMMUNICATION ERROR DETECTED. API=${api}, LOCATION=${loc}
, FUNCTION=${func}, ERROR CODES=${rc1} ${rc2} ${rc3}
>>>>> sqlCodes V8 >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>*/
/*<<< sqlCodes V9 <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+205 ${column-name} IS NOT A COLUMN OF TABLE ${table-name}
+206 ${column-name} IS NOT A COLUMN OF AN INSERTED TABLE, UPDATED TABLE,
MERGED TABLE, OR ANY TABLE IDENTIFIED IN A FROM CLAUSE
+231 CURRENT POSITION OF CURSOR ${cursor-name} IS NOT VALID FOR THE SPEC
IFIED FETCH ORIENTATION OF THE CURRENT ROW OR ROWSET
+237 SQLDA INCLUDES ${integer1} SQLVAR ENTRIES, BUT ${integer2} ARE REQU
IRED BECAUSE AT LEAST ONE OF THE COLUMNS BEING DESCRIBED IS A DISTINCT
TYPE
+252 A NON-ATOMIC ${statement} STATEMENT SUCCESSFULLY PROCESSED ALL REQU
ESTED ROWS, WITH ONE OR MORE WARNING CONDITIONS
+331 THE NULL VALUE HAS BEEN ASSIGNED TO A HOST VARIABLE OR PARAMETER BE
CAUSE THE STRING CANNOT BE CONVERTED FROM ${source-ccsid} TO ${target-
ccsid}. REASON ${reason-code}, POSITION ${position-number}
+354 A ROWSET FETCH STATEMENT MAY HAVE RETURNED ONE OR MORE ROWS OF DATA
. HOWEVER, ONE OR MORE WARNING CONDITIONS WERE ALSO ENCOUNTERED. USE T
HE GET DIAGNOSTICS STATEMENT FOR MORE INFORMATION REGARDING THE CONDIT
IONS THAT WERE ENCOUNTERED
+361 COMMAND WAS SUCCESSFUL BUT RESULTED IN THE FOLLOWING: ${msg-token}
+364 DECFLOAT EXCEPTION ${exception-type} HAS OCCURRED DURING ${operatio
n-type} OPERATION, POSITION ${position-number}
+385 ASSIGNMENT TO AN SQLSTATE OR SQLCODE VARIABLE IN AN SQL ROUTINE ${r
outine-name} MAY BE OVERWRITTEN AND DOES NOT ACTIVATE ANY HANDLER
+394 ALL USER SPECIFIED OPTIMIZATION HINTS USED DURING ACCESS PATH SELEC
TION
+395 A USER SPECIFIED OPTIMIZATION HINT IS INVALID (REASON CODE = ${reas
on-code})
+434 ${clause} IS A DEPRECATED CLAUSE
+438 APPLICATION RAISED WARNING WITH DIAGNOSTIC TEXT: ${text}
+440 NO ${routine-type} BY THE NAME ${routine-name} HAVING COMPATIBLE AR
GUMENTS WAS FOUND
+585 THE COLLECTION ${collection-id} APPEARS MORE THAN ONCE WHEN SETTING
THE ${special-register} SPECIAL REGISTER
+645 WHERE NOT NULL IS IGNORED BECAUSE THE INDEX KEY CANNOT CONTAIN NULL
VALUES OR THE INDEX IS AN XML INDEX
+664 THE INTERNAL LENGTH OF THE LIMIT-KEY FIELDS SPECIFIED IN THE PARTIT
ION CLAUSE OF THE ${statement-name} STATEMENT EXCEEDS THE EXISTING INT
ERNAL LIMIT KEY LENGTH STORED IN CATALOG TABLE ${table-name}
+20002 THE ${clause} SPECIFICATION IS IGNORED FOR OBJECT ${object-name}
+20007 USE OF OPTIMIZATION HINTS IS DISALLOWED BY A DB2 SUBSYSTEM PARAME
TER. THE SPECIAL REGISTER OPTIMIZATION HINT IS SET TO AN EMPTY STRIN
G.
+20141 TRUNCATION OF VALUE WITH LENGTH ${length} OCCURRED FOR ${hv-or-pa
rm-number}
+20187 ROLLBACK TO SAVEPOINT CAUSED A NOT LOGGED TABLE SPACE TO BE PLACE
D IN THE LPL
+20237 FETCH PRIOR ROWSET FOR CURSOR ${cursor-name} RETURNED A PARTIAL R
OWSET
+20245 NOT PADDED CLAUSE IS IGNORED FOR INDEXES CREATED ON AUXILIARY TAB
LES
+20270 OPTION NOT SPECIFIED FOLLOWING ALTER PARTITION CLAUSE
+20272 TABLE SPACE ${table-space-name} HAS BEEN CONVERTED TO USE TABLE-C
ONTROLLED PARTITIONING INSTEAD OF INDEX-CONTROLLED PARTITIONING, ADDIT
IONAL INFORMATION: ${old-limit-key-value}
+20348 THE PATH VALUE HAS BEEN TRUNCATED.
+20360 TRUSTED CONNECTION CAN NOT BE ESTABLISHED FOR SYSTEM AUTHID ${aut
horization-name}
+20365 A SIGNALING NAN WAS ENCOUNTERED, OR AN EXCEPTION OCCURRED IN AN A
RITHMETIC OPERATION OR FUNCTION INVOLVING A DECFLOAT.
+20367 OPTION ${clause} IS NOT SUPPORTED IN THE CONTEXT IN WHICH IT WAS
SPECIFIED
+20368 TRUSTED CONTEXT ${context-name} IS NO LONGER DEFINED TO BE USED B
Y SPECIFIC VALUES FOR ATTRIBUTE ${attribute-name}
+20371 THE ABILITY TO USE TRUSTED CONTEXT ${context-name} WAS REMOVED FR
OM SOME, BUT NOT ALL AUTHORIZATION IDS SPECIFIED IN THE STATEMENT.
+20378 A NON-ATOMIC ${statement} STATEMENT SUCCESSFULLY COMPLETED FOR SO
ME OF THE REQUESTED ROWS, POSSIBLY WITH WARNINGS, AND ONE OR MORE ERRO
RS, AND THE CURSOR CAN BE USED
+30100 OPERATION COMPLETED SUCCESSFULLY BUT A DISTRIBUTION PROTOCOL VIOL
ATION HAS BEEN DETECTED. ORIGINAL SQLCODE=${original-sqlcode} AND ORIG
INAL SQLSTATE=${original-sqlstateError} SQL ${codes}
-011 COMMENT NOT CLOSED
-051 ${name} (${sqltype}) WAS PREVIOUSLY DECLARED OR REFERENCED
-056 AN SQLSTATE OR SQLCODE VARIABLE DECLARATION IS IN A NESTED COMPOUND
STATEMENT
-058 VALUE SPECIFIED ON RETURN STATEMENT MUST BE AN INTEGER
-078 PARAMETER NAMES MUST BE SPECIFIED FOR ROUTINE ${routine-name}
-079 QUALIFIER FOR OBJECT ${name} WAS SPECIFIED AS ${qualifier1} ${but}
${qualifier2} IS REQUIRED
-087 A NULL VALUE WAS SPECIFIED IN A CONTEXT WHERE A NULL IS NOT ALLOWED
-096 VARIABLE ${variable-name} DOES NOT EXIST OR IS NOT SUPPORTED BY THE
SERVER AND A DEFAULT VALUE WAS NOT PROVIDED
-101 THE STATEMENT IS TOO LONG OR TOO COMPLEX
-102 STRING CONSTANT IS TOO LONG. STRING BEGINS ${string}
-103 ${constant} IS AN INVALID NUMERIC CONSTANT
-110 INVALID HEXADECIMAL CONSTANT BEGINNING ${constant}
-112 THE OPERAND OF AN AGGREGATE FUNCTION INCLUDES AN AGGREGATE FUNCTION
, AN OLAP SPECIFICATION, OR A SCALAR FULLSELECT
-113 INVALID CHARACTER FOUND IN: ${string}, REASON CODE ${nnn}
-119 A COLUMN OR EXPRESSION IN A HAVING CLAUSE IS NOT VALID
-120 AN AGGREGATE FUNCTION OR OLAP SPECIFICATION IS NOT VALID IN THE CON
TEXT IN WHICH IT WAS INVOKED
-121 THE COLUMN ${name} IS IDENTIFIED MORE THAN ONCE IN THE INSERT OR UP
DATE OPERATION OR SET TRANSITION VARIABLE STATEMENT
-122 COLUMN OR EXPRESSION IN THE SELECT LIST IS NOT VALID
-127 DISTINCT IS SPECIFIED MORE THAN ONCE IN A SUBSELECT
-134 IMPROPER USE OF A STRING, LOB, OR XML VALUE
-136 SORT CANNOT BE EXECUTED BECAUSE THE SORT KEY LENGTH TOO LONG
-138 THE SECOND OR THIRD ARGUMENT OF THE SUBSTR OR SUBSTRING FUNCTION IS
OUT OF RANGE
-147 ALTER FUNCTION ${function-name} FAILED BECAUSE SOURCE FUNCTIONS OR
NOT FENCED EXTERNAL FUNCTION CANNOT BE ALTERED
-148 THE SOURCE TABLE ${source-name} CANNOT BE ALTERED, REASON ${reason-
code}
-150 THE OBJECT OF THE INSERT, DELETE, UPDATE, MERGE, OR TRUNCATE STATEM
ENT IS A VIEW, SYSTEM-MAINTAINED MATERIALIZED QUERY TABLE, OR TRANSITI
ON TABLE FOR WHICH THE REQUESTED OPERATION IS NOT PERMITTED
-151 THE UPDATE OPERATION IS INVALID BECAUSE THE CATALOG DESCRIPTION OF
COLUMN ${column-name} INDICATES THAT IT CANNOT BE UPDATED
-159 THE STATEMENT REFERENCES ${object-name} WHICH IDENTIFIES AN ${objec
t-type} RATHER THAN AN ${expected-object-type}
-160 THE WITH CHECK OPTION CLAUSE IS NOT VALID FOR THE SPECIFIED VIEW
-187 A REFERENCE TO A CURRENT DATETIME SPECIAL REGISTER IS INVALID BECAU
SE THE MVS TOD CLOCK IS BAD OR THE MVS PARMTZ IS OUT OF RANGE
-189 CCSID ${ccsid} IS INVALID
-190 THE ATTRIBUTES SPECIFIED FOR THE COLUMN ${table-name.column-name} A
RE NOT COMPATIBLE WITH THE EXISTING COLUMN DEFINITION
-197 A QUALIFIED COLUMN NAME IS NOT ALLOWED IN THE ORDER BY CLAUSE WHEN
A SET OPERATOR IS ALSO SPECIFIED
-206 ${name} IS NOT VALID IN THE CONTEXT WHERE IT IS USED
-222 AN UPDATE OR DELETE OPERATION WAS ATTEMPTED AGAINST A HOLE USING CU
RSOR ${cursor-name}
-225 FETCH STATEMENT FOR ${cursor-name} IS NOT VALID FOR THE DECLARATION
OF THE CURSOR
-229 THE LOCALE ${locale} SPECIFIED IN A SET LC_CTYPE OR OTHER STATEMENT
THAT IS LOCALE SENSITIVE WAS NOT FOUND
-240 THE PARTITION CLAUSE OF A LOCK TABLE STATEMENT IS INVALID
-242 THE OBJECT NAMED ${object-name} OF TYPE ${object-type} WAS SPECIFIE
D MORE THAN ONCE IN THE LIST OF OBJECTS, OR THE NAME IS THE SAME AS AN
EXISTING OBJECT
-245 THE INVOCATION OF FUNCTION ${routine-name} IS AMBIGUOUS
-253 A NON-ATOMIC ${statement} STATEMENT SUCCESSFULLY COMPLETED FOR SOME
OF THE REQUESTED ROWS, POSSIBLY WITH WARNINGS, AND ONE OR MORE ERRORS
-254 A NON-ATOMIC ${statement} STATEMENT ATTEMPTED TO PROCESS MULTIPLE R
OWS OF DATA, BUT ERRORS OCCURRED
-312 VARIABLE ${variable-name} IS NOT DEFINED OR NOT USABLE
-330 A STRING CANNOT BE USED BECAUSE IT CANNOT BE PROCESSED. REASON ${re
ason-code}, CHARACTER ${code-point}, HOST VARIABLE ${position-number}
-331 CHARACTER CONVERSION CANNOT BE PERFORMED BECAUSE A STRING, POSITION
${position-number}, CANNOT BE CONVERTED FROM ${source-ccsid} TO ${tar
get-ccsid}, REASON ${reason-code}
-333 THE SUBTYPE OF A STRING VARIABLE IS NOT THE SAME AS THE SUBTYPE KNO
WN AT BIND TIME AND THE DIFFERENCE CANNOT BE RESOLVED BY CHARACTER CON
VERSION
-336 THE SCALE OF THE DECIMAL NUMBER MUST BE ZERO
-342 THE COMMON TABLE EXPRESSION ${name} MUST NOT USE SELECT DISTINCT AN
D MUST USE UNION ALL BECAUSE IT IS RECURSIVE
-344 THE RECURSIVE COMMON TABLE EXPRESSION ${name} HAS MISMATCHED DATA T
YPES OR LENGTHS OR CODE PAGE FOR COLUMN ${column-name}
-345 THE FULLSELECT OF THE RECURSIVE COMMON TABLE EXPRESSION ${name} MUS
T BE A UNION ALL AND MUST NOT INCLUDE AGGREGATE FUNCTIONS, GROUP BY CL
AUSE, HAVING CLAUSE, OR AN EXPLICIT JOIN INCLUDING AN ON CLAUSE
-348 ${sequence-expression} CANNOT BE SPECIFIED IN THIS CONTEXT
-350 ${column-name} WAS IMPLICITLY OR EXPLICITLY REFERENCED IN A CONTEXT
IN WHICH IT CANNOT BE USED
-353 FETCH IS NOT ALLOWED, BECAUSE CURSOR ${cursor-name} HAS AN UNKNOWN
POSITION
-354 A ROWSET FETCH STATEMENT MAY HAVE RETURNED ONE OR MORE ROWS OF DATA
. HOWEVER, ONE OR MORE NON-TERMINATING ERROR CONDITIONS WERE ENCOUNTER
ED. USE THE GET DIAGNOSTICS STATEMENT FOR MORE INFORMATION REGARDING T
HE CONDITIONS THAT WERE ENCOUNTERED
-356 KEY EXPRESSION ${key-expr-num} IS NOT VALID, REASON CODE = ${reason
-code}
-372 ONLY ONE ROWID, IDENTITY, OR SECURITY LABEL COLUMN IS ALLOWED IN A
TABLE
-373 DEFAULT CANNOT BE SPECIFIED FOR COLUMN OR SQL VARIABLE ${name}
-374 THE CLAUSE ${clause} HAS NOT BEEN SPECIFIED IN THE CREATE OR ALTER
FUNCTION STATEMENT FOR LANGUAGE SQL FUNCTION ${function-name} BUT AN E
XAMINATION OF THE FUNCTION BODY REVEALS THAT IT SHOULD BE SPECIFIED
-390 THE FUNCTION ${function-name}, SPECIFIC NAME ${specific-name}, IS N
OT VALID IN THE CONTEXT WHERE IT IS USED
-397 GENERATED IS SPECIFIED AS PART OF A COLUMN DEFINITION, BUT IT IS NO
T VALID FOR THE DEFINITION OF THE COLUMN
-399 INVALID VALUE ROWID WAS SPECIFIED
-405 THE NUMERIC CONSTANT ${constant} CANNOT BE USED AS SPECIFIED BECAUS
E IT IS OUT OF RANGE
-408 THE VALUE IS NOT COMPATIBLE WITH THE DATA TYPE OF ITS TARGET. TARGE
T NAME IS ${name}
-410 A NUMERIC VALUE ${value} IS TOO LONG, OR IT HAS A VALUE THAT IS NOT
WITHIN THE RANGE OF ITS DATA TYPE
-415 THE CORRESPONDING COLUMNS, ${column-number}, OF THE OPERANDS OF A S
ET OPERATOR ARE NOT COMPATIBLE
-416 AN OPERAND OF A SET OPERATOR CONTAINS A LONG STRING COLUMN
-421 THE OPERANDS OF A SET OPERATOR DO NOT HAVE THE SAME NUMBER OF COLUM
NS
-431 ROUTINE ${routine-name} (SPECIFIC NAME ${specific-name}) OF TYPE ${
routine-type} HAS BEEN INTERRUPTED BY THE USER
-435 AN INVALID SQLSTATE ${sqlstate} IS SPECIFIED IN A RAISE_ERROR FUNCT
ION, RESIGNAL STATEMENT, OR SIGNAL STATEMENT
-440 NO ${routine-type} BY THE NAME ${routine-name} HAVING COMPATIBLE AR
GUMENTS WAS FOUND IN THE CURRENT PATH
-441 INVALID USE OF DISTINCT OR ALL WITH FUNCTION ${function-name}
-443 ROUTINE ${routine-name} (SPECIFIC NAME ${specific-name}) HAS RETURN
ED AN ERROR SQLSTATE WITH DIAGNOSTIC TEXT ${msg-text}
-451 THE ${data-item} DEFINITION IN THE CREATE OR ALTER STATEMENT FOR ${
routine-name} CONTAINS DATA TYPE ${type} WHICH IS NOT SUPPORTED FOR TH
E TYPE AND LANGUAGE OF THE ROUTINE
-452 UNABLE TO ACCESS THE FILE REFERENCED BY HOST VARIABLE ${variable-po
sition}. REASON CODE: ${reason-code}
-504 CURSOR NAME ${cursor-name} IS NOT DECLARED
-511 THE FOR UPDATE CLAUSE CANNOT BE SPECIFIED BECAUSE THE RESULT TABLE
DESIGNATED BY THE SELECT STATEMENT CANNOT BE MODIFIED
-516 THE DESCRIBE STATEMENT DOES NOT SPECIFY A PREPARED STATEMENT
-525 THE SQL STATEMENT CANNOT BE EXECUTED BECAUSE IT WAS IN ERROR AT BIN
D TIME FOR SECTION = ${sectno} PACKAGE = ${pkgname} CONSISTENCY TOKEN
= ${contoken}
-526 THE REQUESTED OPERATION OR USAGE DOES NOT APPLY TO ${table-type} TE
MPORARY TABLE ${table-name}
-532 THE RELATIONSHIP ${constraint-name} RESTRICTS THE DELETION OF ROW W
ITH RID X ${rid-number}
-553 ${auth-id} SPECIFIED IS NOT ONE OF THE VALID AUTHORIZATION IDS FOR
REQUESTED OPERATION
-554 AN AUTHORIZATION ID OR ROLE CANNOT GRANT A PRIVILEGE TO ITSELF
-555 AN AUTHORIZATION ID OR ROLE CANNOT REVOKE A PRIVILEGE FROM ITSELF
-575 VIEW ${view-name} CANNOT BE REFERENCED
-583 THE USE OF FUNCTION OR EXPRESSION ${name} IS INVALID BECAUSE IT IS
NOT DETERMINISTIC OR HAS AN EXTERNAL ACTION
-584 INVALID USE OF NULL
-585 THE COLLECTION ${collection-id} APPEARS MORE THAN ONCE IN THE SET $
{special-register} STATEMENT
-586 THE TOTAL LENGTH OF THE CURRENT PATH SPECIAL REGISTER CANNOT EXCEED
2048 CHARACTERS
-590 NAME ${name} IS NOT UNIQUE IN THE CREATE OR ALTER FOR ROUTINE ${rou
tine-name}
-593 NOT NULL MUST BE SPECIFIED FOR ROWID (OR DISTINCT TYPE FOR ROWID) O
R ROW CHANGE TIMESTAMP COLUMN ${column-name}
-601 THE NAME (VERSION OR VOLUME SERIAL NUMBER) OF THE OBJECT TO BE DEFI
NED OR THE TARGET OF A RENAME STATEMENT IS IDENTICAL TO THE EXISTING N
AME (VERSION OR VOLUME SERIAL NUMBER) ${name} OF THE OBJECT TYPE ${obj
-type}
-602 TOO MANY COLUMNS OR KEY-EXPRESSIONS SPECIFIED IN A CREATE INDEX OR
ALTER INDEX STATEMENT
-612 ${identifier} IS A DUPLICATE NAME
-620 KEYWORD ${keyword} IN ${stmt-type} STATEMENT IS NOT PERMITTED FOR A
${space-type} SPACE IN THE ${database-type} DATABASE
-624 TABLE ${table-name} ALREADY HAS A PRIMARY KEY OR UNIQUE CONSTRAINT
WITH SPECIFIED COLUMNS
-627 THE ALTER STATEMENT IS INVALID BECAUSE THE TABLE SPACE OR INDEX HAS
USER-MANAGED DATA SETS
-636 RANGES SPECIFIED FOR PARTITION ${part-num} ARE NOT VALID
-637 DUPLICATE ${keyword} KEYWORD OR CLAUSE
-643 A CHECK CONSTRAINT OR THE VALUE OF AN EXPRESSION FOR A COLUMN OF AN
INDEX EXCEEDS THE MAXIMUM ALLOWABLE LENGTH KEY EXPRESSION
-644 INVALID VALUE SPECIFIED FOR KEYWORD OR CLAUSE ${keyword-or-clause}
IN STATEMENT ${stmt-type}
-647 BUFFERPOOL ${bp-name} FOR IMPLICIT OR EXPLICIT TABLESPACE OR INDEXS
PACE ${name} HAS NOT BEEN ACTIVATED
-661 ${object-type} ${index-name} CANNOT BE CREATED ON PARTITIONED TABLE
SPACE ${tspace-name} BECAUSE THE NUMBER OF PARTITION SPECIFICATIONS I
S NOT EQUAL TO THE NUMBER OF PARTITIONS OF THE TABLE SPACE
-662 A PARTITIONED INDEX CANNOT BE CREATED ON A NON-PARTITIONED, PARTITI
ON-BY-GROWTH OR RANGE-PARTITIONED UNIVERSAL TABLE SPACE ${tspace-name}
-665 THE PARTITION CLAUSE OF AN ALTER STATEMENT IS OMITTED OR INVALID
-676 THE PHYSICAL CHARACTERISTICS OF THE INDEX ARE INCOMPATIBLE WITH RES
PECT TO THE SPECIFIED STATEMENT. THE STATEMENT HAS FAILED. REASON ${re
ason-code}
-678 THE CONSTANT ${constant} SPECIFIED FOR THE INDEX LIMIT KEY MUST CON
FORM TO THE DATA TYPE ${data-type} OF THE CORRESPONDING COLUMN ${colum
n-name}
-684 THE LENGTH OF CONSTANT LIST BEGINNING ${string} IS TOO LONG
-693 THE COLUMN ${column-name} IN DDL REGISTRATION TABLE OR INDEX ${name
} IS NOT DEFINED PROPERLY
-694 THE SCHEMA STATEMENT CANNOT BE EXECUTED BECAUSE A DROP IS PENDING O
N THE DDL REGISTRATION TABLE ${table-name}
-695 INVALID VALUE ${seclabel} SPECIFIED FOR SECURITY LABEL COLUMN OF TA
BLE ${table-name}
-713 THE REPLACEMENT VALUE FOR ${special-register} IS INVALID
-748 AN INDEX ${index-name} ALREADY EXISTS ON AUXILIARY TABLE ${table-na
me}
-750 THE SOURCE TABLE ${table-name} CANNOT BE RENAMED BECAUSE IT IS REFE
RENCED IN EXISTING VIEW, MATERIALIZED QUERY TABLE, OR TRIGGER DEFINITI
ONS, IS A CLONE TABLE, OR HAS A CLONE TABLE DEFINED FOR IT
-770 TABLE ${table-name} CANNOT HAVE A LOB COLUMN UNLESS IT ALSO HAS A R
OWID, OR AN XML COLUMN UNLESS IT ALSO HAS A DOCID COLUMN
-773 CASE NOT FOUND FOR CASE STATEMENT
-776 USE OF CURSOR ${cursor-name} IS NOT VALID
-778 ENDING LABEL ${label} DOES NOT MATCH THE BEGINNING LABEL
-779 LABEL ${label} SPECIFIED ON A GOTO, ITERATE, OR LEAVE STATEMENT IS
NOT VALID
-780 UNDO SPECIFIED FOR A HANDLER
-781 CONDITION ${condition-name} IS NOT DEFINED OR THE DEFINITION IS NOT
IN SCOPE
-782 A CONDITION OR SQLSTATE ${value} SPECIFIED IS NOT VALID
-783 SELECT LIST FOR CURSOR ${cursor-name} IN FOR STATEMENT IS NOT VALID
. COLUMN ${column-name} IS NOT UNIQUE
-785 USE OF SQLCODE OR SQLSTATE IS NOT VALID
-787 RESIGNAL STATEMENT ISSUED OUTSIDE OF A HANDLER
-788 THE SAME ROW OF TARGET TABLE ${table-name} WAS IDENTIFIED MORE THAN
ONCE FOR AN UPDATE OPERATION OF THE MERGE STATEMENT
-789 THE DATA TYPE FOR THE VARIABLE ${name} IS NOT SUPPORTED IN THE SQL
ROUTINE
-797 THE TRIGGER ${trigger-name} IS DEFINED WITH AN UNSUPPORTED TRIGGERE
D SQL STATEMENT
-798 A VALUE CANNOT BE SPECIFIED FOR COLUMN ${column-name} WHICH IS DEFI
NED AS GENERATED ALWAYS
-803 AN INSERTED OR UPDATED VALUE IS INVALID BECAUSE THE INDEX IN INDEX
SPACE ${indexspace-name} CONSTRAINS COLUMNS OF THE TABLE SO NO TWO ROW
S CAN CONTAIN DUPLICATE VALUES IN THOSE COLUMNS. RID OF EXISTING ROW I
S X ${rid}
-845 A PREVIOUS VALUE EXPRESSION CANNOT BE USED BEFORE THE NEXT VALUE EX
PRESSION GENERATES A VALUE IN THE CURRENT APPLICATION PROCESS FOR SEQU
ENCE ${sequence-name}
-873 THE STATEMENT REFERENCED DATA ENCODED WITH DIFFERENT ENCODING SCHEM
ES OR CCSIDS IN AN INVALID CONTEXT
-876 ${object} CANNOT BE CREATED OR ALTERED, REASON ${reason}
-878 THE PLAN_TABLE USED FOR EXPLAIN CANNOT BE ASCII
-900 THE SQL STATEMENT CANNOT BE EXECUTED BECAUSE THE APPLICATION PROCES
S IS NOT CONNECTED TO A SERVER
-907 AN ATTEMPT WAS MADE TO MODIFY THE TARGET TABLE, ${table-name}, OF T
HE MERGE STATEMENT BY CONSTRAINT OR TRIGGER ${name}
-910 THE SQL STATEMENT CANNOT ACCESS AN OBJECT ON WHICH UNCOMMITTED CHAN
GES ARE PENDING
-951 OBJECT ${object-name} OBJECT TYPE ${object-type} IS IN USE AND CANN
OT BE THE TARGET OF THE SPECIFIED ALTER STATEMENT
-989 AFTER TRIGGER ${trigger-name} ATTEMPTED TO MODIFY A ROW IN TABLE ${
table-name} THAT WAS MODIFIED BY AN SQL DATA CHANGE STATEMENT WITHIN A
FROM CLAUSE
-992 PACKAGE ${package-name} CANNOT BE EXECUTED OR DEPLOYED ON LOCATION
${location-name}
-1403 THE USERNAME AND/OR PASSWORD SUPPLIED IS INCORRECT
-4302 JAVA STORED PROCEDURE OR USER-DEFINED FUNCTION ${routine-name} (SP
ECIFIC NAME ${specific-name}) HAS EXITED WITH AN EXCEPTION ${exception
-string}
-4701 THE NUMBER OF PARTITIONS, OR THE COMBINATION OF THE NUMBER OF TABL
E SPACE PARTITIONS AND THE CORRESPONDING LENGTH OF THE PARTITIONING LI
MIT KEY EXCEEDS THE SYSTEM LIMIT
-4702 THE MAXIMUM NUMBER OF ALTERS ALLOWED HAS BEEN EXCEEDED FOR ${objec
t-type}
-4703 THE ALTER TABLE STATEMENT CANNOT BE EXECUTED BECAUSE COLUMN ${colu
mn-name} IS MIXED DATA, OR THE DATA TYPE OR LENGTH SPECIFIED DOES NOT
AGREE WITH THE EXISTING DATA TYPE OR LENGTH
-4704 AN UNSUPPORTED DATA TYPE WAS ENCOUNTERED AS AN INCLUDE COLUMN
-4705 ${option} SPECIFIED ON ALTER PROCEDURE FOR PROCEDURE ${routinename
} IS NOT VALID
-4706 ALTER PROCEDURE STATEMENT CANNOT BE PROCESSED BECAUSE THE OPTIONS
IN EFFECT ARE NOT THE SAME AS THE ONES THAT WERE IN EFFECT (ENVID ${en
vid}) WHEN THE PROCEDURE OR VERSION WAS FIRST DEFINED
-4707 STATEMENT ${statement} IS NOT ALLOWED WHEN USING A TRUSTED CONNECT
ION
-4708 TABLE ${table-name} CANNOT BE DEFINED AS SPECIFIED IN THE ${statem
ent} STATEMENT IN A COMMON CRITERIA ENVIRONMENT
-4709 EXPLAIN MONITORED STMTS FAILED WITH REASON CODE = ${yyyyy}
-4710 EXCHANGE DATA STATEMENT SPECIFIED ${table1} ${and} ${table2} BUT T
HE TABLES DO NOT HAVE A DEFINED CLONE RELATIONSHIP
-5001 TABLE ${table-name} IS NOT VALID
-5012 HOST VARIABLE ${host-variable} IS NOT EXACT NUMERIC WITH SCALE ZER
O
-7008 ${object-name} NOT VALID FOR OPERATION (${reason-code}) -${skel}
-16000 AN XQUERY EXPRESSION CANNOT BE PROCESSED BECAUSE THE ${context-co
mponent} COMPONENT OF THE STATIC CONTEXT HAS NOT BEEN ASSIGNED. ERROR
QNAME = ${err}:XPST0001
-16001 AN XQUERY EXPRESSION STARTING WITH TOKEN ${token} CANNOT BE PROCE
SSED BECAUSE THE FOCUS COMPONENT OF THE DYNAMIC CONTEXT HAS NOT BEEN A
SSIGNED. ERROR QNAME = ${err}:XPDY0002
-16002 AN XQUERY EXPRESSION HAS AN UNEXPECTED TOKEN ${token} FOLLOWING $
{text}. EXPECTED TOKENS MAY INCLUDE: ${token-list}. ERROR QNAME= ERR:X
PST0003
-16003 AN EXPRESSION OF DATA TYPE ${value-type} CANNOT BE USED WHEN THE
DATA TYPE ${expected-type} IS EXPECTED IN THE CONTEXT. ERROR QNAME= ${
err}:XPTY0004
-16005 AN XQUERY EXPRESSION REFERENCES AN ELEMENT NAME, ATTRIBUTE NAME,
TYPE NAME, FUNCTION NAME, NAMESPACE PREFIX, OR VARIABLE NAME ${undefin
ed-name} THAT IS NOT DEFINED WITHIN THE STATIC CONTEXT. ERROR QNAME= E
RR:XPST0008
-16007
-16009 AN XQUERY FUNCTION NAMED ${function-name} WITH ${number-of-parms}
PARAMETERS IS NOT DEFINED IN THE STATIC CONTEXT. ERROR QNAME= ${err}:
XPST0017
-16011 THE RESULT OF AN INTERMEDIATE STEP EXPRESSION IN AN XQUERY PATH E
XPRESSION CONTAINS AN ATOMIC VALUE. ERROR QNAME = ${err}:XPTY0019
-16012 THE CONTEXT ITEM IN AN AXIS STEP MUST BE A NODE. ERROR QNAME = ${
err}:XPTY0020
-16015 AN ELEMENT CONSTRUCTOR CONTAINS AN ATTRIBUTE NODE NAMED ${attribu
te-name} THAT FOLLOWS AN XQUERY NODE THAT IS NOT AN ATTRIBUTE NODE. ER
ROR QNAME = ERR:XQTY0024
-16016 THE ATTRIBUTE NAME ${attribute-name} CANNOT BE USED MORE THAN ONC
E IN AN ELEMENT CONSTRUCTOR. ERROR QNAME = ${err}:XQTY0025
-16020 THE CONTEXT NODE IN A PATH EXPRESSION THAT BEGINS WITH AN INITIAL
?/? OR ?//? DOES NOT HAVE AN XQUERY DOCUMENT NODE ROOT. ERROR QNAME =
${err}:XPDY0050
-16022 OPERANDS OF TYPES ${xquery-data-types} ARE NOT VALID FOR OPERATOR
${operator-name} . ERROR QNAME = ${err}:XPTY0004
-16023 THE XQUERY PROLOG CANNOT CONTAIN MULTIPLE DECLARATIONS FOR THE SA
ME NAMESPACE PREFIX ${ns-prefix}. ERROR QNAME = ${err}:XQST0033
-16024 THE NAMESPACE PREFIX ${prefix-name} CANNOT BE REDECLARED OR CANNO
T BE BOUND TO THE SPECIFIED URI. ERROR QNAME = ${err}:XQST0070
-16031 XQUERY LANGUAGE FEATURE USING SYNTAX ${string} IS NOT SUPPORTED
-16032 THE STRING ${string} IS NOT A VALID URI. ERROR QNAME = ${err}:XQS
T0046
-16036 THE URI THAT IS SPECIFIED IN A NAMESPACE DECLARATION CANNOT BE A
ZERO-LENGTH STRING
-16046 A NUMERIC XQUERY EXPRESSION ATTEMPTED TO DIVIDE BY ZERO. ERROR QN
AME = ${err}:FOAR0001
-16047 AN XQUERY EXPRESSION RESULTED IN ARITHMETIC OVERFLOW OR UNDERFLOW
. ERROR QNAME= ${err}:FOAR0002
-16048 AN XQUERY PROLOG CANNOT CONTAIN MORE THAN ONE ${decl-type} DECLAR
ATION. ERROR QNAME = ${error-qname}
-16049 THE LEXICAL VALUE ${value} IS NOT VALID FOR THE ${type-name} DATA
TYPE IN THE FUNCTION OR CAST. ERROR QNAME= ${err}:FOCA0002
-16051 THE VALUE ${value} OF DATA TYPE ${source-type} IS OUT OF RANGE FO
R AN IMPLICIT OR EXPLICIT CAST TO TARGET DATA TYPE ${target-type}. ERR
OR QNAME = ${err}:${error-qname}
-16061 THE VALUE ${value} CANNOT BE CONSTRUCTED AS, OR CAST (USING AN IM
PLICIT OR EXPLICIT CAST) TO THE DATA TYPE ${data-type}. ERROR QNAME =
${err}:FORG0001
-16065 AN EMPTY SEQUENCE CANNOT BE CAST TO THE DATA TYPE ${data-type}, E
RROR QNAME = ${err}:FORG0006
-16066 THE ARGUMENT PASSED TO THE AGGREGATE FUNCTION ${function-name} IS
NOT VALID. ERROR QNAME = ${err}:FORG0006
-16075 THE SEQUENCE TO BE SERIALIZED CONTAINS AN ITEM THAT IS AN ATTRIBU
TE NODE. ERROR QNAME = ${err}:SENR0001
-16246 INCOMPLETE ANNOTATION MAPPING AT OR NEAR LINE ${lineno} IN XML SC
HEMA DOCUMENT ${uri}. REASON CODE = ${reason-code}.
-16247 SOURCE XML TYPE ${source-data-type} CANNOT BE MAPPED TO TARGET SQ
L TYPE ${target-data-type} IN THE ANNOTATION AT OR NEAR LINE ${lineno}
IN XML SCHEMA DOCUMENT ${uri}
-16248 UNKNOWN ANNOTATION ${annotation-name} AT OR NEAR LINE ${lineno} I
N XML SCHEMA DOCUMENT ${uri}
-16249 THE ${db2-xdb}:${expression} ANNOTATION ${expression} AT OR NEAR
LINE ${lineno} IN XML SCHEMA DOCUMENT ${uri} IS TOO LONG.
-16250 THE ${db2-xdb}:${defaultSQLSchema} WITH VALUE ${schema-name} AT O
R NEAR LINE ${lineno} IN XML SCHEMA DOCUMENT ${uri} CONFLICTS WITH ANO
THER ${db2-xdb}:${defaultSQLSchema} SPECIFIED IN ONE OF THE XML SCHEMA
DOCUMENTS WITHIN THE SAME XML SCHEMA.
-16251 DUPLICATE ANNOTATION DEFINED FOR ${object-name} AT OR NEAR ${loca
tion} IN XML SCHEMA DOCUMENT ${uri}
-16252 THE ${db2-xdb}:${rowSet} NAME ${rowset-name} SPECIFIED AT OR NEAR
LINE ${lineno} IN THE XML SCHEMA DOCUMENT ${uri} IS ALREADY ASSOCIATE
D WITH ANOTHER TABLE
-16253 THE ${db2-xdb}:${condition} ANNOTATION ${condition} AT OR NEAR LI
NE ${lineno} IN XML SCHEMA DOCUMENT ${uri} IS TOO LONG.
-16254 A ${db2-xdb}:${locationPath} ${locationpath} AT OR NEAR LINE ${li
neno} IN XML SCHEMA DOCUMENT ${uri} IS NOT VALID WITH REASON CODE ${re
ason-code}.
-16255 A ${db2-xdb}:${rowSet} VALUE ${rowset-name} USED AT OR NEAR LINE
${lineno} IN XML SCHEMA DOCUMENT ${uri} CONFLICTS WITH A ${db2-xdb}:${
table} ANNOTATION WITH THE SAME NAME.
-16257 XML SCHEMA FEATURE ${feature} SPECIFIED IS NOT SUPPORTED FOR DECO
MPOSITION.
-16258 THE XML SCHEMA CONTAINS A RECURSIVE ELEMENT WHICH IS AN UNSUPPORT
ED FEATURE FOR DECOMPOSITION. THE RECURSIVE ELEMENT IS IDENTIFIED AS $
{elementnamespace} : ${elementname} OF TYPE ${typenamespace} : ${typen
ame}.
-16259 INVALID MANY-TO-MANY MAPPINGS DETECTED IN XML SCHEMA DOCUMENT ${u
ri1} NEAR LINE ${lineno1} AND IN XML SCHEMA DOCUMENT ${uri2} NEAR LINE
${lineno2}.
-16260 XML SCHEMA ANNOTATIONS INCLUDE NO MAPPINGS TO ANY COLUMN OF ANY T
ABLE.
-16262 THE ANNOTATED XML SCHEMA HAS NO COLUMNS MAPPED FOR ROWSET ${rowse
tname}.
-16265 THE XML DOCUMENT CANNOT BE DECOMPOSED USING XML SCHEMA ${xsrobjec
t-name} WHICH IS NOT ENABLED OR IS INOPERATIVE FOR DECOMPOSITION.
-16266 AN SQL ERROR OCCURRED DURING DECOMPOSITION OF DOCUMENT ${docid} W
HILE ATTEMPTING TO INSERT DATA. INFORMATION RETURNED FOR THE ERROR INC
LUDES SQLCODE ${sqlcode}, SQLSTATE ${sqlstate}, AND MESSAGE TOKENS ${t
oken-list}.
-20019 THE RESULT TYPE RETURNED FROM THE FUNCTION BODY CANNOT BE ASSIGNE
D TO THE DATA TYPE DEFINED IN THE RETURNS CLAUSE
-20060 UNSUPPORTED DATA TYPE ${data-type} ENCOUNTERED IN SQL ${object-ty
pe} ${object-name}
-20072 ${bind-type} ${bind-subtype} ERROR USING ${auth-id} AUTHORITY OPE
RATION IS NOT ALLOWED ON A ${package-type} PACKAGE ${package-name}
-20092 A TABLE OR VIEW WAS SPECIFIED IN THE LIKE CLAUSE, BUT THE OBJECT
CANNOT BE USED IN THIS CONTEXT
-20106 THE CCSID FOR THE TABLE SPACE OR DATABASE CANNOT BE CHANGED BECAU
SE THE TABLE SPACE OR DATABASE ALREADY CONTAINS A TABLE THAT IS REFERE
NCED IN EXISTING VIEW, OR MATERIALIZED QUERY TABLE DEFINITIONS OR AN E
XTENDED INDEX
-20143 THE ENCRYPTION OR DECRYPTION FUNCTION FAILED, BECAUSE THE ENCRYPT
ION PASSWORD VALUE IS NOT SET
-20144 THE ENCRYPTION IS INVALID BECAUSE THE LENGTH OF THE PASSWORD WAS
LESS THAN 6 BYTES OR GREATER THAN 127 BYTES
-20146 THE DECRYPTION FAILED. THE DATA IS NOT ENCRYPTED
-20147 THE ENCRYPTION FUNCTION FAILED. MULTIPLE PASS ENCRYPTION IS NOT S
UPPORTED
-20165 AN SQL DATA CHANGE STATEMENT WITHIN A FROM CLAUSE IS NOT ALLOWED
IN THE CONTEXT IN WHICH IT WAS SPECIFIED
-20166 AN SQL DATA CHANGE STATEMENT WITHIN A SELECT SPECIFIED A VIEW ${v
iew-name} WHICH IS NOT A SYMMETRIC VIEW OR COULD NOT HAVE BEEN DEFINED
AS A SYMMETRIC VIEW
-20178 VIEW ${view-name} ALREADY HAS AN INSTEAD OF ${operation} TRIGGER
DEFINED
-20179 THE INSTEAD OF TRIGGER CANNOT BE CREATED BECAUSE THE VIEW ${view-
name} IS DEFINED USING THE WITH CHECK OPTION
-20182 PARTITIONING CLAUSE ${clause} ON ${stmt-type} STATEMENT FOR ${ind
ex-name} IS NOT VALID
-20183 THE PARTITIONED, ADD PARTITION, ADD PARTITIONING KEY, ALTER PARTI
TION, ROTATE PARTITION, OR PARTITION BY RANGE CLAUSE SPECIFIED ON CREA
TE OR ALTER FOR ${name} IS NOT VALID
-20186 A CLAUSE SPECIFIED FOR THE DYNAMIC SQL STATEMENT BEING PROCESSED
IS NOT VALID
-20200 THE INSTALL OR REPLACE OF ${jar-id} WITH URL ${url} FAILED DUE TO
REASON ${reason-code-}(${reason-string}).
-20201 THE INSTALL, REPLACE, REMOVE, OR ALTER OF ${jar-name} FAILED DUE
TO REASON ${reason-code-}(${reason-string})
-20202 THE REMOVE OF ${jar-name} FAILED AS ${class} IS IN USE
-20210 THE SQL STATEMENT CANNOT BE EXECUTED BECAUSE IT WAS PRECOMPILED A
T A LEVEL THAT IS INCOMPATIBLE WITH THE CURRENT VALUE OF THE ENCODING
BIND OPTION OR SPECIAL REGISTER
-20211 THE SPECIFICATION ORDER BY OR FETCH FIRST N ROWS ONLY IS INVALID
-20212 USER-DEFINED ROUTINE ${name} ENCOUNTERED AN EXCEPTION ATTEMPTING
TO LOAD JAVA CLASS ${class-name} FROM JAR ${jar-name}. ORIGINAL EXCEPT
ION: ${exception-string}
-20213 STORED PROCEDURE ${procedure-name} HAS RETURNED A DYNAMIC RESULT
SET, PARAMETER ${number}, THAT IS NOT VALID
-20223 THE ENCRYPT_TDES OR DECRYPT FUNCTION FAILED. ENCRYPTION FACILITY
NOT AVAILABLE ${return-code}, ${reason-code}
-20224 ENCRYPTED DATA THAT WAS ORIGINALLY A BINARY STRING CANNOT BE DECR
YPTED TO A CHARACTER STRING
-20232 CHARACTER CONVERSION FROM CCSID ${from-ccsid} TO ${to-ccsid} FAIL
ED WITH ERROR CODE ${error-code} FOR TABLE ${dbid.obid} COLUMN ${colum
n-number} REQUESTED BY ${csect-name}
-20235 THE COLUMN ${column-name} CANNOT BE ADDED OR ALTERED BECAUSE ${ta
ble-name} IS A MATERIALIZED QUERY TABLE
-20240 INVALID SPECIFICATION OF A SECURITY LABEL COLUMN ${column-name} R
EASON CODE ${reason-code}
-20243 THE VIEW ${view-name} IS THE TARGET IN THE MERGE STATEMENT, BUT I
S MISSING THE INSTEAD OF TRIGGER FOR THE ${operation} OPERATION.
-20248 ATTEMPTED TO EXPLAIN ALL CACHED STATEMENTS OR A CACHED STATEMENT
WITH STMTID OR STMTTOKEN ID-${token} BUT THE REQUIRED EXPLAIN INFORMAT
ION IS NOT ACCESSIBLE.
-20249 THE PACKAGE ${package-name} NEEDS TO BE REBOUND IN ORDER TO BE SU
CCESSFULLY EXECUTED (${token})
-20252 DIAGNOSTICS AREA FULL. NO MORE ERRORS CAN BE RECORDED FOR THE NOT
ATOMIC STATEMENT
-20257 FINAL TABLE IS NOT VALID WHEN THE TARGET VIEW ${view-name} OF THE
SQL DATA CHANGE STATEMENT IN A FULLSELECT HAS AN INSTEAD OF TRIGGER D
EFINED
-20258 INVALID USE OF INPUT SEQUENCE ORDERING
-20260 THE ASSIGNMENT CLAUSE OF THE UPDATE OPERATION AND THE VALUES CLAU
SE OF THE INSERT OPERATION MUST SPECIFY AT LEAST ONE COLUMN THAT IS NO
T AN INCLUDE COLUMN
-20264 FOR TABLE ${table-name}, ${primary-auth-id} WITH SECURITY LABEL $
{primary-auth-id-seclabel} IS NOT AUTHORIZED TO PERFORM ${operation} O
N A ROW WITH SECURITY LABEL ${row-seclabel}. THE RECORD IDENTIFIER (RI
D) OF THIS ROW IS ${rid-number}.
-20265 SECURITY LABEL IS ${reason} FOR ${primary-auth-id}
-20266 ALTER VIEW FOR ${view-name} FAILED
-20275 The XML NAME ${name} IS NOT VALID. REASON CODE = ${reason-code}
-20281 ${primary-auth-id} DOES NOT HAVE THE MLS WRITE-DOWN PRIVILEGE
-20283 A DYNAMIC CREATE STATEMENT CANNOT BE PROCESSED WHEN THE VALUE OF
CURRENT SCHEMA DIFFERS FROM CURRENT SQLID
-20286 DB2 CONVERTED STRING ${token-type} ${token} FROM ${from-ccsid} TO
${to-ccsid}, AND RESULTED IN SUBSTITUTION CHARACTERS
-20289 INVALID STRING UNIT ${unit} SPECIFIED FOR FUNCTION ${function-nam
e}
-20295 THE EXECUTION OF A BUILT IN FUNCTION ${function} RESULTED IN AN E
RROR REASON CODE ${reason-code}
-20304 INVALID INDEX DEFINITION INVOLVING AN XMLPATTERN CLAUSE OR A COLU
MN OF DATA TYPE XML. REASON CODE = ${reason-code}
-20305 AN XML VALUE CANNOT BE INSERTED OR UPDATED BECAUSE OF AN ERROR DE
TECTED WHEN INSERTING OR UPDATING THE INDEX IDENTIFIED BY ${index-id}
ON TABLE ${table-name}. REASON CODE = ${reason-code}
-20306 AN INDEX ON AN XML COLUMN CANNOT BE CREATED BECAUSE OF AN ERROR D
ETECTED WHEN INSERTING THE XML VALUES INTO THE INDEX. REASON CODE = ${
reason-code}
-20310 THE REMOVE OF ${jar-name1} FAILED, AS IT IS IN USE BY ${jar-name2
}
-20311 THE VALUE PROVIDED FOR THE NEW JAVA PATH IS ILLEGAL
-20312 THE ALTER OF JAR ${jar-id} FAILED BECAUSE THE SPECIFIED PATH REFE
RENCES ITSELF
-20313 DEBUG MODE OPTION FOR ROUTINE ${routine-name} CANNOT BE CHANGED
-20314 THE PARAMETER LIST DOES NOT MATCH THE PARAMETER LIST FOR ALL OTHE
R VERSIONS OF ROUTINE ${routine-name}
-20315 THE CURRENTLY ACTIVE VERSION FOR ROUTINE ${routine-name} (${type}
) CANNOT BE DROPPED
-20326 AN XML ELEMENT NAME, ATTRIBUTE NAME, NAMESPACE PREFIX OR URI ENDI
NG WITH ${string} EXCEEDS THE LIMIT OF 1000 BYTES
-20327 THE DEPTH OF AN XML DOCUMENT EXCEEDS THE LIMIT OF 128 LEVELS
-20328 THE DOCUMENT WITH TARGET NAMESPACE ${namespace} AND SCHEMA LOCATI
ON ${location} HAS ALREADY BEEN ADDED FOR THE XML SCHEMA IDENTIFIED BY
${schema} ${name}
-20329 THE COMPLETION CHECK FOR THE XML SCHEMA FAILED BECAUSE ONE OR MOR
E XML SCHEMA DOCUMENTS IS MISSING. ONE MISSING XML SCHEMA DOCUMENT IS
IDENTIFIED BY ${uri-type} AS ${uri}
-20330 THE ${xsrobject-type} IDENTIFIED BY XML ${uri-type1} ${uri1} AND
XML ${uri-type2} ${uri2} IS NOT FOUND IN THE XML SCHEMA REPOSITORY
-20331 THE XML COMMENT VALUE ${string} IS NOT VALID
-20332 THE XML PROCESSING INSTRUCTION VALUE ${string} IS NOT VALID
-20335 MORE THAN ONE ${xsrobject-type} EXISTS IDENTIFIED BY XML ${uri-ty
pe1} ${uri1} AND ${uri-type2} ${uri2} EXISTS IN THE XML SCHEMA REPOSIT
ORY.
-20339 XML SCHEMA ${name} IS NOT IN THE CORRECT STATE TO PERFORM OPERATI
ON ${operation}
-20340 XML SCHEMA ${xmlschema-name} INCLUDES AT LEAST ONE XML SCHEMA DOC
UMENT IN NAMESPACE ${namespace} THAT IS NOT CONNECTED TO THE OTHER XML
SCHEMA DOCUMENTS
-20345 THE XML VALUE IS NOT A WELL-FORMED DOCUMENT WITH A SINGLE ROOT EL
EMENT
-20353 AN OPERATION INVOLVING COMPARISON CANNOT USE OPERAND ${name} DEFI
NED AS DATA TYPE ${type-name}
-20354 INVALID SPECIFICATION OF A ROW CHANGE TIMESTAMP COLUMN FOR TABLE
${table-name}
-20355 THE STATEMENT COULD NOT BE PROCESSED BECAUSE ONE OR MORE IMPLICIT
LY CREATED OBJECTS ARE INVOLVED ${reason-code}
-20356 THE TABLE WITH DBID = ${dbid} AND OBID = ${obid} CANNOT BE TRUNCA
TED BECAUSE DELETE TRIGGERS EXIST FOR THE TABLE, OR THE TABLE IS THE P
ARENT TABLE IN A REFERENTIAL CONSTRAINT
-20361 AUTHORIZATION ID ${authorization-name} IS NOT DEFINED FOR THE TRU
STED CONTEXT ${context-name}
-20362 ATTRIBUTE ${attribute-name} WITH VALUE ${value} CANNOT BE DROPPED
BECAUSE IT IS NOT PART OF THE DEFINITION OF TRUSTED CONTEXT ${context
-name}
-20363 ATTRIBUTE ${attribute-name} WITH VALUE ${value} IS NOT A UNIQUE S
PECIFICATION FOR TRUSTED CONTEXT ${context-name}
-20365 A SIGNALING NAN WAS ENCOUNTERED, OR AN EXCEPTION OCCURRED IN AN A
RITHMETIC OPERATION OR FUNCTION INVOLVING A DECFLOAT
-20366 TABLE WITH DBID=${dbid.obid} AND OBID= ${obid} CANNOT BE TRUNCATE
D BECAUSE UNCOMMITTED UPDATES EXIST ON THE TABLE WITH 'IMMEDIATE' OPTI
ON SPECIFIED IN THE STATEMENT
-20369 AN ALTER TRUSTED CONTEXT STATEMENT FOR ${context-name} ATTEMPTED
TO REMOVE THE LAST CONNECTION TRUST ATTRIBUTE ASSOCIATED WITH THE TRUS
TED CONTEXT
-20372 THE SYSTEM AUTHID CLAUSE OF A CREATE OR ALTER TRUSTED CONTEXT STA
TEMENT FOR ${context-name} SPECIFIED ${authorization-name}, BUT ANOTHE
R TRUSTED CONTEXT IS ALREADY DEFINED FOR THAT AUTHORIZATION ID.
-20373 A CREATE OR ALTER TRUSTED CONTEXT STATEMENT SPECIFIED ${authoriza
tion-name} MORE THAN ONCE OR THE TRUSTED CONTEXT IS ALREADY DEFINED TO
BE USED BY THIS AUTHORIZATION ID OR PUBLIC.
-20374 AN ALTER TRUSTED CONTEXT STATEMENT FOR ${context-name} SPECIFIED
${authorization-name} BUT THE TRUSTED CONTEXT IS NOT CURRENTLY DEFINED
TO BE USED BY THIS AUTHORIZATION ID OR PUBLIC
-20377 AN ILLEGAL XML CHARACTER ${hex-char} WAS FOUND IN AN SQL/XML EXPR
ESSION OR FUNCTION ARGUMENT THAT BEGINS WITH STRING ${start-string}
-20380 ALTER INDEX WITH REGENERATE OPTION FOR ${index-name} FAILED. INFO
RMATION RETURNED: SQLCODE ${sqlcode}, SQLSTATE ${sqlstate}, MESSAGE TO
KENS ${token-list}
-20381 ALTER INDEX WITH REGENERATE OPTION IS NOT VALID FOR ${index-name}
-20382 CONTEXT ITEM CANNOT BE A SEQUENCE WITH MORE THAN ONE ITEM
-20398 ERROR ENCOUNTERED DURING XML PARSING AT LOCATION ${n} ${text}
-20399 XML PARSING OR VALIDATION ERROR ENCOUNTERED DURING XML SCHEMA VAL
IDATION AT LOCATION ${n} ${text}
-20400 XML SCHEMA ERROR ${n} ${text}
-20409 AN XML DOCUMENT OR CONSTRUCTED XML VALUE CONTAINS A COMBINATION O
F XML NODES THAT CAUSES AN INTERNAL IDENTIFIER LIMIT TO BE EXCEEDED
-20410 THE NUMBER OF CHILDREN NODES OF AN XML NODE IN AN XML VALUE HAS E
XCEEDED THE LIMIT NUMBER OF CHILDREN NODES
-20411 A FETCH CURRENT CONTINUE OPERATION WAS REQUESTED FOR ${cursor-nam
e} BUT THERE IS NO PRESERVED, TRUNCATED DATA TO RETURN
-20412 SERIALIZATION OF AN XML VALUE RESULTED IN CHARACTERS THAT COULD N
OT BE REPRESENTED IN THE TARGET ENCODING
-20422 A CREATE TABLE, OR DECLARE GLOBAL TEMPORARY TABLE STATEMENT FOR $
{table-name} ATTEMPTED TO CREATE A TABLE WITH ALL THE COLUMNS DEFINED
AS HIDDEN
-20433 AN UNTYPED PARAMETER MARKER WAS SPECIFIED, BUT AN ASSUMED DATA TY
PE CANNOT BE DETERMINED FROM ITS USE
-30005 EXECUTION FAILED BECAUSE FUNCTION NOT SUPPORTED BY THE SERVER: LO
CATION ${location} PRODUCT ID ${pppvvrr} REASON ${reason-code} (${sub-
code})
-30020 EXECUTION FAILED DUE TO A DISTRIBUTION PROTOCOL ERROR THAT CAUSED
DEALLOCATION OF THE CONVERSATION: REASON ${reason-code} (${sub-code})
-30025 EXECUTION FAILED BECAUSE FUNCTION IS NOT SUPPORTED BY THE SERVER
WHICH CAUSED TERMINATION OF THE CONNECTION: LOCATION ${location} PRODU
CT ID ${pppvvrr} REASON ${reason-code} (${sub-code})
-30041 EXECUTION FAILED DUE TO UNAVAILABLE RESOURCES THAT WILL AFFECT TH
E SUCCESSFUL EXECUTION OF SUBSEQUENT COMMANDS AND SQL STATEMENTS. REAS
ON ${reason-code} TYPE OF RESOURCE ${resource-type} RESOURCE NAME ${re
source-name} PRODUCT ID ${pppvvrrm} RDBNAME ${rdbname}
-30050 ${command-or-SQL-statement-type} COMMAND OR SQL STATEMENT INVALID
WHILE BIND PROCESS IN PROGRESS
-30081 ${prot} COMMUNICATIONS ERROR DETECTED. API=${api}, LOCATION=${loc
}, FUNCTION=${func}, ERROR CODES=${rc1} ${rc2} ${rc3}
>>>>> sqlCodes V9 >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>*/
}¢--- A540769.WK.REXX(SQLCSM) cre=2016-09-30 mod=2016-09-30-09.58.30 A540769 ---
/* copy sqlCsm begin *************************************************/
sqlConClass_C: procedure expose m.
if m.sqlCsm_ini == 1 then
return m.class_sqlCsmConn
m.sqlCsm_ini = 1
call sqlConClass_R
call csmIni
call classNew 'n SqlCsmRdr u JRW', 'm',
, "jReset m.m.rzDb=arg; m.m.src=arg2; m.m.type=arg(4)" ,
, "jOpen call sqlCsmRdrOpen m, opt",
, "jClose" ,
, "jRead return 0"
return classNew('n SqlCsmConn u', 'm',
, "sqlRdr return oNew(m.class_SqlCsmRdr" ,
", m.sql_conRzDB, src, type)" ,
, "stmts return err('no stmts in sqlCsm')")
endProcedure sqlConClass_C
/*--- send an sql to csm and handle sqlCode -------------------------*/
sqlCsmExe:
parse arg ggRzDb, sql_query, ggRetOk
parse value dsnCsmSys(ggRzDb) with sql_host '/' sql_db2SSID
sql_query = strip(sql_query) /* csmASqls fails on leading spaces */
call csmAppc 'csmASql', , , 4
if sqlCode = 0 then
return 0
ggSqlStmt = sql_query /* for sqlMsg etc. */
if pos('*', ggRetOk) > 0 | wordPos(sqlCode, ggRetOk) > 0 ,
then do
if sqlCode < 0 & pos('say', ggRetOk) > 0 then
call errSay ' }'sqlmsg(sqlCA2Rx(sqlCa))'\nsqlCsmExe' ggRzDb
return sqlCode
end
else if sqlCode < 0 then
call err sqlmsg(sqlCA2rx(sqlCa))'\nsqlCsmExe' ggRzDb
else if pos('w', ggRetOk) < 1 then
if sqlCode = 100 then
call errSay ' }sqlCode +100 row not found\nsql =' ggSqlStmt
else
call errSay 'w}'sqlMsg(sqlCA2rx(sqlCa))'\nsqlCsmExe' ggRzDb
return sqlCode
endProcedure sqlCsmExe
/*--- execute a query from sql, with one resultset ------------------*/
sqlCsmRdrOpen: procedure expose m.
parse arg m, opt
src = sqlRdrOpenSrc(m, opt)
res = sqlCsmExe(m.m.rzDb, src, 100 retOk)
if res < 0 then
return res
if words(m.m.type) = 1 & \ abbrev(m.m.type, ' ') then
cl = class4name(m.m.type)
else if m.m.type <> '' then
cl = classNew('n* SqlCsm u f%v' m.m.type)
else do
vv = ''
do kx=1 to sqlD
vv = sqlNiceVarsApp(vv, SQLDA_REXXNAME.kx)
end
cl = classNew('n* SqlCsm u f%v' vv)
end
ff = classFldD(cl)
if sqlD <> m.ff.0 then
return err('sqlCsmQuery sqlD' sqlD '<>' m.ff.0 'for' ,
className(cl))
do rx=1 to sqlRow#
m.m.buf.rx = m'.BUFD.'rx
call oMutate m'.BUFD.'rx, cl
end
m.m.buf.0 = sqlRow#
do kx=1 to sqlD
rxNa = SQLDA_REXXNAME.kx
do rx=1 to sqlRow#
dst = m'.BUFD.'rx || m.ff.kx
if substr(sqlIndicator.rx, kx ,1) == 'ff'x then
m.dst = m.sqlNull
else
m.dst = value(rxNa'.'rx)
end
end
return 0
endProcedure sqlCsmRdrOpen
/* copy sqlCsm end *************************************************/
}¢--- A540769.WK.REXX(SQLDIV) cre=2016-10-28 mod=2016-10-28-14.01.53 A540769 ---
/* copy sqlDiv begin *************************************************/
/*--- generate the format m for a sql cx as specified in sp
use the information from the sqlDa ------------------------*/
sqlFTabReset: procedure expose m.
parse arg ff, maxCh, maxBlo, maxDe
return sqlFTabOpts(fTabReset(ff, , , '-'), maxCh, maxBlo, maxDe)
/*--- default formats per datatype ----------------------------------*/
sqlFTabOpts: procedure expose m.
parse arg ff, m.ff.maxChar, m.ff.blobMax, m.ff.maxDec
if m.ff.maxChar == '' then
m.ff.maxChar = 32
if m.ff.blobMax == '' then
m.ff.blobMax = 200
bf = '%-'max(m.ff.blobMax, 4)'C'
m.ff.sql2fmt.384 = '%-10C' /* date */
m.ff.sql2fmt.388 = '%-8C' /* time */
m.ff.sql2fmt.392 = '%-26C' /* timestamp */
m.ff.sql2fmt.400 = 'c' /* graphic string */
m.ff.sql2fmt.404 = bf /* BLOB */
m.ff.sql2fmt.408 = bf /* CLOB */
m.ff.sql2fmt.412 = bf /* DBCLOB */
m.ff.sql2fmt.448 = 'c' /* varchar */
m.ff.sql2fmt.452 = 'c' /* char */
m.ff.sql2fmt.452 = 'c' /* long varchar */
m.ff.sql2fmt.460 = 'c' /* null term. string */
m.ff.sql2fmt.464 = 'c' /* graphic varchar */
m.ff.sql2fmt.468 = 'c' /* graphic char */
m.ff.sql2fmt.472 = 'c' /* long graphic varchar */
m.ff.sql2fmt.480 = '%-7e' /* float */
m.ff.sql2fmt.484 = 'd' /* packed decimal */
m.ff.sql2fmt.492 = '%20i' /* bigInt */
m.ff.sql2fmt.496 = '%11i' /* int */
m.ff.sql2fmt.500 = '%6i' /* smallInt */
m.ff.sql2fmt.904 = '%-34H' /* rowID 17 Byte Binary */
return ff
endProcedure sqlFTabOpts
/*--- set a defaultFormat for type tx in fTab ff --------------------*/
sqlFTabDef: procedure expose m.
parse arg ff, tx, m.ff.sql2fmt.tx
return ff
/*--- complete / override column info from sqlCa --------------------*/
sqlFTabComplete: procedure expose m.
parse arg m, cx, aOth, aFmt
if aOth then
call sqlFTabOthers m, cx
f2x = classMet(sqlFetchClass(cx), 'f2x')
do tx=1 to m.m.0
c1 = m.m.tx.col
if symbol('m.m.set.c1') == 'VAR' then do
sx = m.m.set.c1
parse var m.m.set.sx c1 aDone
m.m.tx.done = aDone \== 0
m.m.tx.fmt = m.m.set.sx.fmt
m.m.tx.labelSh = m.m.set.sx.labelSh
end
if symbol('m.f2x.c1') \== 'VAR' then
iterate
kx = m.f2x.c1
if m.m.tx.labelLo = '' then
m.m.tx.labelLo = m.sql.cx.d.kx.sqlName
if m.m.tx.labelSh = '' then
m.m.tx.labelSh = m.sql.cx.d.kx.sqlName
if m.m.tx.fmt <> '' | \ aFmt then
iterate
/* use format for datatype */
ty = m.sql.cx.d.kx.sqlType
ty = ty - ty // 2 /* odd = with null */
le = m.sql.cx.d.kx.sqlLen
if symbol('m.m.sql2fmt.ty') <> 'VAR' then
call err 'sqlType' ty 'col' c1 'not supported'
f1 = m.m.sql2fmt.ty
if f1 == 'c' then
f1 = '%-'min(le, m.m.maxChar)'C'
else if f1 == 'd' then do
pr = m.sql.cx.d.kx.sqlLen.sqlPrecision
sc = m.sql.cx.d.kx.sqlLen.sqlScale
if sc < 1 then
f1 = '%' || (pr + 1) || 'i'
else
f1 = '%' || (pr + 2) || '.'sc'i'
end
if \ abbrev(f1, '%') then
call err 'sqlType' ty 'col' c1 'bad format' f1
m.m.tx.fmt = f1
end
return m
endProcedure sqlFTabComplete
/*--- add all cols of sqlCA to fTab,
that are not yet (witho aDone=0) ----------------------*/
sqlFTabOthers: procedure expose m.
parse arg m, cx
do cy=1 to m.m.0
if m.m.cy.done then do
nm = m.m.cy.col
done.nm = 1
end
end
ff = m.sql.cx.fetchFlds
do kx=1 to m.sql.cx.d.sqlD
c1 = word(ff, kx)
if done.c1 \== 1 then
call ftabAdd m, c1
end
return m
endProcedure sqlFTabOthers
/*--- fetch all rows from cursor cx, tabulate and close crs
opt = a autoformat from data
c column format (each column on separate line)
s silent
o ouput objects
q format by sqlCA ----------------------------------*/
sqlFTab: procedure expose m.
parse arg m, cx
if pos('o', m.m.opt) < 1 then
call sqlFTabComplete m, cx, pos('|', m.m.opt) < 1,
, pos('a', m.m.opt) < 1
if verify(m.m.opt, 'ao', 'm') > 0 then
return fTab(m, sqlQuery2Rdr(cx))
/* fTab would also work in other cases,
however, we do it without sqlQuery2Rdr */
dst = 'SQL_fTab_dst'
if pos('c', m.m.opt) > 0 then do
if pos('c', m.m.generated) < 1 then
call fTabGenCol m
do rx=1 while sqlFetch(cx, dst)
call out left('--- row' rx '', 80, '-')
call fTabCol m, dst
end
call out left('--- end of' (rx-1) 'rows ', 80, '-')
end
else do
call fTabBegin m
do rx=1 while sqlFetch(cx, dst)
call out f(m.m.fmt, dst)
end
call fTabEnd m
end
call sqlClose cx
return m
endProcedure sqlFTab
/*--- create insert statment into table tb
for object m in spufi (72chars) format ---------------------*/
sql4obj: procedure expose m.
parse arg m, tb
call out 'insert into' tb '--' className(objClass(m))
line = ''
ff = oFldD(m)
pr = ' ('
do fx=1 to m.ff.0
call sql4ObjOut substr(m.ff.fx, 2)
end
call sql4ObjOut , 1
call out ' ) values '
pr = ' ('
do fx=1 to m.ff.0
f1 = m || m.ff.fx
v = m.f1 /* no strip T, gives errors in RCM profile | */
if dataType(v, n) then
call sql4ObjOut v
else do qx=1 until v == ''
vx = verify(v, m.ut_alfPrint)
if vx = 0 then do
l1 = min(60, length(v))
w = quote(left(v, l1), "'")
end
else if vx > 29 then do
l1 = min(60, vx-1)
w = quote(left(v, l1), "'")
end
else do
l1 = min(29, length(v))
w = 'x'quote(c2x(left(v, l1)), "'")
end
if qx == 1 then
call sql4ObjOut w
else do
if qx = 2 then
call sql4ObjOut , 1
call out ' ||' w
end
v = substr(v, l1+1)
end
end
call sql4ObjOut , 1
call out ' ) ; '
return
endProcedure
sql4objOut:
parse arg t1, force
if (force == 1 & line \== '') | length(line t1) > 65 then do
call out pr substr(line, 3)
pr = ' ,'
line = ''
end
if force \== 1 then
line = line',' t1
return
endProcedure sql4objOut
/*--- -dis db interface ---------------------------------------------*/
/*--- do one -dis db... and insert it into stem --------------------*/
sqlDisDb: procedure expose m.
parse upper arg o, cc
do cx=1
mid = strip(left(m.cc.cx, 10))
if words(mid) > 1 then
call err 'bad msgId' mid 'line:' m.cc.cx
if mid == '' | wordPos(mid, 'DSNT360I DSNT361I DSNT365I') ,
> 0 then
iterate
if mid == 'DSN9022I' then
if cx = m.cc.0 then
return m.o.0
else
call err 'not at end' cx':' m.cc.cx
if mid \== 'DSNT362I' then
call err 'DSNT362I expected not line:' m.cc.cx
dx = pos('DATABASE =', m.cc.cx)
sx = pos('STATUS =' , m.cc.cx)
if dx < 1 | sx <= dx then
call err 'bad DSNT362I line' cx':' m.cc.cx
db = word(substr(m.cc.cx, dx+10), 1)
sta = strip(substr(m.cc.cx, sx+8))
call sqlDisDbAdd o, db, ,0, 0, 'DB', sta
do cx=cx+1 while abbrev(m.cc.cx, ' ')
end
if abbrev(m.cc.cx, 'DSNT397I ') then do
cx = cx + 1
if \ abbrev(space(m.cc.cx, 1),
, 'NAME TYPE PART STATUS ') then
call err 'NAME TYPE PART STATUS mismatch' cx m.cc.cx
txNa = pos('NAME', m.cc.cx)
txTy = pos('TYPE', m.cc.cx)
txPa = pos('PART', m.cc.cx)
txSt = pos('STAT', m.cc.cx)
txEn = verify(m.cc.cx, ' ', 'n', txSt+6)
if 0 then say 'title' txNa txTy txPa txSt txEn cx m.cc.cx
cx=cx+1
do forever
do while abbrev(m.cc.cx, '----')
cx = cx + 1
end
if abbrev(m.cc.cx, '*') then
leave
parse var m.cc.cx sp =(txTy) ty . =(txPa) paFr . ,
=(txSt) sta =(txEn)
sp = strip(sp)
if words(sp) \= 1 | wordPos(ty, 'TS IX') < 0 then
call err 'bad name or type' cx':'m.cc.cx
if paFr == '' | paFr == 'L*' then
paFr = 0
else if abbrev(paFr, 'D') | abbrev(paFr, 'L') then
paFr = substr(paFr, 2)
if \ datatype(paFr, 'n') then
call err 'part not numeric' cx':'m.cc.cx
paTo = paFr
cw = cx
cx = cx + 1
if abbrev(m.cc.cx, ' -THRU ') then do
parse var m.cc.cx =(txPa) paTo . =(txSt)
if \ datatype(paTo, 'n') then
call err '-thru part not numeric' cx':'m.cc.cx
cx = cx + 1
end
call sqlDisDbAdd o, db, sp, paFr, paTo, ty, sta
end
end
if m.cc.cx = '******** NO SPACES FOUND' then
cx = cx + 1
if abbrev(m.cc.cx, '******* DISPLAY OF DATABASE ') ,
& word(m.cc.cx,5) == db then
if word(m.cc.cx,6) == 'ENDED' then
iterate
else if word(m.cc.cx,6) == 'TERMINATED' then
call err 'db display overflow' cx':' m.cc.cx
call err 'database' db 'ENDED mismatch' cx':' m.cc.cx
end
endProcedure sqlDbDis
/*--- insert one tuple into tDbState --------------------------------*/
sqlDisDbAdd: procedure expose m.
if arg(7) == '' | arg(7) == 'RW' then
return
parse arg o
m.o.0 = m.o.0 + 1
q = o'.'m.o.0
parse arg , m.q.db, m.q.sp, m.q.paFr, m.q.paTo, m.q.ty, m.q.sta
/*say added q m.q.db'.'m.q.sp':'m.q.paFr'-'m.q.paTo m.q.ty':'m.q.sta*/
ky = m.q.db'.'m.q.sp
if symbol('m.o.ky') \== 'VAR' then
m.o.ky = m.o.0
return
endProceedure sqlDisDbAdd
/*--- get index in o for db sp part ---------------------------------*/
sqlDisDbIndex: procedure expose m.
parse arg st, d, s, pa
if symbol('m.st.d.s') \== 'VAR' then
return 0
ix = m.st.d.s
if ix > m.st.0 | d \== m.st.ix.db | s \== m.st.ix.sp then
return 0
if pa == '' then
return ix
do ix=ix to m.st.0 while d == m.st.ix.db & s == m.st.ix.sp
if pa < m.st.ix.paFr then
return 0
else if pa <= m.st.ix.paTo then
return ix
end
return 0
endProcedure sqlDisDbIndex
/*--- dsn Command, return true if continuation needed ---------------*/
sqlDsnCont: procedure expose m.
parse arg cc, ssid, cmd
say '???dsnCont' cmd
cont = sqlDsn(cc, ssid, cmd, 12) <> 0
if cont then do
cz = m.cc.0
cy = cz - 1
if \ abbrev(m.cc.cy, DSNT311I) ,
| \ abbrev(m.cc.cz, 'DSN9023I') then
call err 'sqlDsn rc=12 for' cmd 'out='cz ,
'\n'cy'='m.cc.cy'\n'cz'='m.cc.cz
m.cc.0 = cz-2
end
return cont
endProcedure sqlDsnCont
/* copy sqlDiv end *************************************************/
}¢--- A540769.WK.REXX(SQLO) cre=2016-09-09 mod=2016-09-09-07.55.46 A540769 -----
/* copy sqlO begin **************************************************
sql interface mit o und j Anbindung
**********************************************************************/
sqlConClass_R: procedure expose m.
if m.sqlO_ini == 1 then
return m.class_sqlConn
m.sqlO_ini = 1
call sqlIni
call jIni
/* call scanReadIni */
call classNew 'n SqlRdr u JRW', 'm',
, "jReset m.m.sql = arg; m.m.type = arg2;",
, "jOpen call sqlRdrOpen m, opt",
, "jClose call sqlRdrClose m",
, "jRead if \ sqlRdrRead(m, rStem) then return 0"
call classNew 'n SqlResRdr u JRW', 'm',
, "jReset m.m.cursor = arg; m.m.type = arg2;",
, "jOpen call sqlRdrO2 m" ,
, "jClose call sqlClose m.m.cursor" ,
, "jRead if \ sqlRdrRead(m, rStem) then return 0"
return classNew('n SqlConn u', 'm',
, "sqlRdr return oNew(m.class_SqlRdr, src, type)" ,
, "sqlsOut return err('no stmts/sqlsOut in conClass_R')")
endProcedure sqlConClass_R
/*--- return a new sqlRdr with sqlSrc from src
type is the class for result, if empty generated --------------*/
sqlRdr: procedure expose m.
parse arg srcRdr, type
src = in2str(srcRdr, ' ')
interpret classMet(m.sql_ConCla, 'sqlRdr')
endProcedure sqlRdr
/*--- execute sql query, generate type and fetchList ----------------*/
sqlRdrOpen: procedure expose m.
parse arg m, opt
src = m.m.sql
cx = sqlGetCursor()
m.m.cursor = cx
if words(m.m.type) <> 1 | abbrev(m.m.type, ' ') then do
m.sql.cx.fetchClass = ''
res = sqlQuery(cx, src, m.m.type)
m.m.type = sqlFetchClass(cx)
end
else do
m.m.type = class4name(m.m.type)
res = sqlQuery(cx, src, mCat(classFlds(m.m.type),' '))
m.sql.cx.fetchClass = m.m.type
end
if res >= 0 then
return sqlRdrO2(m)
call sqlFreeCursor cx
return res
endProcedure sqlRdrOpen
sqlRdrOpenSrc: procedure expose m.
parse arg m, opt
if opt\== m.j.cRead then
call err 'opt not' m.j.cRead 'sqlRdrOpenSrc('m',' opt')'
m.m.srcTxt = in2str(m.m.src, ' ')
return m.m.srcTxt
sqlRdrO2: procedure expose m.
parse arg m
cx = m.m.cursor
if m.m.type \== m.sql.cx.fetchClass | m.m.Type == '' then
call err 'type' m.m.type '\==' m.sql.cx.fetchClass 'fetchClass'
m.m.fetchCount = ''
return m
endProcedure sqlRdrO2
/*--- generate class for fetched objects, if necessary --------------*/
sqlFetchClass: procedure expose m.
parse arg cx, force
if m.sql.cx.fetchClass == '' | force == 1 then
m.sql.cx.fetchClass = classNew('n* Sql u f%v' ,
m.sql.cx.fetchFlds)
return m.sql.cx.fetchClass
endProcedure sqlFetchClass
/*--- read next from cursor, return as object -----------------------*/
sqlRdrRead: procedure expose m.
parse arg m, rStem
cx = m.m.cursor
if m.sql.cx.fetchcount \== m.m.bufI0 then
call err cx 'fetchCount='m.sql.cx.fetchcount ,
'<> m'.m'.bufI0='m.m.bufI0
do bx=1 to 10
v = oNew(m.m.type)
if \ sqlFetch(m.m.cursor, v) then do
call mFree v
leave
end
m.rStem.bx = v
end
m.rStem.0 = bx-1
return bx > 1
endProcedure sqlRdrRead
/*--- close sql Cursor ----------------------------------------------*/
sqlRdrClose: procedure expose m.
parse arg m
cx = m.m.cursor
call sqlClose cx
call sqlFreeCursor cx
m.m.cursor = ''
m.m.fetchCount = m.sql.cx.fetchCount
return m
endProcedure sqlRdrClose
sqlQuery2Rdr: procedure expose m.
parse arg cx
r = jReset(oMutate('SQL_RDR.'cx, m.class_SqlResRdr), cx)
m.r.type = sqlFetchClass(cx)
return r
endProcedure sqlQuery2Rdr
/*--- select and write all to stdOut --------------------------------*/
sqlSel: procedure expose m.
parse arg src, type
s = sqlRdr(src, type)
call pipeWriteAll s
return /* do not return fetchCount, writeAll may be delayed| */
endProcedure sqlSel
/* copy sqlO end *************************************************/
}¢--- A540769.WK.REXX(SQLQCSM) cre=2012-04-02 mod=2012-04-02-17.18.23 A540769 ---
/* copy sqlQCsm begin *************************************************/
/*--- execute a query from sql, with one resultset -------------------*/
sqlQuery: procedure expose m.
parse arg cx, src, retOk
return sqlCsmQuery(cx, src, retOk)
/*--- fetch next row to m.dst.* at end return false ------------------*/
sqlFetch: procedure expose m.
parse arg cx, dst, retOk
return sqlCsmFetch(cx, dst)
/*--- close cursor 'c'cx ---------------------------------------------*/
sqlClose: procedure expose m.
parse arg cx, retOk
return 0
/*-- execute an sql with no resultset, but possibly outParms ---------*/
sqlUpdate: procedure expose m.
parse arg cx, src, retOk
return sqlCsmUpdate(cx, src, retOk)
/*-- execute an sql call statement with outParms and several results--*/
sqlCall: procedure expose m.
parse arg cx, src, retOk
return sqlCsmCall(cx, src, retOk)
/* copy sqlQCsm end *************************************************/
}¢--- A540769.WK.REXX(SQLRX) cre=2015-12-15 mod=2015-12-15-17.26.52 A540769 ----
/* copy sqlRx begin ***************************************************
Achtung: inc generiert sql aus sqlRx, Aenderungen nur in sqlRx|
sql interface
***********************************************************************/
/*--- initialize sqlRx -----------------------------------------------*/
sqlRxIni: procedure expose m.
if m.sqlRx_ini == 1 then
return
m.sqlRx_ini = 1
call utIni
m.sqlNull = '---'
m.sqlInd = 'sqlInd'
m.sql_defCurs= 49
m.sqlCAMsg = 0
m.sqlSuMsg = 2
m.sql_dbSys = ''
m.sql_csmhost = ''
isInProd = wordPos(sysvar(sysNode), 'RZ2') > 0
m.sql_retOk = 'dne' copies('rod', \ isInProd)
return 0
endProcedure sqlRxIni
/*--- get default db2System ------------------------------------------*/
sqlDefaultSys: procedure expose m.
parse arg
if sysvar(sysnode) == 'RZ4' then
return 'DP4G'
else if sysvar(sysnode) == 'RZX' then
return 'DX0G'
else
call err 'no default dbSys for' sysvar(sysnode)
endProcedure sqlDefaultSys
/*--- connect to the db2 subsystem sys -----------------------------*/
sqlRxConnect: procedure expose m.
parse upper arg sys, ggRetOk
call sqlIni
address tso "SUBCOM DSNREXX"
if rc <> 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
if sys = '-' then
return 0
if sys == '' then
sys = sqlDefaultSys()
m.sql_dbSys = sys
return sqlExec0('connect' sys)
endProcedure sqlRxConnect
/*--- diconnect from db2 ---------------------------------------------*/
sqlRxDisconnect: procedure expose m.
parse arg retOk
if m.sql_dbSys == '' then
return 0
m.sql_dbSys = ''
m.sql_csmHost = ''
return sqlExec0('disConnect')
endProcedure sqlRxDisconnect
/*--- reset sql cursor 'c'cx fields ----------------------------------*/
sqlReset: procedure expose m.
parse arg cx
m.sql.cx.updateCount = ''
m.sql.cx.resultSet = ''
m.sql.cx.d.sqlD = 'noSqlDA'
m.sql.cx.i.sqlD = 'noDescInp'
m.sql.cx.fetchVars = ''
m.sql.cx.fetchFlds = ''
m.sql.cx.fetchClass = ''
m.sql.cx.type = ''
return
endProcedue sqlReset
/*--- execute a query from sql, with one resultset -------------------*/
sqlRxQuery: procedure expose m.
parse arg cx, src, feVa, retOk
call sqlReset cx
s1 = ''
if pos(left(feVa, 1), '?:') < 1 then
s1 = 'into :M.SQL.'cx'.D'
res = sqlExec('prepare s'cx s1 'from :src', retOk)
if res < 0 then
return res
call sqlRxFetchVars cx, feVa
call sqlExec 'declare c'cx 'cursor for s'cx
res = sqlExec('open c'cx, retOk)
if res < 0 then
return res
m.sql.cx.updateCount = sqlErrd.3
m.sql.cx.resultSet = cx
return res
endProcedure sqlRxQuery
/*--- prepare a query from sql, with one resultset -------------------*/
sqlQueryPrepare: procedure expose m.
parse arg cx, src, feVa, retOk
call sqlReset cx
s1 = ''
if feVa == '' | feVa = 'd' then
s1 = 'into :M.SQL.'cx'.D'
res = sqlExec('prepare s'cx s1 'from :src', retOk)
if res < 0 then
return res
call sqlRxFetchVars cx, feVa
call sqlExec 'declare c'cx 'cursor for s'cx
return sqlExec('describe input s'cx 'into :M.SQL.'cx'.I')
endProcedure sqlQueryPrepare
sqlQueryExecute: procedure expose m.
parse arg cx retOk
do ix=1 to arg()-1
call sqlDASet cx , 'I', ix, arg(ix+1)
end
res = sqlExec('open c'cx 'using descriptor :M.SQL.'cx'.I', retOk)
if res < 0 then
return res
m.sql.cx.updateCount = sqlErrd.3
m.sql.cx.resultSet = cx
return res
endProcedure sqlQueryExecute
/*--- fetch next row to m.dst.* at end return false ------------------*/
sqlRxFetch: procedure expose m.
parse arg cx, dst, retOk
fetCode = sqlExec('fetch c'cx 'into' m.sql.cx.fetchVars, 100 retOk)
if fetCode == 100 then
return 0
if fetCode < 0 then
return fetCode
interpret m.sql.cx.fetchCode
return 1
endProcedure sqlRxFetch
/*--- close cursor 'c'cx ---------------------------------------------*/
sqlRxClose: procedure expose m.
parse arg cx, retOk
return sqlExec('close c'cx, retOk)
endProcedure sqlRxClose
/*-- execute an sql with no resultset, but possibly outParms ---------*/
sqlRxUpdate: procedure expose m.
parse arg cx, src, retOk
m.sql.cx.updateCount = ''
m.sql.cx.resultSet = ''
bx = verify(src, '( ')
if bx > 0 then
fun = translate(word(substr(src, bx), 1))
if fun = 'SET' then do
w2 = translate(word(substr(src, bx), 2))
if \ abbrev(w2, ':') then
return sqlExec('execute immediate :src', retOk)
trace ?r
ex = pos('=', w2)
if ex = 0 then
ex = length(w2)+1
var = strip(substr(w2, 2, ex-2))
if var = '' then
call err 'bad hostVar in' src
m.sql.outVar = var
src2 = 'set :M.sql.out.'var substr(w, ex) subword(src, 3)
return sqlExec(src2, retOk)
end
if fun == 'DECLARE' then do
if 'GLOBAL' == translate(word(substr(src, bx), 2)) then
return sqlExec('execute immediate :src', retOk)
end
res = sqlExec(src, retOk)
if wordPos(fun, 'DELETE INSERT UPDATE') > 0 then
m.sql.cx.updateCount = sqlErrd.3
return res
endProcedure sqlRxUpdate
/*-- prepare an update -----------------------------------------------*/
sqlUpdatePrepare: procedure expose m.
parse arg cx, src, retOk
res = sqlExec('prepare s'cx 'from :src', retOk)
return sqlExec('describe input s'cx 'into :M.SQL.'cx'.I')
endProcedure sqlUpdatePrepare
/*-- execute a prepared update with the given arguments --------------*/
sqlUpdateExecute: procedure expose m.
parse arg cx retOk
do ix=1 to arg()-1
call sqlDASet cx , 'I', ix, arg(ix+1)
end
res = sqlExec('execute s'cx 'using descriptor :M.SQL.'cx'.I',
, retOk)
m.sql.cx.updateCount = sqlErrd.3
return res
endProcedure sqlUpdateExecute
/*-- execute a query, update or call ---------------------------------*/
sqlExecute: procedure expose m.
parse arg cx, src, retOk
f = translate(word(src, 1))
bx = pos('(', f)
if bx > 0 then
f = left(f, max(1, bx-1))
m.sql.cx.fun = f
if f == 'SELECT' | f == 'WITH' | f == '(' then
return sqlQuery(cx, src, , retOk)
else if f == 'CALL' then
call err 'implement sql call for:' src
else
return sqlUpdate(cx, src, retOk)
endProcedure sqlExecute
/*-- fetch all rows to stem and close --------------------------------*/
sqlFetch2St: procedure expose m.
parse arg cx, dst, retOK
do sx=1 while sqlFetch(cx, dst'.'sx)
end
res = sx-1
m.dst.0 = sx-1
call sqlClose cx
return m.dst.0
endProcedure sqlFetch2St
/*-- execute a query, copy result to stem ----------------------------*/
sql2St: procedure expose m.
parse arg src, dst, feVa, retOK
cx = m.sql_defCurs
res = sqlQuery(cx, src, feVa, retOk)
return sqlFetch2St(cx, dst, retOk)
endProcedure sql2St
/*-- return first column of the only row and close -------------------*/
sqlFetch2One: procedure expose m.
parse arg cx, dst, retNone
f1 = sqlFetch(cx, dst)
if f1 then
f2 = sqlFetch(cx, dst'.2')
call sqlClose cx
if \ f1 then
if retNone \== '' then
return substr(retNone, 2)
else
call err 'sqlFetch2One: no row returned'
else if f2 then
call err 'sqlFetch2One: more than 1 row'
if m.sql.cx.fetchFlds == '' then do
c1 = substr(word(m.sql.cx.fetchVars, 1), 2)
res = value(c1)
return res
end
c1 = word(m.sql.cx.fetchFlds, 1)
return m.dst.c1
endProcedure sqlFetch2One
/*-- execute a query and return first column of the only row
if > 1 row fail, if 0 rows return arg(3) or fail ----------*/
sql2One: procedure expose m.
parse arg src, dst, feVa, retOk, retNone
cx = m.sql_defCurs
call sqlQuery cx, src, feVa, retOk
return sqlFetch2One(cx, dst, retNone)
endProcedure sql2One
/*--- describe table and return sqlDA --------------------------------*/
sqlDescribeTable: procedure expose m.
parse upper arg tb, force
if force == 1 | \ datatype(m.sql.table.tb.sqlD, 'n') then
call sqlExec 'describe table :tb into :M.SQL.TABLE.'tb
return 'SQL.TABLE.'tb
endProcedure sqlDescribeTable
/*--- return select column list for table tb
omit Blobs (blobMax < 0) or substr(blob, 1, blobMax) ----------*/
sqlColList: procedure expose m.
parse arg tb al, blobMax
sd = sqlDescribeTable(tb)
bs = ''
lst = ''
if al \== '' & right(al, 1) \== '.' then
al = al'.'
do sx=1 to m.sd.sqld
if wordPos(m.sd.sx.sqlType, '404 405 408 409 412 413') < 1 then
lst = lst',' al || m.sd.sx.sqlName
else do
bs = bs m.sd.sx.sqlName
if blobMax >= 0 then
lst = lst', length('al || m.sd.sx.sqlName')' ,
m.sd.sx.sqlName'Len' ,
|| ', substr('al || m.sd.sx.sqlName ,
|| ', 1,' blobMax')' m.sd.sx.sqlName
end
end
m.sd.colList = substr(lst, 3)
m.sd.blobs = strip(bs)
return substr(lst, 3)
endProcedure sqlColList
/*--- use describe output to generate column names,
'' use names from ca (rexxified)
nms+ use names, check ca for null values
?('?'?nm)+ use names, check for null if preceeded by ?
:... use string as is
fetchVariables and sqlNull names ---------------------*/
sqlRxFetchVars: procedure expose m.
parse arg cx, src, cd
st = 'SQL.'cx'.COL'
if abbrev(src, ':') then do
m.sql.cx.fetchVars = src
m.sql.cx.fetchCode = cd
m.sql.cx.fetchFlds = ''
return
end
m.sql.cx.fetchVars = ''
if abbrev(src, '?') then do
call err implement + rxFetchVars ?????? /*
r = substr(src, 2)
do wx=1 to words(src)
cn = word(src, wx)
if abbrev(cn, '?') then
call sqlRexxAddVar substr(cn, 2), 0, 1
else
call sqlRexxAddVar cn, 0, 0
end ????????????? */
end
else if src <> '' then do
ff = src
end
else do
ff = ''
do kx=1 to m.sql.cx.d.sqlD
ff = sqlNiceVarsAdd(ff, m.sql.cx.d.kx.sqlName)
end
end
m.sql.cx.fetchFlds = ff
if m.sql.cx.d.sqlD <> words(ff) then
call err 'sqlRxFetchVars sqlD='m.sql.cx.d.sqlD ,
'<>' words(ff) 'fields of' ff
sNu = ''
sFe = ''
do kx=1 to m.sql.cx.d.sqlD
nm = word(ff, kx)
sFe = sFe', :m.dst.'nm
if m.sql.cx.d.kx.sqlType // 2 then do
sFe = sFe' :m.dst.'nm'.sqlInd'
sNu = sNu 'if m.dst.'nm'.sqlInd < 0 then' ,
'm.dst.'nm '= m.sqlNull;'
end
end
m.sql.cx.fetchVars = substr(sFe, 3)
m.sql.cx.fetchCode = sNu cd
return
endProcedure sqlRxFetchVars
/* ????????????
sqlRexxAddVar:
parse arg nm, nicify, hasNulls
nm = sqlAddVar(st, nm, nicify)
if \ hasNulls then
vrs = vrs', :m.dst.'nm
else do
vrs = vrs', :m.dst.'nm ':m.dst.'nm'.sqlInd'
sNu = sNu 'if m.dst.'nm'.sqlInd < 0 then' ,
'm.dst.'nm '= m.sqlNull;'
end
return
endSubroutine sqlRexxAddVar ?????? */
sqlNiceVarsAdd: procedure expose m.
parse arg old, nx rest
upper nx
cx = verifId(nx)
if cx > 0 then /* avoid bad characters for classNew| */
nx = left(nx, cx-1)
if nx <> '' & wordPos(nx, old) < 1 0 then
return old nx
else
return old 'COL' || (words(old) + 1)
endProcedure sqlNiceVarsAdd
/*--- set one value in a DA, handle nulls ----------------------------*/
sqlDASet: procedure expose m.
parse arg cx, da, ix, val
m.sql.cx.da.ix.sqlData = val
m.sql.cx.da.ix.sqlInd = - (val == m.sqlNull)
/* data types schienen einmal nicht zu funktionieren .......
if wordPos(m.da.ix.sqlType, '384 385 388 389 392 393') > 0 then
m.da.ix.sqlType = 448 + (m.da.ix.sqlType // 2) */
return
endProcedure sqlDASet
sqlCommit: procedure expose m.
parse arg src
return sqlUpdate(, 'commit')
endProcedure sqlCommit
/*--- execute sql thru the dsnRexx interface ------------------------*/
sqlExec: /* no procedure, to keep variables sql... */
parse arg ggSqlStmt, ggSqlRet0
m.sql_HaHi = ''
do forever
address dsnRexx 'EXECSQL' ggSqlStmt
if rc == 0 & sqlCode == 0 & sqlWarn.0 == ' ' then
return 0
if \ dataType(sqlCode, 'n') | abs(rc) \== 1 then
return err('dsnRexx rc='rc sqlMsg())
/* if pos('-', retOK) < 1 then ?????? */
ggSqlRet = ggSqlRet0 m.sql_retOk
if pos('*', ggSqlRet) >0 | wordPos(sqlCode, ggSqlRet) >0 then do
if sqlCode < 0 & pos('say', ggSqlRet) > 0 then
call outNl errMsg(' }'sqlMsg())
return sqlCode
end
if sqlCode >= 0 then do
if (sqlCode > 0 | sqlWarn.0 \== ' ') ,
& pos('w', ggSqlRet) < 1 then
call outNl errMsg(' }'sqlMsg())
return sqlCode
end
if translate(word(ggSqlStmt, 1)) == 'DROP' then do
if (sqlCode == -204 | sqlCode == -458) ,
& wordPos('dne', ggSqlRet) > 0 then
return sqlCode
if sqlCode = -672 & wordPos('rod', ggSqlRet) > 0 ,
& length(m.sql_hahi) < 1000 then do
m.sql_hahi = m.sql_HaHi || sqlMsgLine(sqlCode,
, 'tb='sqlErrMc ,ggSqlStmt)'\n'
m.sql_hahi = m.sql_HaHi || sqlExecHaHi('alter table' ,
SqlErrMc 'drop restrict on drop')'\n'
iterate
end
end
ggSqlEE = ''
if wordPos('rb', ggSqlRet) > 0 then
ggSqlEE = '\n'sqlExecHaHi('rollback')
if wordPos('ret', ggSqlRet) < 1 then do
call err m.sql_hahi || sqlMsg() || ggSqlEE
return sqlCode
end
m.sql_errRet = 1
call outNl errMsg(' }'m.sql_haHi || sqlMsg() || ggSqlEE)
return sqlCode
end
endProcedure sqlExec
/*--- execute sql thru the dsnRexx interface fail if sqlcode <> 0 ---*/
sqlExec0: procedure expose m.
parse arg ggSqlStmt, ePlus
address dsnRexx ggSqlStmt
if rc == 0 & sqlCode == 0 & sqlWarn.0 == ' ' then
return 0
if \ dataType(sqlCode, 'n') | abs(rc) \== 1 then
ePlus = strip(ePlus 'dsnRexx rc='rc'\n')
return err(ePlus || sqlMsg())
endProcedure sqlExec0
/*--- execute sql fail or return msgLine ----------------------------*/
sqlExecHaHi: procedure expose m.
parse arg ggSqlStmt
return sqlMsgLine(sqlExec0('execSql' ggSqlStmt, m.sql_hahi) ,
, , ggSqlStmt)
endProcedure sqlExechaHi
sqlMsgLine: procedure expose m. sqlErrD.
parse arg res, cnt, src, plus
verb = translate(word(src, 1))
if datatype(res, 'n') then
res = 'sqlCode' res
if cnt \== '' then do
res = res',' cnt
vx = wordPos(translate(word(src,1)), 'DELETE INSERT UPDATE')
if datatype(cnt, 'n') then
if vx > 0 then
res = res 'rows' word('deleted inserted updated', vx)
else if cnt <> 0 then
res = res 'rows updated'
end
if plus \== '' then
res = res',' plus
if abbrev(res, ', ') then
res = substr(res, 3)
if src \== '' then do
ll = 75 - length(res)
aa = strip(src)
if length(aa) > ll then
aa = space(aa, 1)
if length(aa) > ll then
aa = left(aa, ll-3)'...'
res = res':' aa
end
return res
endProcedure sqlMsgLine
/*--- send a command to db2 through the TSO dsn processor ------------*/
sqlDsn: procedure expose m.
parse arg st, sys, cmd, rcOk
x = outtrap('M.'st'.')
push 'END'
push cmd
address tso 'DSN SYSTEM('sys')'
rr = rc
x = outtrap(off)
if rr = 0 | rcOk = '*' | wordPos(rr, rcOk) > 0 then
return rr
fl = max(1, m.st.0 - 10)
em = 'rc' rr 'for DSN SYSTEM('sys') cmd' cmd,
'\nOuputlines' fl '-' m.st.0':'
do lx=fl to m.st.0
em = em '\n' strip(m.st.lx, 't')
end
call err em
endProcedure sqlDsn
/*--- issue an sql error message -------------------------------------*/
sqlMsg: /* no procedure, to keep variables sql... */
if \ dataType(sqlCode, 'n') then do
ggRes = 'sqlCode' sqlCode 'not numeric\n'sqlCaMsg()
end
else do
ggRes = sqlDsntiar(sqlRx2CA())
ggWa = sqlMsgWarn()
if ggWa \= '' then
ggRes = ggRes'\nwarnings' ggWa
if m.sqlCAMsg == 1 then
ggRes = ggRes'\n'sqlCaMsg()
end
ggSt = 'SQL_HOST'
ggVa = 'SQL_HOST.VAR'
ggBe = 'SQL_HOST.BEF'
call sqlHostVars ggSqlStmt, 12, ggSt
ggFrom = 'ggSqlStmt'
ggW1 = translate(word(ggSqlStmt, 1))
ggW2 = translate(word(ggSqlStmt, 2))
if ggW1 == 'PREPARE' then
ggFrom = sqlHostVarFind(ggSt, 'FROM')
else if ggW1 ggW2 == 'EXECUTE IMMEDIATE' then
ggFrom = sqlHostVarFind(ggSt, 1)
ggPos = 0
if datatype(sqlErrd.5, 'n') & sqlErrd.5 > 0 then do
ggPos = sqlErrd.5
ggRes = ggRes || sqlMsgSrcPos(value(ggFrom), sqlErrd.5)
end
if ggFrom == 'ggSqlStmt' then do
ggRes = ggRes'\nsql =' sqlShorten(ggSqlStmt, 2000, ggPos)
end
else do
ggRes = ggRes'\nsql =' sqlShorten(value(ggFrom), 2000, ggPos)
ggRes = ggRes'\nstmt =' sqlShorten(ggSqlStmt, 2000)
end
ggPref = '\nwith'
do ggXX=1 to m.ggSt.0
if ggFrom = m.ggVa.ggXX then
iterate
ggRes = ggRes || ggPref m.ggBe.ggXX ':'m.ggVa.ggXX ,
'=' sqlShorten(value(m.ggVa.ggXX), 210)
ggPref = '\n '
end
if m.sqlSuMsg == 1 | (m.sqlSuMsg == 2 & m.sql_csmhost \== '') then
ggRes = ggRes'\nsubsys =' m.sql_dbSys ,
|| ', host =' m.sql_csmhost
return ggRes
endSubroutine sqlMsg
sqlShorten: procedure expose m.
parse arg txt, maxL, pos
if length(txt) <= maxL then
return txt
if \ datatype(pos, 'n') | pos < 1 then
pos = 1
ex = pos + min(60, maxL%7)
if ex <= maxL - 4 then
return left(txt, maxL-4) '...'
if ex >= length(txt) then
return left(txt, 67) '...\n'substr(txt, length(txt)-maxL+72)
else
return left(txt, 67) '...\n'substr(txt, ex-maxL+76, maxL-75) ,
'...'
endProcedure sqlShorten
/*--- use dsnTiar to translate sql Info to error text ----------------*/
sqlDsnTiar: procedure expose m.
parse arg ca
if -438 = sqlCa2Rx(ca) then
return '\nSQLCODE = -438:',
'APPLICATION RAISED ERROR WITH sqlState' sqlState ,
'and DIAGNOSTIC TEXT:' sqlErrMc
liLe = 78
msLe = liLe * 10
msg = d2c(msLe,2) || left('', msLe)
len = d2c(liLe, 4)
ADDRESS LINKPGM "DSNTIAR ca msg len"
if rc = 0 then nop
else if rc = 4 then say 'warn linkPgm dsnTiar rc' rc 'sqlCa' ca
else call err 'linkPgm dsnTiar rc' rc 'sqlCa' ca
res = strip(substr(msg, 13, liLe-10))
cx = pos(', ERROR: ', res)
if cx > 0 then
res = left(res, cx-1)':' strip(substr(res, cx+9))
do c=3+liLe by liLe to msLe while substr(msg, c, 10) = ''
res = res'\n 'strip(substr(msg, c+10, liLe-10))
end
return res
endProcedure sqlDsnTiar
/*--- format all rexx sqlCa fields into a message --------------------*/
sqlCaMsg:
return 'sqlCode' sqlCode 'sqlState='sqlState ,
'\n errMC='translate(sqlErrMc, ',', 'ff'x) ,
'\n warnings='sqlWarnCat('+') 'erP='sqlErrP ,
'\n errD.1='sqlErrD.1 '2='sqlErrD.2 '3='sqlErrD.3 ,
'\n errD.4='sqlErrD.4 '5='sqlErrD.5 '6='sqlErrD.6
endProcedure sqlCaMsg
/*--- concat the sql warnings with Separator sep --------------------*/
sqlWarnCat: procedure expose m. sqlWarn.
parse arg sep
return sqlWarn.0 || sep,
|| sqlWarn.1||sqlWarn.2||sqlWarn.3||sqlWarn.4||sqlWarn.5||sep ,
|| sqlWarn.6||sqlWarn.7||sqlWarn.8||sqlWarn.9||sqlWarn.10||sep
endProcedure sqlWarnCat
/*--- format the sqlCA into the dsnTiar SQLCA ------------------------*/
sqlRx2Ca: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
if \ (datatype(sqlcode, 'n') & datatype(sqlErrD.1, 'n') ,
& datatype(sqlErrD.3, 'n')) then
return err('sqlCode etc. not numeric\nsqlCa =' sqlCaMsg())
if digits() < 10 then
numeric digits 10
sqlCa = 'SQLCA ' || d2c(136, 4) || d2c(sqlCode, 4) ,
|| d2c(min(70, length(sqlErrMc)), 2)left(sqlErrMc, 70) ,
|| left(sqlErrP, 8) ,
|| d2c(sqlErrD.1, 4)d2c(sqlErrD.2, 4)d2c(sqlErrD.3, 4) ,
|| d2c(sqlErrD.4, 4)d2c(sqlErrD.5, 4)d2c(sqlErrD.6, 4) ,
|| sqlWarnCat() || sqlState
if length(sqlCa) <> 136 then
call err 'sqlCa length' length(sqlCa) 'not 136' ,
'\n'sqlCaMsg() '==>' ca', hex='c2x(ca)
return sqlCa
endProcedure sqlRx2Ca
/*--- extract the fields from the SqlCA and put it to rexx vars ------*/
sqlCA2Rx: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
parse arg ca
numeric digits 10
if length(ca) < 136 | c2d(substr(ca, 9, 4), 4) <> 136 then
call err 'bad sqlCa len' length(ca) 'not 136:' ca', hex='c2x(ca)
sqlCode = c2d(substr(ca, 13 ,4), 4)
sqlErrMC = substr(ca, 19, c2d(substr(ca, 17, 2), 2))
sqlErrP = substr(ca, 89, 8)
do ix=1 to 6
sqlErrD.ix = c2d(substr(ca, 93 + 4 * ix, 4), 4)
end
do ix=0 to 10
sqlWarn.ix = substr(ca, 121 + ix, 1)
end
sqlState = substr(ca, 132, 5)
return sqlCode
endProcedure sqlCA2Rx
/*--- make the text for sqlWarnings ----------------------------------*/
sqlMsgWarn: procedure expose m. sqlWarn.
r = ''
text =' 1=W var truncated, 1=S scrollable, 1=N nonScrollable,' ,
'2=W nulls in aggregate,' ,
'3=W more cols than vars,' ,
'3=Z more result sets than locators,' ,
'4=W no where, 4=D sensitive dynamic, 4=I insensitive,' ,
'4=S sensitive static,' ,
'5=W not valid sql, 5=1 readOnly, 5=2 readDelete,' ,
'5=3 readDeleteUpdate,' ,
'6=W day changed to month range,' ,
'7=W dec digits truncated,' ,
'8=W char substituted,' ,
'9=W arith excep in count, 9=Z multipe result sets,' ,
'10=W char conversion err in ca,'
do wx = 1 to 10
w = sqlWarn.wx
if w = ' ' then
iterate
t = wx'='w
cx = pos(' 'wx'='w' ', text)
ex = pos(',' , text, cx + 1)
if cx > 0 & ex > cx then
r = r substr(text, cx+1, ex-cx)
else
r = r wx'='w '?,'
end
r = strip(r, 't', ',')
if r = '' & sqlwarn.0 <> '' then
call err 'sqlWarn.0='sqlWarn.0 'but all warns empty'
return r
endProcedure sqlMsgWarn
/*--- show in the source src the point pos (where error occured)
a few lines from src around pos and arrow to pos ----------*/
sqlMsgSrcPos: procedure expose m.
parse arg src, pos
liLe = 68
liCn = 3
afLe = 25
t1 = space(left(src, pos), 1)
t2 = left(' ', substr(src, pos, 1) == ' ' ,
| substr(src, pos+1, 1) == ' ') ,
|| space(substr(src, pos+1), 1)
afLe = min(afLe, length(t2))
if length(t1) + afLe > liLe * liCn then
t1 = '...'right(t1, liLe * liCn - afLe -3)
else if length(t1)+length(t2) > liLe then
t1 = left(' ', (liCn * liLe - length(t1) -afLe) // liLe)||t1
pL = length(t1) // liLe
if length(t2) <= liLe-pL then
tx = t1 || t2
else
tx = t1 || left(t2, liLe-pL-3)'...'
res = '\nsrc' strip(substr(tx, 1, liLe), 't')
do cx=1+liLe by liLe to length(tx)
res = res || '\n +' strip(substr(tx, cx, liLe), 't')
end
loc = 'pos' pos 'of' length(src)
if length(loc)+6 < pL then
return res'\n >' right('>>>'loc'>>>', pL)
else
return res'\n >' left('', pL-1)'<<<'loc'<<<'
endProcdedure sqlMsgSrcPos
/*--- get the hostVars in the sql in src and the word before ---------*/
sqlHostVars: procedure expose m.
parse arg src, cnt, st
cx = 1
sx = 1
do cnt
cx = pos(':', src, cx) + 1
if cx < 2 then
leave
if pos(substr(src, cx, 1), m.ut_rxN1) > 0 then
iterate
ex = verify(src, m.ut_rxDot, 'n', cx)
if ex < 1 then
m.st.var.sx = substr(src, cx)
else
m.st.var.sx = substr(src, cx, ex - cx)
if m.st.var.sx == '' | length(m.st.var.sx) > 100 then
iterate
/* search word before */
do bE = cx-2 by -1 to 1 ,
while substr(src, bE, 1) == ' '
end
do bB = bE by -1 to max(1, bE-20),
while pos(substr(src, bB, 1), m.ut_alfa) > 0
end
if bB < bE & bB >= 0 then
m.st.bef.sx = substr(src, bB+1, bE-bB)
else
m.st.bef.sx = ''
sx = sx + 1
end
m.st.0 = sx-1
return sx
endProcedure sqlHostVars
/*--- find the name of hostvar, by index or by before ----------------*/
sqlHostVarFind: procedure expose m.
parse arg st, fnd
if datatype(fnd, 'n') & fnd <= m.st.0 then
return m.st.var.fnd
do ix=1 to m.st.0
if translate(m.st.bef.ix) = fnd then
return m.st.var.ix
end
return ''
endSubroutine sqlHostVarFind
/* copy sqlRx end **************************************************/
}¢--- A540769.WK.REXX(SQLS) cre=2016-10-28 mod=2016-10-28-14.01.53 A540769 -----
/* copy sqlS begin **************************************************
sqlStmts **********************************************/
sqlConClass_S: procedure expose m.
if m.sqlS_ini == 1 then
return m.class_SqlConnS
m.sqlS_ini = 1
call sqlConClass_R
call scanWinIni
return classNew('n SqlConnS u SqlConn', 'm',
, "sqlsOut return sqlsOutSql(rdr, retOk, ft)")
endProcedure sqlConClass_S
/*** execute sql's in a stream (separated by ;) and output as tab */
sqlStmts: procedure expose m.
parse arg sqlSrc, retOk, wOpt, sOpt, fOpt
return sqlsOut(scanSqlStmtRdr(sqlSrc, wOpt, sOpt), retOk, fOpt)
endProcedure sqlStmts
/*--- output sql as table -------------------------------------------*/
sql2tab: procedure expose m.
parse arg src, retOk, ft
cx = m.sql_defCurs
if ft == '' then
ft = sqlFTabOpts(fTabReset('SQL.'cx'.2Tab', 'c 1','1 c' , '-'))
else if objClass(ft) == m.class_s then
ft = sqlFTabOpts(fTabReset('SQL.'cx'.2Tab', 'c 1','1 c','-'ft))
call sqlQuery cx, in2str(src, ' '), retOk
call sqlFTab ft, cx
return
endProcedure sql2tab
/*--- result of each sql read from rdr to out
oo='a' autoTab, 't'=sqlTab, 'o'=object, 'c'=csv ----------*/
sqlsOut: procedure expose m.
parse arg rdr, retOk, ft
if ft = '' then
ft = sqlFTabOpts(fTabReset(sql_outFTab, 'c 1', , 'a'))
else if objClass(ft) == m.class_s then
ft = sqlFTabOpts(fTabReset(sql_outFTab, 'c 1', , ft))
interpret classMet(m.sql_ConCla, 'sqlsOut')
sqlsOutSql: procedure expose m.
parse arg rdr, retOk, ft
m.sql_errRet = 0
cx = m.sql_defCurs
r = jOpen(in2file(rdr), '<')
do while jRead(r)
sqlC = sqlExecute(cx, m.r, retOk)
if m.sql_errRet then
leave
if m.sql.cx.resultSet == '' | m.sql.cx.fun == 'CALL' then
if m.ft.verbose then
call outNl(m.sql_HaHi ,
|| sqlMsgLine(sqlC, m.sql.cx.updateCount, m.r))
if m.sql.cx.resultSet == '' then
iterate
do until \ sqlNextResultSet(cx) | m.sql_errRet
m.sql.cx.sqlClosed = 0
call sqlFTab fTabResetCols(ft), cx
if m.ft.verbose & m.sql.cx.sqlClosed then/* sql finished*/
call out sqlMsgLine(m.sql.cx.fetchCount ,
'rows fetched', , m.r)
end
end
call jClose r
if m.sql_errRet then do
call sqlClose cx, '*'
say 'sqlsOut terminating because of sql error'
end
return \ m.sql_errRet
endProcedure sqlsOutSql
/*--- sql hook ------------------------------------------------------
hook paramter db | windowSpec | db? , windowSpec? , fTabOpt?
db: dbSys, rz/dbSysAbkürzung, 1 oder 2 chars
windowSpec: 0 = variable len, 123 = window123
default spufi = window72 ---------------------*/
wshHook_S: procedure expose m.
parse arg m, spec
parse var spec ki 2 rest
call errSetSayOut 'so'
if ki == '/' then do
inp = m.m.in
end
else do
call compIni
if pos(ki, m.comp_chKind) <= 0 then do
ki = '='
rest = spec
end
inp = wshCompile(m, ki)
end
if pos('@',rest)>0 then call err 'was ist das??????' spec
if words(rest)==1 & (datatype(rest, 'n') | pos('@',rest)>0) then
rest = ','rest
parse var rest dbSy ',' wOpt ',' fOpt
d2 = ii2rzDb(dbSy, 1)
call sqlConnect d2
m.m.info = 'runSQL'
if \ sqlStmts(inp, 'rb ret', strip(wOpt), , strip(fOpt)) then do
m.m.end = 1
m.m.exitCC = 8
end
call sqlDisConnect
return ''
endProcedure wshHook_s
/*--- wshHook for sqlRdr read from dd wsh --------------------------*/
wshHook_sqlRdr: procedure expose m.
parse arg m, dbSys
call errSetSayOut 'so'
call sqlIni
m.sql_retOk = m.sql_retOk 'rb ret'
m.sql_errRet = 0
call sqlConnect dbSys
if \ m.sql_errRet then
r = sqlRdr(m.m.in)
if \ m.sql_errRet then
call jOpen r, '<'
if \ m.sql_errRet then do
call pipeWriteAll r
call jClose r
end
if m.sql_errRet then do
call out 'from' sysvar(sysnode) mvsVar(sysName) m.sql_ConRzdb
m.m.end = 1
m.m.exitCC = 4
end
/* else
call out sqlMsgLine(m.r.bufI0 'rows fetched', , m.r.srcTxt) */
call sqlDisConnect
return ''
endProcedure wshHook_sqlRdr
/*--- wshHook for sqlsOut read from dd wsh --------------------------*/
wshHook_sqlsOut: procedure expose m.
parse arg m, dbSys oo retOk
call errSetSayOut 'so'
call sqlIni
m.sql_retOk = m.sql_retOk 'rb ret'
m.sql_errRet = 0
call sqlConnect dbSys
if oo == 'a' | oo == 't' then do
myOut = m.j.out
m.myOut.truncOk = 1
end
if \ m.sql_errRet then
call sqlsOut m.m.in, retOk, oo
if m.sql_errRet then do
call out 'from' sysvar(sysnode) mvsVar(sysName) m.sql_ConRzdb
m.m.end = 1
m.m.exitCC = 4
end
call sqlDisConnect
return ''
endProcedure wshHook_sqlsOut
/* copy sqlS end *************************************************/
}¢--- A540769.WK.REXX(SQLWSH) cre=2016-09-09 mod=2016-09-09-07.55.46 A540769 ---
/* copy sqlWsh begin **************************************************
remote SQL using csmExWsh ************************************/
sqlConClass_w: procedure expose m.
if m.sqlWsh_ini == 1 then
return m.class_SqlWshConn
m.sqlWsh_ini = 1
call sqlConClass_S
call csmIni
call classNew 'n SqlWshRdr u CsmExWsh', 'm',
, "jReset call jReset0 m; m.m.rdr = jBuf()" ,
"; m.m.rzDb=arg; m.m.sql = arg2;m.m.type= arg(3)" ,
, "jOpen call sqlWshRdrOpen m, opt"
return classNew('n SqlWshConn u', 'm',
, "sqlRdr return oNew(m.class_sqlWshRdr, m.sql_conRzDb" ,
", src, type)" ,
, "sqlsOut return sqlWshOut(rdr,m.sql_conRzDB,retOk,m.ft.opt)")
endProcedure sqlConClass_w
/*--- send an sql to csm and handle sqlCode -------------------------*/
sqlWshRdrOpen: procedure expose m.
parse arg m, oOpt
r = m.m.rdr
m.r.buf.0 = 1
m.r.buf.1 = m.m.sql
parse var m.m.RzDb m.m.rz '/' dbSys
m.m.wOpt = 'e sqlRdr' dbSys
call csmExWshOpen m, oOpt
d = m.m.deleg
em = ''
do while jRead(d)
if objClass(m.d) \== m.class_S then do
m.d.readIx = m.d.readIx - 1
leave
end
em = em'\n'm.d
end
if em == '' then
return m
call jClose m.m.deleg
return err('sqlWshRdr got' substr(em, 3))
endProcedure sqlWshRdrOpen
/*--- send an sql to csm and handle sqlCode -------------------------*/
sqlWshOut: procedure expose m.
parse arg rdr, rzDb, retOk, oo
parse value dsnCsmSys(rzDb) with rz '/' dbSys
if pos('o', oo) > 0 then
spec = 'e sqlsOut'
else
spec = 'v' || (m.wsh.outLen+4) 'sqlsOut'
call csmExWsh rz, rdr, spec dbSys oo retOk
return 1
endProcedure sqlWshOut
/* copy sqlWsh end *************************************************/
}¢--- A540769.WK.REXX(STRINGUT) cre=2009-09-03 mod=2009-09-03-10.35.35 A540769 ---
/* copy stringUt begin ***********************************************/
/*--- return the count of occurrences of needle in heyStack ----------*/
posCount: procedure
parse arg needle, hayStack, start, fin
if start = '' then
start = 1
if fin = '' then
fin = length(hayStack) + 1 - length(needle)
do cnt = 0 by 1
start = pos(needle, haystack, start)
if start < 1 | start > fin then
return cnt
start = start + length(needle)
end
endProcedure posCount
repAll: procedure expose m.
parse arg src, w, new
res = ''
cx = 1
do forever
nx = pos(w, src, cx)
if nx < 1 then
return res || substr(src, cx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAll
repAllWords: procedure expose m.
parse arg src, w, new
res = ''
wx = 0
cx = 1
do forever
wx = wordPos(w, src, wx+1)
if wx < 1 then
return res || substr(src, cx)
nx = wordindex(src, wx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAllWords
/* copy stringUt end ***********************************************/
}¢--- A540769.WK.REXX(SV) cre=2009-04-21 mod=2011-02-01-20.30.59 A540769 -------
/* rexx ****************************************************************
sv: editMacro for a backup of the current member
arguments:
noArgs save current member and copy it to saveLib
s<srcDsn> source dsn (ps or pds with member)
m<mbr> memberName in backup and saveLib
n no save in current edit session
l additional copy to zLib
t trace
?, -? this help
backupLib: zzz.save (root) contains index
(s0???) contains contents
saveLib: zLib.????
***********************************************************************/
parse arg arg
call errReset 'h'
backupLib = dsn2Jcl('zzz.save', 1)
saveLibPref = dsn2Jcl('zlib.', 1)
rootMbr = 'root'
editing = 0
eDsn = ''
eMbr = ''
src = ''
call adrIsp 'control errors return'
if arg ^== '' then nop
else if adrEdit("MACRO (arg)", "*") ^= 0 then
say 'no edit marcro rc' rc
else do
editing = 1
call adrEdit "(eDsn) = dataset"
call adrEdit "(eMbr) = member"
end
if (^editing & arg = '') | pos('?', arg) > 0 then
return help()
mbr = eMbr
doSave = editing
doLib = 0
do wx = 1 to words(arg)
w = word(arg, wx)
upper w
do cx=1 to length(w)
if substr(w, cx, 1) == 'N' then
doSave = 0
else if substr(w, cx, 1) == 'L' then
doLib = 1
else if substr(w, cx, 1) == 'T' then
m.trace = 1
else if substr(w, cx, 1) == 'S' then do
src = substr(w, cx + 1)
leave
end
else if substr(w, cx, 1) == 'M' then do
mbr = substr(w, cx + 1)
leave
end
else
call err 'bad option' substr(w, cx) 'word' w 'in' arg
end
end
call trc 'doSave' doSave 'doLib' doLib 'eMbr' eMbr 'eDsn' eDsn
call trc ' ' 'mbr' mbr 'src' src
if src == '' then do
if ^editing then
call err 'src empty'
if doSave then do /* editor save */
if adrEdit("save", '*') ^= 0 then do
say 'could not SAVE, rc=' rc
doSave = 0
end
end
src = dsnSetMbr(eDsn, eMbr)
end
backupDsn = backupRoot(backupLib, dsnSetMbr(src, mbr)) /* root entry */
dd = svBack
call adrTso "alloc dd("dd") shr dsn('"backupDsn"')"
if doLib then
dd = dd svLib(saveLibPref, src, mbr)
if editing & ^doSave then
call copyEdit dd
else
call copyDsn src, dd
call adrTso 'free dd('dd')'
exit
/*--- make a root entry in backlib for name
and return dsn of mbr pointed to -------------------------------*/
backupRoot: procedure expose m.
parse arg backLib, name
backRoot = backlib'(ROOT)'
rs = sysDsn("'"backRoot"'")
if rs == 'OK' then do
call adrTso "ALLOC F(svBack) Dsn('"backRoot"') SHR REUSE"
end
else do
if rs == 'DATASET NOT FOUND' then do
call createLib backLib
rs = sysDsn("'"backRoot"'")
end
if rs ^== 'MEMBER NOT FOUND' then
call err 'backlib' backlib rs
rec.1 = left('root lastRecord 1', 100)'eol'
do i=2 to 1030
rec.i = left('',100)'eol'
end
call adrTso "ALLOC F(svBack) Dsn('"backRoot"') SHR REUSE"
call adrTso "EXECIO" 1000 "DISKW svBack (STEM rec. FINIS)"
end
call adrTSO "EXECIO 1 DISKRU svBack (STEM rootOne.)"
lastRec = strip(substr(rootOne.1, 20, 10))
if left(rootOne.1, 16) <> 'root lastRecord' ,
| ^ dataType(lastRec, 'num') then
call err 'root record 1 bad'
else if lastRec >= 999 then do
say 'overflow'
call adrTSO "EXECIO 0 DISKW svBack (finis )"
call adrTso "FREE F(svBack)"
call renameLib backLib
return backupRoot(backlib, name)
end
lastRec = lastRec + 1
nextMbr = 's'right(lastRec,4,0)
rootOne.1 = overlay(lastRec, rootOne.1, 20, 10)
call adrTSO "EXECIO 1 DISKW svBack (STEM rootOne. )"
call adrTSO "EXECIO 1 DISKRU svBack" lastRec "(STEM rootAct.)"
rootAct.1 = overlay(left(nextMbr,8) date() time() ,
name, rootAct.1)
call adrTSO "EXECIO 1 DISKW svBack (STEM rootAct. finis )"
call adrTso "FREE F(svBack)"
res = dsnSetMbr(backlib, nextMbr)
call trc 'backUpRoot' res 'for' name
return res
endProcedure backupRoot
/*--- open (and create) savelib for PDS src --------------------------*/
svLib: procedure expose m.
parse arg pref, src, mbr
if mbr = '' then
say 'empty member ==> no lib'
else do
llq = substr(src, lastPos('.', src)+1)
suf = ''
if substr(llq, 1, 2) == 'PL' then
suf = PLI
else if substr(llq, 1, 2) == 'RE' then
suf = REXX
else
say 'llq' llq '==> no lib'
if suf ^== '' then do
svLib = pref || suf
if sysDsn(svLib) == 'DATASET NOT FOUND' then
call createLib svLib
call adrTso "alloc dd(svLib)shr dsn('"svLib"("mbr")')"
call trc 'svLib' svLib'('mbr') from' src
return 'svLib'
end
end
return ''
endProcedure svLib
/*--- create library dsn ---------------------------------------------*/
createLib: procedure
parse arg dsn
call adrTso "alloc dd(ddCrea) new catalog dsn('"dsn"')",
'dsntype(library) dsorg(po) recfm(v b) lrecl(32756)' ,
'space(100, 1000) cyl mgmtclas(COM#A092)'
call adrTso 'free dd(ddCrea)'
return
endProcedure createLib
/*--- rename library dsn ---------------------------------------------*/
renameLib: procedure
parse arg dsn
do ix=9999 by -1
if sysDsn("'"dsn"'") == 'OK' then
act = dsn || ix
rc = listdsi("'"act"' norecall")
if rc = 0 then
say 'available' act
else if rc = 16 & sysReason = 9 then
say "migrated" act
else if rc = 16 & sysReason = 5 then
leave
else
call err 'listDsi nc' rc 'reason' sysReason SYSMSGLVL2 dsn x
end
say 'renaming' dsn to act
call adrTso "rename '"dsn"' '"act"'"
return
endProcedure renameLib
/*--- copy frDsn to all the dd's in toDDs ---------------------------*/
copyDsn: procedure
parse arg frDsn, toDDs
call trc 'copyDsn from' frDsn 'to' toDDs
call adrTso "ALLOC dd(svSrc) dsn('"frDsn"') SHR REUSE"
call readDDBegin svSrc
do wx=1 to words(toDDs)
call writeDDBegin word(toDDs, wx)
end
do while readDD(svSrc, s.)
do wx=1 to words(toDDs)
call writeDD word(toDDs, wx), s.
end
end
call readDDEnd svSrc
do wx=1 to words(toDDs)
call writeDDend word(toDDs, wx)
end
return
endProcedure copyDsn
/*--- copy the editors source to all dd's in toDDs -------------------*/
copyEdit: procedure /* copy editor content to an other */
parse arg toDDs
call trc 'copyEdit to' toDDs
do wx=1 to words(toDDs)
call writeDDBegin word(toDDs, wx)
end
limit = 100
call adrEdit '(lastNum) = linenum .zl'
sx = 0
do lx=1 by 1
if lx > lastNum | sx > 100 then do
do wx=1 to words(toDDs)
call writeDD word(toDDs, wx), s, sx
end
sx = 0
if lx > lastNum then
leave
end
sx = sx + 1
call adrEdit '(s'sx') = line' lx
end
do wx=1 to words(toDDs)
call writeDDend word(toDDs, wx)
end
return
endProcedure copyEdit
/* 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 timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') shr dsn('grp'.datasets)'
end
else do
call trc 'no datasets found' timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') dummy'
end
call readDDBegin grp
return /* end lmdBegin */
lmdNext:
parse arg ggGrp, ggSt, withVolume
if ^ readDD(ggGrp, ggSt) then
return 0
if withVolume ^== 1 then
do ggIx=1 to value(ggSt'0')
x = value(ggSt || ggIx, word(value(ggSt || ggIx), 1))
end
return 1
endSubroutin lmdNext
lmdEnd: procedure
parse arg grp
call readDDEnd grp
call adrTso 'free dd('grp')'
return /* end lmdEnd */
lmd: procedure expose m.
parse arg lev, withVol
call lmdBegin gg1, lev
do while lmdNext(gg1, q., withVol)
do x=1 to q.0
call jOut q.x
end
end
call lmdEnd gg1
return
endProcedure lmd
/**********************************************************************
member list of a pds:
call sequence x=lmmBegin(dsn) lmmNext(x) * lmmEnd(x)
***********************************************************************/
lmm: procedure expose m.
parse arg dsn
id = lmmBegin(dsn)
do ix=1 by 1
m = lmmNext(id)
if m = '' then
leave
call jOut m
end
call lmmEnd id
return
endProcedure lmm
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')'
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 strip(mbr)
else
return ''
endProcedure lmmNext
lmmRm: 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
endProcedure lmmRm
/*--- address ispf with error checking -------------------------------*/
adrIsp:
parse arg ggIspCmd, ggRet
address ispexec ggIspCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr ispExec rc' rc 'in' ggIspCmd':' strip(zerrlm)
endSubroutine adrIsp
/*--- address editor with error checking -----------------------------*/
adrEdit:
parse arg ggEditCmd, ggRet
address isrEdit ggEditCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr isrEdit rc' rc 'for' ggEditCmd
endSubroutine adrEdit
/* copy adrIsp end *************************************************/
/* copy adrTso begin *************************************************/
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet ---*/
adrTso:
parse arg ggTsoCmd, ggRet
address tso ggTsoCmd
if rc == 0 then return 0
else if ggRet == '*' then return rc
else if wordPos(rc, ggRet) > 0 then return rc
else
call err 'adrTso rc' rc 'for' ggTsoCmd
return /* end adrTso */
/*--- format dsn from tso format to jcl format -----------------------*/
dsn2jcl: procedure
parse 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
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
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, disp, dd, retRc
ds = ''
m.dsnAlloc.dsn = ds
if left(spec, 1) = '-' then
return strip(substr(spec, 2))
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
disp = w
else if w = 'CATALOG' then
disp = disp w
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
ds = strip(substr(w, 5, length(w)-5))
else if ds = '' then
ds = dsn2jcl(w)
else
leave
end
rest = subword(spec, wx)
if abbrev(rest, '.') then
rest = substr(rest, 2)
parse var rest rest ':' nn
if dd <> '' & ds = '' & rest = '' & ^ abbrev(disp, 'SYSO') then
call err "'return" dd"' no longer supported please use ="dd
if dd = '' then do
if symbol('m.adrTso.ddNum') = 'VAR' then
dd = m.adrTso.ddNum + 1
else
dd = 1
m.adrTso.ddNum = dd
dd = 'DD' || dd
end
if disp = '' then
disp = 'SHR'
else if pos('(', ds) < 1 then
nop
else if disp = 'MOD' then
call err 'disp mod for' ds
else
disp = 'SHR'
m.dsnAlloc.dsn = ds
if pos('/', ds) > 0 then
return csmAlloc(dd, disp, ds, rest, nn, retRc)
else
return tsoAlloc(dd, disp, ds, rest, nn, retRc)
endProcedure dsnAlloc
tsoAlloc: procedure expose m.
parse arg dd, disp, dsn, rest, nn, retRc
c = 'alloc dd('dd')' disp
if dsn <> '' then
c = c "DSN('"dsn"')"
if retRc <> '' | nn = '' then do
alRc = adrTso(c rest, retRc)
if alRc <> 0 then
return alRc
return dd 'call adrTso "free dd('dd')";'
end
do retry=0 to 1
alRc = adrTso(c rest, '*')
if alRc = 0 then
return dd 'call adrTso "free dd('dd')";'
if nn = '' | wordPos(disp, 'OLD SHR') < 1 ,
| sysDsn("'"m.dsnAlloc.dsn"'") ^== 'DATASET NOT FOUND' then
leave
say 'tsoAlloc rc' alRc 'for' c rest '...trying to create'
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(dsn, nn)
call adrTso 'free dd('dd')'
end
call err 'tsoAlloc rc' alRc 'for' c rest
endProcedure tsoAlloc
dsnCreateAtts: procedure expose m.
parse arg dsn, atts
if abbrev(atts, ':') then do
rl = substr(atts, 3)
if abbrev(atts, ':F') then do
if rl = '' then
rl = 80
atts = 'recfm(f b) lrecl('rl')' ,
'block(' (32760 - 32760 // rl)')'
end
else do
if rl = '' then
rl = 32756
atts = 'recfm('substr(atts, 2, 1) 'b) lrecl('rl')' ,
'block(32760)'
end
end
if pos('(', dsn) > 0 then
atts = atts 'dsntype(library) dsorg(po)' ,
"dsn('"dsnSetMbr(dsn)"')"
else
atts = atts "dsn('"dsn"')"
return atts 'mgmtclas(COM#A091) space(10, 1000) cyl'
endProcedure dsnCreateAtts
/*--- read the dataset specified in ggDsnSpec to stem ggSt -----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
interpret subword(ggAlloc, 2)
return
endSubroutine readDsn
/*--- write the dataset specified in ggDsnSpec from stem ggSt
write ggCnt records if not empty otherwise ggst0
if ggSay 1 then say ... records written to ... -------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'open finis)'
interpret subword(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
/* copy adrTso end ****************************************************/
/* copy err begin ******************************************************
messages, errorhandling,help
***********************************************************************/
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
parse arg oo, ha
if pos('I', translate(oo)) > 0 then
call adrIsp 'control errors return'
m.err.opt = translate(oo, 'h', 'H')
if ha == '' then
drop m.err.handler
else
m.err.handler = ha
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
drop err handler opt
if ggOpt == '' & symbol('m.err.handler') == 'VAR' then
interpret m.err.handler
call errSay ggTxt
parse source . . ggS3 . /* current rexx */
if ggOpt == '' | ggOpt == '*' then
ggOpt = translate(value('m.err.opt'), 'ht', 'HT')
if pos('h', ggOpt) > 0 then do
say 'fatal error in' ggS3': divide by zero to show stackHistory'
x = 1 / 0
end
say 'fatal error in' ggS3': exit(12)'
exit errSetRc(12)
endSubroutine err
/*--- assert that the passed rexx expression evaluates to true -------*/
assert:
interpret 'assertRes =' arg(1)
if ^ assertRes then
call err 'assert failed' arg(1)':' arg(2)
return
endProcedure assert
/*--- say an errorMessage msg with pref pref
split message in lines at '/n'
say addition message in stem st ---------------------------*/
errSay: procedure expose m.
parse arg msg, st, pref
parse source . . ggS3 . /* current rexx */
if pref == 'e' | (pref == '' & st == '') then
msg = 'fatal error:' msg
else if pref == 'w' then
msgf = 'warning:' msg
else if pref == 0 then
nop
else if right(pref, 1) ^== ' ' then
msg = pref':' msg
else
msg = pref || msg
sx = 0
bx = -1
do lx=1 until bx >= length(msg)
ex = pos('\n', msg, bx+2)
if ex < 1 then
ex = length(msg)+1
if st == '' then do
say substr(msg, bx+2, ex-bx-2)
end
else do
sx = sx+1
m.st.sx = substr(msg, bx+2, ex-bx-2)
m.st.0 = sx
end
bx = ex
end
return
endProcedure errSay
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg, op
say 'fatal error:' msg
call help
call err msg, op
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
----------------------------------------------------------------------*/
errSetRc: procedure
parse arg zIspfRc
if sysVar('sysISPF') = 'ACTIVE' then do
address ispExec vput 'zIspfRc' shared
end
return zIspfRc
endProcedure errSetRc
/*--- 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
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
say 'debug' msg
return
endProcedure debug
/*--- return current time and cpu usage ------------------------------*/
timing: 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 *****************************************************/
}¢--- A540769.WK.REXX(T) cre=2013-11-29 mod=2016-03-01-16.45.29 A540769 --------
$#@
$= y = WK913K003 = strip(wk913k003) || 'u' $*+
asdf asfd
say $y'|'
$#out 20160301 16:44:22
$#out 20160301 16:44:00
$#out
}¢--- A540769.WK.REXX(TBCNT) cre=2012-09-19 mod=2012-09-19-14.28.33 A540769 ----
$#@
call sqlConnect 'DBAF'
$;
$<#¢
select creator, name
from sysibm.sysTables
where dbName = 'PTDB'
order by 2
$! call sqlSel
$|
$@forWith i $@¢
r = $CREATOR'.'$NAME sql2one('select count(*) from' ,
$CREATOR'.'$NAME)
say r
$$- r
$!
$#out 20120919 14:21:02
PTI.ACCUM_STRATEGY 0
PTI.ALOGFILE 0
PTI.ALOGRANGE 0
PTI.BPLOG_0203 89
PTI.OFS_PK 105
PTI.OFS_RT 328
PTI.PTALT_ACM_0160 0
PTI.PTALT_SYSTBL_0160 0
PTI.PTAN_PRFM_0201 0
PTI.PTAN_PRFM_1200 0
PTI.PTAN_SQL_0201 0
PTI.PTAN_SQL_1200 0
PTI.PTAN_STMT_0201 0
PTI.PTAN_STMT_1200 0
PTI.PTDC1_STRAT_0100 0
PTI.PTGEN_AUTH_0100 0
PTI.PTGEN_DEFAULT_0100 0
PTI.PTGL500_HISTORY 0
PTI.PTGL600_RESTART 0
PTI.PTGL600_RESTART2 0
PTI.PT24G_BACKUP2_0202 0
PTI.PTLOG_BACKUP_0202 0
PTI.PTLOG_CTSTATS_1105 0
PTI.PTLOG_DASTATS_1105 0
PTI.PTLOG_MAIN_1500 1008
PTI.PTLOG_RDAMSG_1105 1
PTI.PTLOG_SEC_0102 0
PTI.PTMG1_STRAT_0200 171
PTI.PTMG2_ALTER_0200 212
PTI.PTMG4_RULES_0300 4
PTI.PTMG5_GLOBAL_0400 14
PTI.PTMG7_GROUP_0400 1
PTI.PTMG8_OUTPUT_0401 0
PTI.PTMG9_MASK_0510 8
PTI.PTMGA_LNAME_0200 33
PTI.PTMGB_APTABLE_0100 1
PTI.PTMGB_SPTABLE_0100 43
PTI.PTMGB_UPTABLE_0100 1
*** run error ***
SQLCODE = -766: THE OBJECT OF A STATEMENT IS A TABLE FOR
WHICH THE REQUESTED OPERATION IS NOT PERMITTED
stmt = prepare s11 into :M.SQL.11.D from :src
with into :M.SQL.11.D = M.SQL.11.D
from :src = select count(*) from PTI.PTMGE_STRAUX_0200
$#out 20120919 14:20:34
*** run error ***
SQLCODE = -766: THE OBJECT OF A STATEMENT IS A TABLE FOR
WHICH THE REQUESTED OPERATION IS NOT PERMITTED
stmt = prepare s11 into :M.SQL.11.D from :src
with into :M.SQL.11.D = M.SQL.11.D
from :src = select count(*) from PTI.PTMGE_STRAUX_0200
$#out 20120919 14:14:28
@O.172.1 class=SQL172, CREATOR=PTI, NAME=ACCUM_STRATEGY
@O.172.2 class=SQL172, CREATOR=PTI, NAME=ALOGFILE
@O.172.3 class=SQL172, CREATOR=PTI, NAME=ALOGRANGE
@O.172.4 class=SQL172, CREATOR=PTI, NAME=BPLOG_0203
@O.172.5 class=SQL172, CREATOR=PTI, NAME=OFS_PK
@O.172.6 class=SQL172, CREATOR=PTI, NAME=OFS_RT
@O.172.7 class=SQL172, CREATOR=PTI, NAME=PTALT_ACM_0160
@O.172.8 class=SQL172, CREATOR=PTI, NAME=PTALT_SYSTBL_0160
@O.172.9 class=SQL172, CREATOR=PTI, NAME=PTAN_PRFM_0201
@O.172.10 class=SQL172, CREATOR=PTI, NAME=PTAN_PRFM_1200
@O.172.11 class=SQL172, CREATOR=PTI, NAME=PTAN_SQL_0201
@O.172.12 class=SQL172, CREATOR=PTI, NAME=PTAN_SQL_1200
@O.172.13 class=SQL172, CREATOR=PTI, NAME=PTAN_STMT_0201
@O.172.14 class=SQL172, CREATOR=PTI, NAME=PTAN_STMT_1200
@O.172.15 class=SQL172, CREATOR=PTI, NAME=PTDC1_STRAT_0100
@O.172.16 class=SQL172, CREATOR=PTI, NAME=PTGEN_AUTH_0100
@O.172.17 class=SQL172, CREATOR=PTI, NAME=PTGEN_DEFAULT_0100
@O.172.18 class=SQL172, CREATOR=PTI, NAME=PTGL500_HISTORY
@O.172.19 class=SQL172, CREATOR=PTI, NAME=PTGL600_RESTART
@O.172.20 class=SQL172, CREATOR=PTI, NAME=PTGL600_RESTART2
@O.172.21 class=SQL172, CREATOR=PTI, NAME=PTLOG_BACKUP2_0202
@O.172.22 class=SQL172, CREATOR=PTI, NAME=PTLOG_BACKUP_0202
@O.172.23 class=SQL172, CREATOR=PTI, NAME=PTLOG_CTSTATS_1105
@O.172.24 class=SQL172, CREATOR=PTI, NAME=PTLOG_DASTATS_1105
@O.172.25 class=SQL172, CREATOR=PTI, NAME=PTLOG_MAIN_1500
@O.172.26 class=SQL172, CREATOR=PTI, NAME=PTLOG_RDAMSG_1105
@O.172.27 class=SQL172, CREATOR=PTI, NAME=PTLOG_SEC_0102
@O.172.28 class=SQL172, CREATOR=PTI, NAME=PTMG1_STRAT_0200
@O.172.29 class=SQL172, CREATOR=PTI, NAME=PTMG2_ALTER_0200
@O.172.30 class=SQL172, CREATOR=PTI, NAME=PTMG4_RULES_0300
@O.172.31 class=SQL172, CREATOR=PTI, NAME=PTMG5_GLOBAL_0400
@O.172.32 class=SQL172, CREATOR=PTI, NAME=PTMG7_GROUP_0400
@O.172.33 class=SQL172, CREATOR=PTI, NAME=PTMG8_OUTPUT_0401
@O.172.34 class=SQL172, CREATOR=PTI, NAME=PTMG9_MASK_0510
@O.172.35 class=SQL172, CREATOR=PTI, NAME=PTMGA_LNAME_0200
@O.172.36 class=SQL172, CREATOR=PTI, NAME=PTMGB_APTABLE_0100
@O.172.37 class=SQL172, CREATOR=PTI, NAME=PTMGB_SPTABLE_0100
@O.172.38 class=SQL172, CREATOR=PTI, NAME=PTMGB_UPTABLE_0100
@O.172.39 class=SQL172, CREATOR=PTI, NAME=PTMGE_STRAUX_0200
@O.172.40 class=SQL172, CREATOR=PTI, NAME=PTMGE_STRINGS_0200
@O.172.41 class=SQL172, CREATOR=PTI, NAME=PTMOD_UTLSYM_0401
@O.172.42 class=SQL172, CREATOR=PTI, NAME=PTPA_AUTOHVER_1200
@O.172.43 class=SQL172, CREATOR=PTI, NAME=PTPA_ES_EXPL_1500
@O.172.44 class=SQL172, CREATOR=PTI, NAME=PTPA_ES_EXSRC_1200
@O.172.45 class=SQL172, CREATOR=PTI, NAME=PTPA_ES_IMSQL_1200
@O.172.46 class=SQL172, CREATOR=PTI, NAME=PTPA_ES_RU2RE_1200
@O.172.47 class=SQL172, CREATOR=PTI, NAME=PTPA_ES_RULES_1200
@O.172.48 class=SQL172, CREATOR=PTI, NAME=PTPA_ES_RULID_1200
@O.172.49 class=SQL172, CREATOR=PTI, NAME=PTPA_ES_STRAT_1200
@O.172.50 class=SQL172, CREATOR=PTI, NAME=PTPA_ES_VOUTP_1200
@O.172.51 class=SQL172, CREATOR=PTI, NAME=PTPA_EXCPT_1200
@O.172.52 class=SQL172, CREATOR=PTI, NAME=PTPA_EXPLPROF_1200
@O.172.53 class=SQL172, CREATOR=PTI, NAME=PTPMM_PURGE_0510
@O.172.54 class=SQL172, CREATOR=PTI, NAME=PTPRI_KEYCOLS_0100
@O.172.55 class=SQL172, CREATOR=PTI, NAME=PTPRI_SYSCOLS_0100
@O.172.56 class=SQL172, CREATOR=PTI, NAME=PTPRI_SYSFKEY_0100
@O.172.57 class=SQL172, CREATOR=PTI, NAME=PTPRI_SYSINDX_0100
@O.172.58 class=SQL172, CREATOR=PTI, NAME=PTPRI_SYSKEYS_0100
@O.172.59 class=SQL172, CREATOR=PTI, NAME=PTPRI_SYSRELS_0100
@O.172.60 class=SQL172, CREATOR=PTI, NAME=PTPRI_TABKEYS_0100
@O.172.61 class=SQL172, CREATOR=PTI, NAME=PTPS_DBASTATS_1200
@O.172.62 class=SQL172, CREATOR=PTI, NAME=PTPS_MASKS_0702
@O.172.63 class=SQL172, CREATOR=PTI, NAME=PTPS_OBJECTS_0702
@O.172.64 class=SQL172, CREATOR=PTI, NAME=PTPS_STRAT_0702
@O.172.65 class=SQL172, CREATOR=PTI, NAME=PTPS_SYSSTATS_0702
@O.172.66 class=SQL172, CREATOR=PTI, NAME=PTRA_SYSCOPY_0301
@O.172.67 class=SQL172, CREATOR=PTI, NAME=PTRCE_OPTION_0103
@O.172.68 class=SQL172, CREATOR=PTI, NAME=PTRCQ_DESC_0200
@O.172.69 class=SQL172, CREATOR=PTI, NAME=PTRCQ_SAVED_RPTS
@O.172.70 class=SQL172, CREATOR=PTI, NAME=PTRI_PSFKEY_0100
@O.172.71 class=SQL172, CREATOR=PTI, NAME=PTRI_PSSYSCOL_0100
@O.172.72 class=SQL172, CREATOR=PTI, NAME=PTRU2_DROPR_0202
@O.172.73 class=SQL172, CREATOR=PTI, NAME=PTSE_AD_PREFX_0105
@O.172.74 class=SQL172, CREATOR=PTI, NAME=PTSE_AD_PREFX_NFM
@O.172.75 class=SQL172, CREATOR=PTI, NAME=PTSQL_DATA_0102
@O.172.76 class=SQL172, CREATOR=PTI, NAME=PTSQL_DATA_115
@O.172.77 class=SQL172, CREATOR=PTI, NAME=PTSQL_TEXT_0101
@O.172.78 class=SQL172, CREATOR=PTI, NAME=PTSQL_TEXT_115
@O.172.79 class=SQL172, CREATOR=PTI, NAME=PTSSC_STRAT_0200
@O.172.80 class=SQL172, CREATOR=PTI, NAME=PTSYS_DEFAULT_0100
@O.172.81 class=SQL172, CREATOR=PTI, NAME=PVPA_ES_EXPL_1500
@O.172.82 class=SQL172, CREATOR=PTI, NAME=RACA_CONN_1105
@O.172.83 class=SQL172, CREATOR=PTI, NAME=RACD_STATS_1105
@O.172.84 class=SQL172, CREATOR=PTI, NAME=RACL_STATS_1105
@O.172.85 class=SQL172, CREATOR=PTI, NAME=RACN_CONN_1105
@O.172.86 class=SQL172, CREATOR=PTI, NAME=RACP_PROCD_1105
@O.172.87 class=SQL172, CREATOR=PTI, NAME=RACR_PROC_1105
@O.172.88 class=SQL172, CREATOR=PTI, NAME=RAEP_PROC_1105
@O.172.89 class=SQL172, CREATOR=PTI, NAME=RAFQ_STATS_1105
@O.172.90 class=SQL172, CREATOR=PTI, NAME=RAIK_STATS_1105
@O.172.91 class=SQL172, CREATOR=PTI, NAME=RAIX_STATS_1105
@O.172.92 class=SQL172, CREATOR=PTI, NAME=RAOS_PROC_1105
@O.172.93 class=SQL172, CREATOR=PTI, NAME=RARP_PROCD_1105
@O.172.94 class=SQL172, CREATOR=PTI, NAME=RATB_STATS_1105
@O.172.95 class=SQL172, CREATOR=PTI, NAME=RATS_STATS_1105
@O.172.96 class=SQL172, CREATOR=PTI, NAME=RAUT_HIST_1105
@O.172.97 class=SQL172, CREATOR=PTI, NAME=RAVL_STATS_1105
$#out 20120919 14:13:57
*** run error ***
no class found for object M.SQL.CONNECTION
$#out 20120919 14:13:45
$#out
}¢--- A540769.WK.REXX(TECSVLEQ) cre=2015-12-08 mod=2015-12-21-09.33.40 A540769 ---
$#@
$*( tecSave:
extract last change from rz4/dp4g/OA1P.TQZ006GBGRTSSTATS
and import it into rz?/? /OA1P.TQZ005TECSVRTSLASTEQ
algo pro Partition
1) find updatestatsTime of newest row
2) find difNew = updatestatstime of newest row
with NOT all columns indicating update equal
3) find eqOld = updatestatstime of oldest row newer difNew
i.e. all rows between updatestatstime and eqOld
have all columns indicating update equal
specials:
if no difNew ==> use oldest row for 3) eqOld
if difNew is legacy data (from old datacollection, with
only size) and size is within +- 16kb
then use min(eqOld, difNew + 5 days) for eqOld
==> eqOld never null
$*)
$= rz = RZ2
$= dbSys = DBOF
$<>
$>. fEdit()
$@jobHead
$@dsntiaul
call sqlConnect dp4g
$@sql
call sqlDisConnect dp4g
$@jobSub
$@load
$$ }{
$$ // DD DISP=(OLD,DELETE),DSN=*.UNLOAD.SYSREC00
$proc $@=/jobHead/
//A540769W JOB (CP00,KE50),'DB2 ADMIN',
// TIME=1440,REGION=0M,CLASS=M1,SCHENV=DB2ALL,
// MSGCLASS=T,NOTIFY=&SYSUID
$/jobHead/
$proc $@=/jobSub/
//***** submit job to $rz *****************************************
//SUB$rz EXEC PGM=IEBGENER
//SYSPRINT DD SYSOUT=*
//SYSUT2 DD SUBSYS=(CSM,'SYSTEM=$rz,SYSOUT=(A,INTRDR)')
//SYSUT1 DD DATA,DLM='}{'
$@jobHead
$/jobSub/
$proc $@=/dsntiaul/
//UNLOAD EXEC PGM=IKJEFT01,DYNAMNBR=200,TIME=99
//SYSTSIN DD *
DSN SYSTEM(DP4G)
RUN PROGRAM(DSNTIAUL) PARMS('SQL')
//SYSTSPRT DD SYSOUT=*
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTERM DD SYSOUT=*
//SYSPUNCH DD SYSOUT=*,RECFM=FB,LRECL=80
//SYSREC00 DD DISP=(MOD,PASS),
// SPACE=(CYL,(2,1000)),MGMTCLAS=COM#A069
//SYSIN DD *
$/dsntiaul/
$proc $@=/sql/
with k as $**--- keys of newest row per partition
(
select rz, dbSys, dbName, name, partition, instance
, max(updatestatstime) updatestatstime
from OA1P.TQZ006GBGRTSSTATS k0
where rz = '$rz' and dbSys = '$dbSys'
$@ if $dbSys == 'DBOF' then $@=¢
and dbName in ('XC01A1P', 'XR01A1P')
and (name like 'A2%' or name like 'A5%')
$*( and (dbName = 'XC01A1P' and name like 'A519%' ) $*)
$! $@ else if $dbSys == 'DVBP' then $@=¢
and dbName like 'XB%'
$! $@ else if $dbSys == 'DP4G' then $@=¢
and dbName like 'QZ01A1P%'
$! $@ else call err 'where for dbSys='$dbSys
group by rz, dbSys, dbName, name, partition, instance
)
, d2 as $**--- timestamp and type of newest different row
(
select cD.*
, ( select max(char(dD.updatestatsTime)
|| case when dD.ibmReqD is null or dD.ibmReqD <> ' '
or dD.dbid is null or dD.dbid <> 0
or dD.pgSIze is null or dD.pgSize <> 1
then 'n' else '' || nActive end)
from OA1P.TQZ006GBGRTSSTATS dD
where kD.rz = dD.rz and kD.dbSys = dD.dbSys
and kD.dbName = dD.dbName and kD.name = dD.name
and kD.partition = dD.partition
and kD.instance = dD.instance
and not
( cD.state = dD.state
and cD.totalRows = dD.totalRows
and cD.nActive = dD.nActive
and cD.nPages = dD.nPages
and cD.reorgInserts = dD.reorgInserts
and cD.REORGDELETES = dD.REORGDELETES
and cD.REORGUPDATES = dD.REORGUPDATES
and cD.REORGMASSDELETE = dD.REORGMASSDELETE
and cD.dataSize = dD.dataSize
) ) difNewNO
from k kD
join OA1P.TQZ006GBGRTSSTATS cD $**--- current row
on kD.rz = cD.rz and kD.dbSys = cD.dbSys
and kD.dbName = cD.dbName and kD.name = cD.name
and kD.partition = cD.partition and kD.instance = cD.instance
and kD.updatestatstime = cD.updateStatsTime
where cD.state = 'a'
)
, d as $**--- decode difNewNO int difNew and difNO
(
select timestamp(left(difNewNO, 26)) difNew
, case when difNewNO is null then ' '
when substr(difNewNO, 27) = 'n' then 'n'
when nActive * pgSize
between int(substr(difNewNO, 27)) - 16
and int(substr(difNewNO, 27)) + 16
then 'e' else 'o' end difNO
, d2.*
from d2
)
, e as $**--- timestamp oldest equal row
(
select
( select min(updatestatsTime)
from OA1P.TQZ006GBGRTSSTATS eE
where eE.rz = dE.rz and eE.dbSys = dE.dbSys and eE.state = 'a'
and eE.dbName = dE.dbName and eE.name = dE.name
and eE.partition = dE.partition
and eE.instance = dE.instance
and eE.updateStatsTime
> value(dE.difNew, '1111-11-11-11.11.11')
) eqOld
, dE.*
from d dE
)
select char(value(strip(dbName) || ',' || strip(name)
|| ',' || partition
|| ',' || char(case when difNO <> 'e' then eqOld
else min(eqOld, difNew + 3 days) end)
|| ',' || char(updateStatsTime)
, '') , 80) txt
from e
order by dbName, name, partition
; $** dsntiaul braucht ;
$/sql/
$proc $@=/load/
//LOAD EXEC PGM=DSNUTILB,PARM='$dbSys,A540769W.LOAD'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSTEMPL DD DSN=$dbSys.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LOAD LOG NO RESUME NO REPLACE COPYDDN(TCOPYD)
STATISTICS INDEX(ALL)
WORKDDN(TSYUTS, TSOUTS)
INDDN(DDIN1) FORMAT DELIMITED EBCDIC CCSID(37, 37)
INTO TABLE OA1P.TQZ005TECSVRTSLASTEQ
//DDIN1 DD *
$/load/
$#out 20151221 09:29:20
$#out 20151215 20:18:22
$#out 20151214 15:49:45
$#out 20151210 09:59:07
$#out 20151210 09:55:34
}¢--- A540769.WK.REXX(TECSVUNL) cre=2015-07-06 mod=2016-01-26-08.23.45 A540769 ---
/* rexx **************************************************************
tecSvUnl <dbSys>
for XC/XR -- EOS / eRet
searches DatasetNames for XC and XR unloads and punches
loads all partitions from db2Catalog / XC&XR Controltables
into oa1p.tQZ005ecSvUnl
with stage, staUpd, unl and Pun DatasetNames and timestamps
for XB -- ELAR
selects stage, unload from meta tables and computes punch
25. 1.16 wk Elar: cleanup sql, xba part=1 ok
8.12.15 wk Elar: unload&punch for www tables / mig off
25. 9.15 wk ignore views for elar load (for RZZ)
20. 9.15 wk add punch for elar
6. 7.15 wk neu
*********************************************************************/
call errReset 'h'
call timeIni
call mapIni
parse upper arg dbSys
if dbSys == '' then dbSys = dp4g
if length(dbSys) <> 4 | \ abbrev(dbSys, 'D') then
call errHelp 'bad dbSys:' dbSys
m.uTb = OA1P.tQZ005TecSvUnload
m.strt = timestampNow()
say m.strt 'start tecSvUnl v260116' dbSys 'refresh tecSvUnload'
call sqlConnect dbSys
if wordPos(dbSys, 'DBOF DE0G') > 0 then do
say 'search xc/xr unloads'
call loadCtrl
m.sg_errX = m.sg.0
m.infoErr = ''
call recPun 'XC.XC01A1P.A2*.**'
call recPun 'XC.XC01A1P.A5*.**'
call recPun 'XR.XR01A1P.A2*.**'
call delInsert
do ex = 1 to words(m.infoErr)
e1 = word(m.infoErr, ex)
say e1 m.infoErr.e1
end
end
else if wordPos(dbSys, 'DVBP DEVG') > 0 then do
say 'collect ELAR metaInfo'
call elarDelIns
end
call sqlDisconnect
say timestampNow() 'tecSvUnl end'
exit
/*--- find sysRec und sysPun for each partition
from datasetList
solves the following problems
1) dsn of sysRec and sysPun are not stored in stage tables
2) there is only one pun for several partitions
3) &uniq for pun and rec does NOT agree
we look for the newest punch of this TS after the unload
---------------------------------------------------------------------*/
recPun: procedure expose m.
parse arg msk
call csiOpen cq, msk
pp = 0
cRec = 0
cDup = 0
cPun = 0
do cx=0
if \ csiNext(cq, cr) then
m.cr = '?end'
parse var m.cr p '.' db '.' ts '.' pa '.' ty '.' ti
if \ abbrev(m.cr, pr) then do /* change of table space */
if cx \== 0 then do /* handle old TS */
cRec = cRec + m.lr.0
cPun = cPun + m.lp.0
call sort lp, lq, '>>=' /* sort punch by timestamp */
do lx=1 to m.lr.0 /* for each unl search pun */
rt = word(m.lr.lx, 1)
do ly=1 to m.lq.0 while rt << m.lq.ly
end
if ly > 1 & (ly > m.lq.0 | rt >>= m.lq.ly) then
ly = ly - 1
if ly > 0 then
call unlPunPut m.lr.lx, m.lq.ly
else
call unlPunPut m.lr.lx
end
end
if m.cr == '?end' then do
say timeStampNow() 'recPun' msk':' cx 'dsns,' ,
cPun 'pun,' cRec 'rec,' cDup 'dups'
return
end
pr = p'.'db'.'ts'.' /* ini fields for new TS */
m.lp.0 = 0
m.lr.0 = 0
end
/* analyze fields in dsn */
if verify(pa, '0123456789', 'n',2) >0 | \abbrev(pa,'P') then do
call addErr db, ts, , '-' m.cr, , ', badPart' pa
iterate
end
if ti == '' then
iterate
err = ''
if length(ti) == 8 then
tf = timeLrsn2LZT(timeUniq2Lrsn(ti))
else if \(translate(ti, 000000000, 123456789)='D000000')then do
tf = m.timestamp_01
err = err', badDate' ti
end
else do
tf = '20'translate('12-34-56', substr(ti, 2), '123456'),
|| '-00.00.00'
e1 = timestampCheck(tf)
if e1 <> '' then do
err = err', badDate' ti'>'e1
tf = m.timestamp_01
end
end
if ty == 'SYSPCH' then
call mAdd lp, tf m.cr err
else if ty == 'SYSREC' then do
ly = m.lr.0
lz = word(m.lr.ly, 2)
if \ abbrev(lz, pr || pa) then
call mAdd lr, tf m.cr err
else do /* use newest Rec and put old in error */
cDup = cDup + 1
if tf << m.lr.ly then
m.lr.ly = m.lr.ly err', dupRec' ti
else
m.lr.ly = tf m.cr subWord(m.lr.ly, 3) err,
', dupRec' substr(word(m.lr.ly, 2),
, lastPos('.', word(m.lr.ly, 2))+1)
end
end
else
call errAdd db, ts, pa, tf m.cr, , ', badType' ty
end
return
endProcedure recPun
/*--- put rec and pun in StaGetable stem ----------------------------*/
unlPunPut: procedure expose m.
parse arg unTs aUn e1, puTs aPu e2, e3
parse value aUn with p '.' db '.' ts '.P' pa '.' ty '.' ti
ee = e1 e2 e3
if aPu = '' then do
ee = ',noPunch:' ee
puTs = m.timestamp_01
end
else do
diff = timestampDiff(puTs, unTs)
if (diff < 0 | diff > 0.4) ,
/* ??? & ( diff > 4 | m.lq.ly >> '2015-01-10' ) */ then
ee = ee', punNotSoon' diff
end
if 0 & ee <> '' then
say db ts substr(pa, 2) 'unl' unTs aUn 'pun' puTs aPu ee
ky = db'.'ts'.'format(pa)
if symbol('m.sg.ky') <> 'VAR' then do
call addErr db, ts, format(pa), unTs aUn, puTs aPu,
, ', notInCtrlTb'ee
return
end
else if m.done.ky = 1 then
call err', alreadyDone:' k
m.done.k = 1
o = m.sg.ky
if m.o.unl <> '' then
call err ky 'unl already set' m.o.unl
m.o.unlTst = unTs
m.o.unl = aUn
m.o.punTst = puTs
m.o.pun = aPu
call putInfoErr o, ee
return
endProcedure unlPunPut
putInfoErr: procedure expose m.
parse arg gg, aErr
ee = m.gg.err',' aErr',' m.gg.info
rE = ''
RI = ''
do while ee <> ''
parse var ee a ',' ee
if a = '' then
iterate
parse var a a1 a2
if wordPos(a1, m.infoErr) > 0 then
m.infoErr.a1 = m.infoErr.a1 + 1
else do
m.infoErr = m.infoErr a1
m.infoErr.a1 = 1
end
if a1 = 'dupRec' then
rI = rI',' a
else
rE = rE',' a
end
m.gg.info = space(substr(rI, 3), 1)
m.gg.err = space(substr(rE, 3), 1)
return
endProcedure putInfoErr
addErr: procedure expose m.
m.sg_errX = m.sg_errX + 1
gg = 'SG.'m.sg_errX
parse arg m.gg.db, m.gg.ts, m.gg.pa,
, m.gg.unlTst m.gg.unl e1, m.gg.punTst m.gg.pun e2, e3
ee = e1 e2 e3
ky = m.gg.db'.'m.gg.ts'.'m.gg.pa
if m.done.ky = 1 | \ datatype(m.gg.pa, 'n') ,
| verify(m.gg.pa, '+-0123456789') <> 0 ,
| length(m.gg.pa) > 4 then do
ee = ',pa='m.gg.pa ee
m.gg.pa = m.sg.0 - m.sg_errX
if m.gg.pa <= -3000 then do
ee = ',db='m.gg.db ee
m.gg.db = 'e'm.gg.pa
m.gg.pa = -30000
end
end
m.gg.stage = 'er'
m.gg.staUpd = m.timestamp_01
m.gg.staTb = ''
if timestampCheck(m.gg.unlTst) <> '' then
m.gg.unlTst = m.timestamp_01
if timestampCheck(m.gg.punTs) <> '' then
m.gg.punTs = m.timestamp_01
m.gg.info = ''
m.gg.err = ''
call putInfoErr gg, ee
return
endProcedure addErr
/* select from stage Control tables
$</loadCtrl/
select t.dbname db, t.tsname ts, p.partition pa
, value(XC106_DOC_STATE, XC406_PART_STATUS, xr106_DOC_STATE
, '-m' ) stage
, value(XC106_TS_UPDATE, XC406_UPDATE_TS , xr106_TS_UPDATE
, '1111-11-11-11.11.11.111111') staUpd
, case when XC106_DOC_STATE is not null then '1'
when XC406_PART_STATUS is not null then '4'
when Xr106_doc_state is not null then 'r'
else ''
end staTb
, '1111-11-11-11.11.11.111111' unlTst, '' unl
, '1111-11-11-11.11.11.111111' punTst, '' pun
, '' info
, '' err
from sysibm.systables t
join sysibm.sysTablePart p
on t.dbName = p.dbName and t.tsName = p.tsName
left join OA1P.TXC106A1
on t.name = 'TXC200A1'
and t.creator
= 'OA1P' || substr(xc106_doc_tabColId, 3, 2)
and xc106_doc_tabColId
= 'XC' || substr(t.creator, 5, 2)
and smallInt(xc106_doc_part_no) = p.partition
and xc106_doc_part_no = right('0000' || p.partition, 4)
left join OA1P.TXC406A1
on t.name like 'TXC5%'
and t.name = xc406_table_name
and smallInt(xc406_part_number) = p.partition
and xc406_part_number = right('000' || p.partition, 3)
left join OA1P.Txr106A1
on t.name like 'TXR2%'
and t.name = xr106_doc_tb_name
and smallInt(xr106_doc_part_no) = p.partition
and xr106_doc_part_no = right('000' || p.partition, 3)
where (t.dbName = 'XC01A1P'
AND (t.tsName LIKE 'A2%' or t.tsName LIKE 'A5%' )
AND NOT (t.tsName = 'A500A'))
or (t.dbName = 'XR01A1P' and t.tsName LIKE 'A2%')
order by t.dbName, t.tsName, p.partition
$/loadCtrl/
*/
/*--- load partition stage info from table into stem SG -------------*/
loadCtrl: procedure expose m.
sql = sqlCat(mapInline('loadCtrl'), ' ')
call sql2st sql, sg
say timestampNow() m.sg.0 'rows from stage tables'
do sx=1 to m.sg.0
k = strip(m.sg.sx.db)'.'strip(m.sg.sx.TS)'.'format(m.sg.sx.PA)
if symbol('m.sg.k') == 'VAR' then
call err 'duplicate' k
m.sg.k = 'SG.'sx
end
return
endProcedure loadCtrl
/*
$</elarIns/
insert into oa1p.tqz005TecSvUnload
with sU (area, n, seg, pa, stage, sTb, hkTS, laIm) as
( --- union of segments and infos for new tables --------------------
select storageArea, storageArea_N, segment, partNumber, stage
, 'i', LASTHKTS, lastImport
from BUA.TXBI003 R
union all select '?', enStorAr, right('000' || enSeg, 3), 1, '-a'
, 'a', cast(null as timestamp), cast(null as timestamp)
from bua.txba201
)
, sG (area, n, areaC, seg, pa, stage, sTb, hkTS, laIm, err) as
( --- group numeric Area, seg and pa
--- compute alpha area from numeric area -------------------
select min(area), n
, case when n <= 999 then right('000' || n, 3)
when n <= 35657 /* 1296 = 36**2 */
then substr('0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ'
, (n + 10998) / 1296 + 1, 1)
|| substr('0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ'
, mod(n + 10998, 1296) / 36 + 1, 1)
|| substr('0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ'
, mod(n + 10998, 36) + 1, 1)
end
, seg, pa
, max(stage)
, max(sTb)
, max(hkTS)
, max(laIm)
, case when sum(case when sTb = 'i' then 1 else 0 end) > 1
then ' multiXbi003' else '' end
||case when sum(case when sTb = 'a' then 1 else 0 end) > 1
then ' multiXba201' else '' end
from sU
group by n, seg, pa
)
, seg(t8, pa, stage, sTb, hkTs, laIm, err) as
( --- compute t8 = eaDba = 'XB' || area || seg ----------------------
select 'XB' || areaC || seg
, smallInt(pa), stage, sTb, hkTs, laIm
, case when area <> '?' and area <> areaC
then ' areaC<>' || area else '' end || err
from sG
)
, uU (eaDba, db, ts, pa, unl, sTb) as
( --- union of both unload tables -----------------------------------
select eaDba, substr(earess, 4, 8)
, substr(earess, 13
, min(8, locate('.', earess || '.', 13) - 13))
, partNumber pa, eaRess, 'c'
from BUA.TXBC021 t
where EYRESS = 5000 and ESRESS = 0
union all select eaDba, substr(earess, 4, 8)
, substr(earess, 13
, min(8, locate('.', earess || '.', 13) - 13))
, partNumber pa, eaRess, 's'
from BUA.TXBC021s t
where EYRESS = 5000 and ESRESS = 0
)
, uG (eaDba, db, ts, pa, unl, sTb, err) as
( --- group uU -----------------------------------------------------
select max(eaDba), db, ts, pa, max(unl), max(sTb)
, case when count(*) <> 1
then ' multiUnl-' || min(sTb) || '-' || max(sTb)
else '' end
from uU
group by db, ts, pa
--- without fetch first or order by we get
--- SQLCODE = -171: THE DATA TYPE, LENGTH, OR VALUE OF ARGUMENT
--- 1 OF INSTR OR LOCATE_IN_STRING IS INVALID ------------
fetch first 2147483647 rows only
)
, unl(eaDba, db, ts, pa, unl, pun, sTb, err) as
( --- check unl, derive pun ----------------------------------------
select eaDba, db, ts, pa
, value(unl, '')
, case when unl is null or unl = '' then ''
when locate_in_string(unl, '.', -1, 2) < 1 then ''
when substr(unl, locate_in_string(unl, '.', -1, 2) + 1
, locate_in_string(unl, '.', -1, 1)
- locate_in_string(unl, '.', -1, 2) - 1)
<> 'SYSREC' then ''
else left(unl, locate_in_string(unl, '.', -1, 2) )
|| 'SYSPCH'
end
, sTb
, case when unl is null or unl = '' then ''
when unl not like 'XB.XB%' then ' unlNotXB.XB%'
when locate('.', unl, 4) <> 12 then ' unlDbLen'
when locate('.', unl, 13) not between 14 and 21
then ' unlTsLen'
when locate_in_string(unl, '.', -1, 2) <1 then ' unl<2q'
when substr(unl, locate_in_string(unl, '.', -1, 2) +1
, locate_in_string(unl, '.', -1, 1)
- locate_in_string(unl, '.', -1, 2) - 1)
<> 'SYSREC' then ' sysrecNotInUnl'
else ''
end || err
from uG
)
, tp (db, ts, pa, t8, err) as
( --- tablePart and tables from db2 catalog -------------------------
select t.dbName, t.tsName, partition, max(left(t.name, 8))
, case when max(left(t.name, 8)) <> min(left(t.name, 8))
then ' multiTables' else '' end
from sysibm.sysTables t
join sysibm.sysTablePart p on
t.dbName = p.dbName and t.tsName = p.tsName
where t.dbName like 'XB%'
and t.type not in ('A', 'V')
group by t.dbName, t.tsName, partition
)
, j2 (db, ts, pa, t8, unl, pun, sTb, err) as
( --- join unl and tp ------------------------------------------------
select value(tp.db, unl.db)
, value(tp.ts, unl.ts)
, value(tp.pa, unl.pa)
, value(tp.t8, unl.eaDba) eaDba
, unl.unl
, unl.pun
, unl.sTb
, case when tp.db is null then ' notInDB2' else '' end
|| case when tp.t8 <> unl.eaDba then ' t8<>eaDba=' || unl.eaDba
else '' end
|| value(unl.err, '') || value(tp.err, '')
from tp
full outer join unl
on tp.db = unl.db and tp.ts = unl.ts and tp.pa = unl.pa
)
--- select count(*), err from j2 group by err;x;
, j3 (db, ts, pa, t8, stage, unl, pun, sTb, hkts, err) as
( --- join segments -------------------------------------------------
select char(value(j2.db, '-noDB-'), 8)
, char(value(j2.ts, j2.t8, seg.t8, '-noTsT8-'), 8) --- avoid dups
, smallInt(value(j2.pa, seg.pa, -99))
, char(value(j2.t8, seg.t8, '-noT8-'), 8)
, case when seg.stage is null and j2.ts like '%WWW%' then '-w'
else value(seg.stage, '-m') end
, case when seg.stage is null and j2.ts like '%WWW%'
then 'XB.MIG.U.' || db || '.' || ts
|| '.P' || right('0000'|| j2.pa, 5)||'.REC.D15338'
else value(j2.unl, '') end
, case when seg.stage is null and j2.ts like '%WWW%'
then 'XB.MIG.U.' || db || '.' || ts || '.PUN.D15338'
else value(j2.pun, '') end
, value(seg.sTb, '') || value(j2.sTb, '')
, value(seg.hkts, '1111-11-11-11.11.11.111111')
, case when j2.db is null then ' notInDB2' else '' end
|| value(seg.err, '') || value(j2.err, '')
from j2
full outer join seg
on j2.t8 = seg.t8 and j2.pa = seg.pa
)
, j (db, ts, pa, stage, unlTst, unl, pun, sTb, t8, err) as
( --- final values and errors ---------------------------------------
select db, ts,pa, stage
, case when stage = '-w' then '2015-12-04-16.00.00.000000'
else hkts end
, unl, pun, sTb, t8
, strip(case when stage = '-m' then ' notInXbi003,Xba201'
when stage not in ('RW', 'CL', 'UL', 'DL', '-a', '-w')
then ' badStage=' || stage
when stage in ('UL', 'DL', '-w') and unl = ''
then ' noUnload '
when stage not in ('CL', 'DL', 'UL', '-w') and unl <> ''
then ' unloadInBadStage'
else '' end
||case when left(unl, 21) <> left(pun, 21) then ' prefUnl<>Pun'
else '' end || err)
from j3
)
select db, ts, pa, stage
, '1111-11-11-11.11.11.111111'
, value(sTb, '')
, unlTst
, unl
, '1111-11-11-11.11.11.111111'
, pun
, ''
, err
from j
$/elarIns/
*/
/*--- load partition stage info from table into stem SG -------------*/
elarDelIns: procedure expose m.
call sqlUpdate , 'delete from' m.uTb
call sqlUpdate 1, sqlCat(mapInline('elarIns'), ' ')
call insRefreshCommit 'elar' m.sql.1.updateCount 'inserts'
return
endProcedure elarIns
/*--- cat the lines of a stem after strip and -- commenting ---------*/
sqlCat: procedure expose m.
parse arg st, sep
res = ''
do sx=1 to m.st.0
if pos('--', m.st.sx) < 1 then
res = res || strip(m.st.sx)' '
else
res = res || strip(left(m.st.sx, pos('--', m.st.sx)-1))' '
end
return res
endProcedure sqlCat
/*--- delete and reload partition table -----------------------------*/
delInsert: procedure expose m.
call sqlUpdate , 'delete from' m.uTb
call sqlUpdatePrepare 7, 'insert into' m.uTb,
'values (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?)'
cUnl = 0
cTru = 0
cErr = 0
do dx=1 to m.sg_errX
o = 'SG.'dx
ii = space(m.o.info, 1)
ee = space(m.o.err , 1)
cUnl = cUnl + (m.o.unl <> '')
cErr = cErr + (ee <> '')
if length(ii) > 70 then do
ii = left(ii, 67)'...'
ee = 'truncInfo' ee
cTru = cTru + 1
end
if length(ee) > 70 then do
ee = left('truncErr' ee, 67)'...'
cTru = cTru + 1
end
call sqlUpdateExecute 7 , m.o.db, m.o.ts, m.o.pa ,
, m.o.stage, m.o.staUpd, m.o.staTb ,
, m.o.unlTst, m.o.unl, m.o.punTst, m.o.pun ,
, ii, ee
end
call insRefreshCommit m.sg.0 "parts," cUnl "unloads," ,
cErr "errors, "cTru "truncates"
say now "reload:" m.sg.0 "parts," cUnl "unloads," ,
cErr "errors," cTru "truncates"
return
endProcedure delInsert
insRefreshCommit: procedure expose m.
parse arg info, err
now = timestampNow()
call sqlUpdate , "insert into" m.uTb ,
"values('', '', -99, '-r', '"m.strt"', ''" ,
|| ", '"m.strt"', 'refresh begin'" ,
|| ", '"now"', 'refresh end'" ,
|| ", '"info"', '"err"')"
call sqlCommit
return
endProcedure insRefreshCommit
/* copy dsnList begin **************************************************
csi interface: see dfs managing catalogs chapt. 11
returncode/reason see message IDC3009I
**********************************************************************/
/*--- specify dsn mask and fields to start a csi catalog search --------
arguments:
m objectPointer
dsnMask specifies the dsns with wildcards:
% 1 character
* 0 - n character in one level
** 0 - n levels
fields a (space separated) list of field names -------------*/
csiOpen: procedure expose m.
parse arg m, dsnMask, fields
m.m.fld.0 = words(fields)
ffix = d2c(m.m.fld.0, 2)
do x=1 to m.m.fld.0
m.m.fld.x = translate(word(fields, x))
ffix = ffix || left(m.m.fld.x, 8)
end
if dsnMask \== '' & right(dsnMask, 1) \== ' ' ,
& pos('*', dsnMask) < 1 & length(dsnMask) < 42 then
dsnMask = dsnMask'.**'
m.m.filt = left(dsnMask, 149) ,
|| left('Y', 3) , /* resume offset 149 */
|| ffix /* csiNumEn offset 152 */
WORKLEN = 1024 * 64
m.m.work = D2C(WORKLEN,4) || COPIES('00'X,WORKLEN-4)
m.m.pos = workLen + 1
return
endProcedure csiOpen
/*--- put the next dsn into m.o and m.o.* (for other fields)
return 1 if next dsn exists 0 otherwise ------------------------*/
csiNext: procedure expose m.
parse arg m, o
usedL = C2D(SUBSTR(m.m.work,9,4)) /* GET AMOUNT OF WORK AREA USED */
px = m.m.pos
do forever
if px > usedL then do
if substr(m.m.filt, 150, 1) \== 'Y' then do
m.m.pos = px
m.o = ''
return 0
end
reason = left('', 4)
ADDRESS LINKPGM 'IGGCSI00 reason m.'m'.filt m.'m'.work'
if rc == 0 & substr(reason, 3, 2) == '0000'x then
nop
else if rc == 4 & substr(reason, 3, 2) == '0464'x then
say 'data set entry with error'
else
call err 'call csi returns' rc,
'rc' c2d(substr(reason, 4,1)),
'reason' c2d(substr(reason, 3,1)),
'module' substr(reason, 1,2)
usedL = C2D(SUBSTR(m.m.work,9,4)) /* GET WORK AREA USED */
numFD = C2D(SUBSTR(m.m.work,13,2)) /* no flds + 1 */
if numFd <> m.m.fld.0 + 1 then
call err 'csiNumFd' numFd 'not' m.m.fld.0 '+' 1
px = 15
iterate
end
eType = substr(m.m.work, px+1, 1)
m.o = strip(substr(m.m.work, px+2, 44), 't')
flag = substr(m.m.work, px, 1)
/* say 'eType' eType m.o 'flag' c2x(flag) */
if eType == '0' then do
if flag \== '00'x & flag \== '40'x then
call err 'flag' c2x(flag) 'for catalog' m.o
px = px + 50 /* length of catalog entry */
iterate
end
else do
if \ abbrev(x2b(c2x(flag)), '101') then
call err 'call csi entry flag' x2b(c2x(flag)),
'rc' c2d(substr(m.m.work, px+49,1)),
'reason' c2d(substr(m.m.work, px+48,1)),
'module' substr(m.m.work, px+46, 2),
'for entry' m.o,
'see qw IDC3009I'
py = px + 46
tl = c2d(substr(m.m.work, py, 2))
pl = py + 4
pf = py + m.m.fld.0 * 2 + 4
do fx = 1 to m.m.fld.0
fi = m.m.fld.fx
fl = c2d(substr(m.m.work, pl, 2))
m.o.fi = substr(m.m.work, pf, fl)
if fi = 'MGMTCLAS' then
m.o.fi = substr(m.o.fi, 3, c2d(left(m.o.fi ,2)))
else if wordPos(fi, 'COMUDSIZ NOBYTTRK') > 0 then
m.o.fi = utc2d(m.o.fi)
pf = pf + fl
pl = pl + 2
end
if py + tl <> pf then
call err 'length mismatch for entry' m.o
m.m.pos = pf
return 1
end
end
endProcedure csiNext
/*--- if dsn is arcived return 'arcive'
if dsn is tape return 'tape'
otherwise return managment class ------------------------------*/
csiArcTape: procedure expose m.
parse arg vo, cl, dt, dsn
if vo = '' then
say err '||| no volume for dsn' dsn
else if vo = 'ARCIVE' then
res = 'arcive'
else if cl <> '' then
res = cl
else if abbrev(vo, 'SHR') then
res = 'SHR'
else
res = 'tape'
if res = 'arcive' then
return res
/*if abbrev(res, 'ar') \= abbrev(dt, '00'x) , */
if abbrev(res, 'ta') \= abbrev(c2x(left(dt, 1)), '7') ,
| (left(res, 1) >= 'A') \= abbrev(dt, '30'x) then
say '||| mismatch cl' cl 'vo' vo 'dt' c2x(dt) 'dsn' dsn
return res
endProcedure csiArcTape
/*--- mbrList with listDS -----------------------------------------*/
mbrList: procedure expose m.
parse arg m, pds
msk = strip(dsnGetMbr(pds))
if msk == '*' then
msk = ''
parse value dsnCsmSys(dsnSetMbr(pds)) with sys '/' dsn
if sys == '*' then do
call adrTso listDS "'"dsn"'" members
oy = m.tso_trap.0 + 99
mFound = 0
mx = 0
do ox=1 to m.tso_trap.0
if mFound then do
if msk \== '' then
if \ match(strip(m.tso_trap.ox), msk) then
iterate
mx = mx +1
m.m.mx = strip(m.tso_trap.ox)
end
else
mFound = m.tso_trap.ox == '--MEMBERS--'
end
end
else do
if msk <> '' then
msk = 'member('translate(msk, '%', '?')')'
mbr_name.0 = -99
call adrCsm "mbrList system("sys") dataset('"dsn"')" msk ,
"index(' ') short"
do mx=1 to mbr_name.0
m.m.mx = strip(mbr_name.mx)
end
mx = mbr_name.0
end
m.m.0 = mx
return mx
endProcedure mbrList
/* copy dsnList end ************************************************/
/* copy sort begin ****************************************************/
sortComparator: procedure expose m.
parse arg cmp, le, ri
if cmp == '' then
cmp = '<<='
if length(cmp) < 6 then
m.sort_comparator = 'cmp =' le cmp ri
else if pos(';', cmp) < 1 then
m.sort_comparator = "aLe =" le"; aRi =" ri"; cmp =" cmp
else
m.sort_comparator = "aLe =" le "; aRi =" ri";" cmp
return
endProcedure sort
sortWords: procedure expose m.
parse arg wrds, cmp
if words(wrds) <= 1 then
return strip(wrds)
m.sort_ii.0 = words(wrds)
do sx=1 to m.sort_ii.0
m.sort_ii.sx = word(wrds, sx)
end
call sort sort_ii, sort_oo, cmp
r = m.sort_oo.1
do sx=2 to m.sort_oo.0
r = r m.sort_oo.sx
end
return r
endProcedure sortWords
sortWordsQ: procedure expose m.
parse arg wrds, cmp
call sortComparator cmp, 'word(le, lx)', 'word(ri, rx)'
return strip(sortWord1(wrds))
endProcedure sortWordsQ
sortWord1: procedure expose m.
parse arg wrds
if words(wrds) <= 1 then
return wrds
h = words(wrds) % 2
le = sortWord1(subWord(wrds, 1, h))
ri = sortWord1(subWord(wrds, h+1))
lx = 1
rx = 1
res = ''
do forever
interpret m.sort_comparator
if cmp then do
res = res word(le, lx)
if lx >= words(le) then
return res subword(ri, rx)
lx = lx + 1
end
else do
res = res word(ri, rx)
if rx >= words(ri) then
return res subword(le, lx)
rx = rx + 1
end
end
endProcedure sortWord1
sort: procedure expose m.
parse arg i, o, cmp
call sortComparator cmp, 'm.l.l0', 'm.r.r0'
call sort1 i, 1, m.i.0, o, 1, sort_work, 1
m.o.0 = m.i.0
return
endProcedure sort
sort1: procedure expose m.
parse arg i, i0, le, o, o0, w, w0
if le <= 3 then do
if le = 3 then do
call sortMerge i, i0, i0+1, i, i0+1, i0+2, w, w0
call sortMerge i, i0+2, i0+3, w, w0, w0+2, o, o0
end
else if le = 2 then
call sortMerge i, i0, i0+1, i, i0+1, i0+2, o, o0
else if le = 1 then
m.o.o0 = m.i.i0
return
end
h = (le + 1) % 2
call sort1 i, i0, h, o, o0+le-h, w, w0
call sort1 i, i0+h, le-h, w, w0, o, o0
call sortMerge o, o0+le-h, o0+le, w, w0, w0+le-h, o, o0
return
endProcedure sort1
sortMerge: procedure expose m.
parse arg l, l0, le, r, r0, re, o, o0
do while l0 < le & r0 < re
interpret m.sort_comparator
if cmp then do
m.o.o0 = m.l.l0
l0 = l0 + 1
end
else do
m.o.o0 = m.r.r0
r0 = r0 + 1
end
o0 = o0 + 1
end
do while l0 < le
m.o.o0 = m.l.l0
l0 = l0 + 1
o0 = o0 + 1
end
do while r0 < re
m.o.o0 = m.r.r0
r0 = r0 + 1
o0 = o0 + 1
end
return
endProcedure sortMerge
/* copy sort end ****************************************************/
/* copy map begin ******************************************************
a map stores values at keys
it may also maintain a list of keys
the basic ideas are similar to the java Interface java.util.Map
contrary to stems we also handle keys longer then 250 bytes
***********************************************************************/
/*--- initialize the module ------------------------------------------*/
mapIni: procedure expose m.
if m.map_ini = 1 then
return
m.map_ini = 1
call mIni
m.map.0 = 0
m.map_inlineSearch = 1
call mapReset map_inlineName, map_inline
return
endProcedure mapIni
mapInline: procedure expose m.
parse arg pName, opt
if mapHasKey(map_inlineName, pName) then do
im = mapGet(map_inlineName, pName)
if pos('l', opt) < 1 & symbol('m.im.0') \== 'VAR' then do
m.im.0 = m.im.lEnd - m.im.lBegin - 1
do ix=1 to m.im.0
m.im.ix = strip(sourceline(ix+m.im.lBegin), 't')
end
end
return im
end
name = '/'
do lx = m.map_inlineSearch to sourceline()
if \ abbrev(sourceline(lx), '$') then
iterate
li = sourceline(lx)
s1 = pos('/', li)+ 1
if s1 < 3 | s1 > 4 then
iterate
s2 = pos('/', li, s1)
if s2 <= s1 then
iterate
if s1 == 3 then do
if name \== substr(li, s1, s2-s1) then
iterate
im = 'map_inline.' || (m.map_inline.0+1)
call mapAdd map_inlineName, name, im
m.im.lBegin = lBeg
m.im.lEnd = lx
m.im.mark = mrk
if name == pName then do
m.map_inlineSearch = lx+1
return mapInline(pName)
end
name = '/'
end
else if \ mapHasKey(map_inlineName,
, substr(li, s1, s2-s1)) then do
lBeg = lx
mrk = substr(li, 2, s1-3)
name = substr(li, s1, s2-s1)
end
else do
name = '/'
end
end
if pos('r', opt) > 0 then
return ''
return err('no inline data /'pName'/ found')
endProcedure mapInline
/*--- create a new map ----------------------------------------------*/
mapNew: procedure expose m.
parse arg opt
m.map.0 = m.map.0 + 1
return mapReset('MAP.'m.map.0 , opt)
endProcedure mapNew
/*--- make an empty map, if opt <> '' maintain stem of keys
('K' in map_keys, '=' in a else in opt) --------------*/
mapReset: procedure expose m.
parse arg a, opt
if symbol('m.map_keys.a') == 'VAR' then
call mapClear a
if opt = '=' then
st = a
else if translate(opt) = 'K' then
st = 'MAP_KEYS.'a
else
st = opt
m.map_keys.a = st
if st \== '' then
m.st.0 = 0
return a
endProcedure
/*--- add a new key value pair to the map ----------------------------*/
mapAdd: procedure expose m.
parse arg a, ky, val
vv = mapAdr(a, ky, 'a')
if vv == '' then
return err('duplicate in mapAdd('a',' ky',' val')')
m.vv = val
return val
endProcedure mapAdd
/*--- change the value at a key or add key value ---------------------*/
mapPut: procedure expose m.
parse arg a, ky, val
vv = mapAdr(a, ky, 'p')
m.vv = val
return val
endProcedure mapPut
/*--- return 1 if key ky exists in map a, 0 otherwise ----------------*/
mapHasKey: procedure expose m.
parse arg a, ky
return mapAdr(a, ky, 'g') \== ''
endProcedure mapHasKey
/*--- return the value of key ky in map a if it exists,
else if called with a third argument return third argument
else issue an error ----------------------------------------*/
mapGet: procedure expose m.
parse arg a, ky
vv = mapAdr(a, ky, 'g')
if vv \== '' then
return m.vv
else if arg() > 2 then
return arg(3)
else
return err('missing key in mapGet('a',' ky')')
endProcedure mapGet
/*--- return a stem of all keys --------------------------------------*/
mapKeys: procedure expose m.
parse arg a
if m.map_keys.a == '' then
call err 'mapKeys('a') with no keys'
return m.map_keys.a
endProcedure mapKeys
/*--- remove a key from the map, do nothing if it is missing ---------*/
mapRemove: procedure expose m.
parse arg a, ky
vv = mapAdr(a, ky, 'g')
if vv == '' then
return ''
if m.map_keys.a \== '' then do
trace ?R /* not tested yet ???wkTest */
k = m.map_keys.a
mx = m.k.0
do i=1 to mx
if m.k.i == ky then do
m.k.i = m.k.mx
m.k.0 = mx - 1
return
end
end
end
val = m.vv
drop m.a.ky
return val
endProcedure mapRemove
/*--- remove all entries ---------------------------------------------*/
mapClear: procedure expose m.
parse arg a
st = mapKeys(a)
liLe = 247 - length(a)
do kx=1 to m.st.0
ky = m.st.kx
drop m.st.kx
if length(ky) < liLe then do
drop m.a.ky
end
else do
adr = mapAdr(a, ky, 'g')
if adr \== '' then do
ha = left(adr, length(adr) - 2)
do i = 1 to m.ha.0
vv = ha'v'i
drop m.ha.i m.vv
end
drop m.ha.0
end
end
end
m.st.0 = 0
return a
endProcedure mapClear
/*--- return the value pointer for a key, '' if non existing
f = 'g' return address if exists otherwise ''
'p' return address if exists otherwise newly added address
'a' return '' if exists otherwise newly added address ---*/
mapAdr: procedure expose m.
parse arg a, ky, f
if length(ky) + length(a) < 247 then do
res = a'.'ky
if symbol('m.res') == 'VAR' then
return copies(res, f \== 'a')
else if f == 'g' then
return ''
end
else do
len = length(ky)
q = len % 2
ha = a'.'len || left(ky, 80) || substr(ky,
, len % 2 - 40, 85-length(len)-length(a)) || right(ky, 80)
if symbol('M.ha.0') == 'VAR' then do
do i=1 to m.ha.0
if m.ha.i == ky then
return copies(ha'v'i, f \== 'a')
end
end
else do
i = 1
end
if f == 'g' then
return ''
if i > 9 then
call err 'overflow long key' y 'in map' a 'hash' ha'.K.'i
m.ha.0 = i
m.ha.i = ky
res = ha'v'i
end
if m.map_keys.a \== '' then
call mAdd m.map_keys.a, ky
return res
endProcedure mapAdr
/* copy map end *******************************************************/
/* copy m begin ********************************************************
we use variables as follows
m. stem m: all global data and object data that must survive
a procedure call (m for memory in Memoria of B5000)
m.<mbr>.** and m.<mbr>_**: every rexx Module (copy) should only
allocate these addresses to avoid address conficts
with <mbr> the name of therexx module
we pass parameters around (e.g. a=address, m=memory, st=stem)
and the called function may use m.a or m.a.subField etc.
gg*: local variable in subroutines without procedure
everything else: temporary data within procedure
every subroutine is declared as procedure expose m.
(also if no m. variable is used, because e.g. of error handling)
the few subroutines that cannot use procedure, should use only
variables starting with gg
***********************************************************************/
/*---make an area -----*/
mNewArea: procedure expose m.
parse arg nm, adr
ax = m.m_area.0 + 1
m.m_area.0 = ax
m.m_area.ax = nm
if adr == '=' then
adr = nm
else if adr == '' then
adr = 'M.'ax
if symbol('m.m_2a.nm') == 'VAR' then
call err 'area name' nm 'already used'
if symbol('m.m_2a.adr') == 'VAR' then
call err 'adr' adr 'for area' nm 'already used'
m.m_2a.adr = adr
m.m_2a.nm = adr
m.adr.0 = 0
m.m_free.adr.0 = 0
return nm
endProcedure mNewArea
mNew: procedure expose m. ggArea
parse arg name
if symbol('m.m_2a.name') \== 'VAR' then
call err 'area' name 'does not exists'
adr = m.m_2a.name
if m.m_free.adr.0 > 0 then do
fx = m.m_free.adr.0
m.m_free.adr.0 = fx-1
return m.m_free.adr.fx
end
m.adr.0 = m.adr.0 + 1
return adr'.'m.adr.0
endProcedure mNew
mFree: procedure expose m.
parse arg m
adr = left(m, lastPos('.', m)-1)
fx = m.m_free.adr.0 + 1
m.m_free.adr.0 = fx
m.m_free.adr.fx = m
return ''
endProcedure mFree
/*--- iterate over all allocate elements of an area ------------------*/
mIterBegin: procedure expose m.
parse arg nm
return m.m_2a.nm'.0'
endProcedure mIterBegin
mIter: procedure expose m.
parse arg cur
if cur == '' then
return ''
lx = lastPos('.', cur)
adr = left(cur, lx-1)
ix = substr(cur, lx+1)
do ix=ix+1 to m.adr.0
n = adr'.'ix
do fx=1 to m.m_free.adr.0 while m.m_free.adr.fx \== n
end
if fx > m.m_free.adr.0 then
return n
end
return ''
endProcedure mIter
/*--- get m.a --------------------------------------------------------*/
mGet: procedure expose m.
parse arg a
return m.a
endProcedure mGet
/*--- put value v into m.a -------------------------------------------*/
mPut: procedure expose m.
parse arg a, v
m.a = v
return v
endProcedure mPut
/*--- cut stem a to length len ---------------------------------------*/
mCut: procedure expose m.
parse arg a, len
m.a.0 = len
return a
endProcedure mCut
/*--- add one or several arguments to stem m.a -----------------------*/
mAdd: procedure expose m.
parse arg a
ix = m.a.0
do ax = 2 to arg()
ix = ix + 1
m.a.ix = arg(ax)
end
m.a.0 = ix
return a'.'ix
endProcedure mAdd
/*--- pop last element from stem m.a ---------------------------------*/
mPop: procedure expose m.
parse arg a
ix = m.a.0
if ix < 1 then
call err 'pop from empty stem' a
m.a.0 = ix-1
return m.a.ix
endProcedure mPop
/*--- create the inverse map of a stem -------------------------------*/
mInverse: procedure expose m.
parse arg a, i
do x=1 to m.a.0
v = m.a.x
m.i.v = x
end
return m.a.0
endProcedure inverse
/*--- add to m.dst.* a (sub)sequence of m.src.* ----------------------*/
mAddSt: procedure expose m.
parse arg dst, src, fx , tx
dx = m.dst.0
if fx == '' then
fx = 1
if tx == '' then
tx = m.src.0
do sx = fx to tx
dx = dx + 1
m.dst.dx = m.src.sx
end
m.dst.0 = dx
return
endProcedure mAddSt
/*--- find position of first occurrence of ele in stem m,
return 0 if nonemove a part of a stem -----------------------*/
mPos: procedure expose m.
parse arg m, ele, sx
if sx == '' then
sx = 1
do x=sx to m.m.0
if m.m.x = ele then
return x
end
return 0
endProcedure mPos
/*--- move a part of a stem ------------------------------------------*/
mMove: procedure expose m.
parse arg m, sx, dx
if dx < sx then do
y = dx
do x=sx to m.m.0
m.m.y = m.m.x
y = y + 1
end
end
else if dx > sx then do
y = m.m.0 + dx - sx
do x=m.m.0 by -1 to sx
m.m.y = m.m.x
y = y - 1
end
end
m.m.0 = m.m.0 + dx - sx
return
endProcedure mMove
/*--- insert a stem into another ------------------------------------*/
mInsert: procedure expose m.
parse arg m, tx, st
call mMove m, tx, tx+m.st.0
do sx=1 to m.st.0
dx = tx-1+sx
m.m.dx = m.st.sx
end
return
endProcedure mInsert
/*--- strip all elements of a stem -----------------------------------*/
mStrip: procedure expose m.
parse arg st, opt
if opt == '' then
opt = 'b'
do x=1 to m.st.0
m.st.x = strip(m.st.x, opt)
end
return st
endProcedure mStrip
/* cat the lines of a stem with separator ---------------------------*/
mCat: procedure expose m.
parse arg st, sep
if m.st.0 < 1 then
return ''
res = m.st.1
do sx=2 to m.st.0
res = res || sep || m.st.sx
end
return res
endProcedure mCat
mIni: procedure expose m.
if m.m_ini == 1 then
return
m.m_ini = 1
call utIni
m.m_area.0 = 0
call mNewArea
return
endProcedure mIni
/* copy m end *********************************************************/
/* copy time begin ****************************************************
timestamp format yz34-56-78-hi.mn.st.abcdef
11.12.14 wk: added lrsn2uniq
11.05.13 wk: numeric digits transparent: in jeder Procedure drin
time2jul, tst externalisiert
**********************************************************************/
/*--- timestamp to julian --------------------------------------------*/
time2jul: procedure expose m.
parse arg yyyy '-' mm '-' dd '-'
if yyyy < 1100 then
yyyy = 11 || right(yyyy, 2, 0)
/* date function cannot convert to julian, only from julian
use b (days since start of time epoch) instead */
return right(yyyy, 2) ,
|| right(date('b', yyyy || mm || dd, 's') ,
- date('b', yyyy-1 || '1231', 's') , 3, 0)
endProcedure time2jul
/*--- current timestamp ---------------------------------------------*/
timestampNow: procedure expose m.
parse value date('s') time('l') with y 5 m 7 d t
return y'-'m'-'d'-'translate(t, '.', ':')
/*--- timestamp expand: expand to timestamp of 26 chars -------------*/
timestampExp: procedure expose m.
parse arg tst .
if length(tst) < m.timeStamp_Len then
return overlay(tst, m.timeStamp_01)
else
return left(tst, timeStamp_Len)
endProcedure tiemstampExp
/*--- timestamp check return '' if correct or error text ------------*/
timestampcheck: procedure expose m.
parse arg tst
if length(tst) < m.timestamp_d0Len | \ abbrev(m.timestamp_11,
, translate(tst, '111111111', '023456789')) then
return 'bad timestamp' tst
parse arg yyyy '-' mo '-' dd '-' hh '.' mm '.' ss '.' u
if mo < 1 | mo > 12 then
return 'bad month in timestamp' tst
if dd < 1 | dd > 3 || substr('101010110101', mo, 1) then
return 'bad day in timestamp' tst
if mo = 2 then
if dd > date('d', yyyy'0301', 's') - 32 then
return 'bad day in timestamp' tst
if hh > 23 & \ abbrev(24 00 00 000000, hh mm ss u) then
return 'bad hour in timestamp' tst
if mm > 59 then
return 'bad minute in timestamp' tst
if ss > 59 then
return 'bad second in timestamp' tst
return ''
endProcedure timestampCheck
/*--- timestamp to days since 1.1.0001 ------------------------------*/
timestamp2days: procedure expose m.
parse arg yyyy '-' mo '-' dd '-' hh '.' mm '.' ss
numeric digits 15
return date('b', yyyy || mo || dd, 's') ,
+ (((hh * 60) + mm) * 60 + ss) / 86400
/*--- timestamp diff in days ----------------------------------------*/
timestampDiff: procedure expose m.
parse arg t1, t2
numeric digits 15
return timestamp2days(t1) - timestamp2Days(t2)
/*--- convert 2 digit year to 4 digit -------------------------------*/
timeYear24: procedure expose m.
parse arg s
y = left(date('S'), 4)
s4 = left(y, 2)right(s, 2, 0)
if s4 > y + 30 then
return (left(y, 2) - 1)substr(s4, 3)
else if s4 < y - 69 then
return (left(y, 2) + 1)substr(s4, 3)
else
return s4
endProcedure timeYear24
/*--- convert 2 or 4 digit year Y (A=0...T=19) ----------------------*/
timeYear2Y: procedure expose m.
parse arg y
return substr('ABCDEFGHIJKLMNOPQRST' , ((y + 10) // 20) + 1, 1)
/*--- convert 2 or 4 digit year Y (A=0...T=19) ----------------------*/
timeY2Year: procedure expose m.
parse arg i
j = pos(i, 'ABCDEFGHIJKLMNOPQRST') - 1
if j < 0 then
call err 'timeYearY24 bad input' i
y = left(date('S'), 4)
r = y - (y+10) // 20 + j
if r < y - 15 then
return r + 20
else if r > y + 4 then
return r - 20
else
return r
endProcedure timeY2Year
/*--- convert numeric month to M (Jan=B=1, dec=12=M) ----------------*/
timeMonth2M: procedure expose m.
parse arg m
return substr('BCDEFGHIJKLM', m, 1)
/*--- convert M to numeric Month (Jan=B=1, dec=12=M) ----------------*/
timeM2Month: procedure expose m.
parse arg m
p = pos(m, 'BCDEFGHIJKLM')
if p= 0 then
call err 'bad M month' m
return right(p, 2, 0)
/*--- convert numeric hour 78 to H8 (A=0..D=3) ----------------------*/
timeHour2H: procedure expose m.
parse arg h
h = right(h, 2, 0)
return substr('ABCD', left(h, 1)+1, 1)substr(h, 2)
/*--- convert H8 to numeric Hour 78 (A=0..D=3) ----------------------*/
timeH2Hour: procedure expose m.
parse arg h
p = pos(left(h, 1), 'ABCD') - 1
if p < 0 | length(h) \== 2 then
call err 'bad H hour' h
return p || substr(h, 2)
/*--- read timeZoneOffset and leapSeconds registers
and set variables for uniq ----------------------------------*/
timeIni: procedure expose m.
parse arg debug
numeric digits 25
/* offsets documented in z/OS Data Areas Vol.1 */
cvtOH = '00000010' /* cvt control block Address */
cvtext2O = x2d('00000560') /* offset to extension 2 */
cvtldtoO = x2d('00000038') /* offset to timezone */
cvtlsoO = x2d('00000050') /* offset to leapSeconds */
/* CVT CB address + extention2 */
cvtExt2A = C2D(STORAGE(cvtOH,4)) + cvtext2O
/* cvtLdto timeZone address +offset */
m.time_Zone = c2d(STORAGE(d2x(cvtext2A+cvtldtoO, 8), 8))
m.time_StckUnit = 1e-6 / 256 / 16
/* cvtLso LeapSecs address +offset */
m.time_Leap = c2d(STORAGE(d2x(cvtext2A+cvtlsoO, 8), 8))
m.time_LZT_TAI10_us16 = (m.time_zone - m.time_leap) % 256
m.time_UQDigits = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ012345678'
/* find lrsn of day 0, 0 out last 6 bits */
m.time_UQZero = x2d(left(timeTAI102Lrsn( ,
'2004-12-31-00.00.22.000000'), 14)) % 64 * 64
m.timeStamp_01 = '0001-01-01-00.00.00.000000'
m.timeStamp_11 = '1111-11-11-11.11.11.111111'
m.timeStamp_99 = '9999-12-31-23.59.59.999999'
m.timeStamp_len = length(m.timestamp_11)
m.timeStamp_d0Llen = m.timestamp_len - 7
m.time_ini = 1
return
endSubroutine timeIni
/*--- TAI10 timestamp yyyy-mm.... -> stckE value char(16)
BLSUETID is described in z/OS MVS IPCS Customization -------*/
timeTAI102stckE: procedure expose m.
/* timestamp must include microSeconds |||*/
parse arg year'-'mo'-'da'-'hh'.'mm'.'secs
tDate = mo'/'da'/'year hh':'mm'.'secs
ACC=left('', 16, '00'x)
ADDRESS LINKPGM "BLSUETID TDATE ACC"
RETURN acc
endProcedure timeTAI102stckE
timeTAI102lrsn: procedure expose m.
parse arg tst
return c2x(left(timeTAI102StckE(tst), 10))
timeLZT2stckE: procedure expose m.
parse arg tst
numeric digits 23
s =timeTAI102StckE(tst)
return d2c(c2d(left(s, 8)) - m.time_lzt_TAI10_us16,8) || substr(s,9)
endProcedure timeLZT2stckE
timeLZT2lrsn: procedure expose m.
parse arg tst
return c2x(left(timeLZT2StckE(tst), 10))
/*--- expand lrsn to 20 hexDigits -------------------------------*/
timeLrsnExp: procedure expose m.
parse arg s
return left(copies('00', length(s) <= 12 & \abbrev(s, 0))s, 20,0)
/*--- expand stcK(e) to 16 Byte ---------------------------------*/
timeStckExp: procedure expose m.
parse arg s
return left(copies('00'x, length(s) <= 8 & s >> '09'x)s, 16,'00'x)
/*--- conversion from StckE Clock Value to TAI10 Timestamp
BLSUETOD is described in z/OS MVS IPCS Customization --------*/
timeStckE2TAI10: PROCEDURE expose m.
parse arg stck /* must be 16 characters ||||| */
TDATE = left('' , 26)
ADDRESS LINKPGM "BLSUETOD stck TDATE"
/* return format : mo/dd/yyyy hh:mm:ss.uuuuuu */
/* Timestamp format: yyyy-mm-dd-hh.mm.ss.uuuuuu */
parse var TDATE mo '/' dd '/' yyyy hh ':' mm ':' secs
RETURN yyyy'-'mo'-'dd'-'hh'.'mm'.'secs
endProcedure timeStckE2TAI10
/*--- conversion from Lrsn Clock Value to TAI10 Timestamp ----------*/
timeLrsn2TAI10:
return timeStckE2TAI10(x2c(arg(1))'000000000000'x)
/*--- conversion from Lrsn Clock Value to LZT Local Zurich Time -----*/
timeStckE2LZT: procedure expose m.
parse arg s
numeric digits 23
return timeStckE2TAI10(d2c(c2d(left(s, 8)) ,
+ m.time_LZT_TAI10_us16, 8) || substr(s, 9))
endProcedure timeStckE2LZT
/*--- conversion from Lrsn Clock Value to LZT Local Zurich Time -----*/
timeLrsn2LZT: procedure expose m.
parse arg lrsn
return timeStckE2LZT(x2c(lrsn) || '000000000000'x)
/* convert a lrsn to the uniq variable ********************************/
timeLrsn2uniq: procedure expose m.
parse arg lrsn
/* unique are bits 0:41 of the TodClock value
minus 31.12.2004 represented
by base 35 by 'ABC...YZ01..8'
*/
lrsn = left(timeLrsnExp(lrsn), 14)
numeric digits 20
diff = x2d(lrsn) - m.time_UQZero
if diff < 0 then
return'< 2005'
return right(i2q(diff % 64, m.time_UQDigits), 8, 'A')
endProcedure timeLrsn2Uniq
/* convert a uniq variable to lrsn ************************************/
timeUniq2lrsn: procedure expose m.
parse arg uniq
numeric digits 15
u1 = q2i(left(uniq, 8, 'A'), m.time_UQDigits) * 64
lrsn = '00'right(d2x(u1 + m.time_UQZero), 12, 0)'000000'
return lrsn
endProcedure uniq2lrsn
/*--- translate a number in q-system to decimal
arg digits givs the digits corresponding to 012.. in the q sysem
q = length(digits) --------------------------------------------*/
q2i: procedure expose m.
parse arg v, digits
b = length(digits)
i = 0
do x = 1 to length(v)
q = substr(v, x, 1)
r = pos(q, digits)
if r < 1 then
call err 'bad digit' q 'in' v 'valid digits' digits
i = i * b + r - 1
end
return i
endProcedure q2i
/*--- translate a decimal number to q-system - inverse of q2i --------*/
i2q: procedure expose m.
parse arg i, digits
if i = 0 then
return left(digits, 1)
b = length(digits)
v = ''
do while i > 0
v = substr(digits, 1 + (i // b), 1) || v
i = i % b
end
return v
endProcedure i2q
/* copy time end -----------------------------------------------------*/
/* copy SQL begin ***************************************************
Achtung: inc generiert sql aus sqlRx, Aenderungen nur in sqlRx|
sql interface
***********************************************************************/
/*--- initialize sql -----------------------------------------------*/
sqlIni: procedure expose m.
if m.sql_ini == 1 then
return
m.sql_ini = 1
call utIni
m.sqlNull = '---'
m.sqlInd = 'sqlInd'
m.sql_defCurs= 49
m.sqlCAMsg = 0
m.sqlSuMsg = 2
m.sql_dbSys = ''
m.sql_csmhost = ''
isInProd = wordPos(sysvar(sysNode), 'RZ2') > 0
m.sql_retOk = 'dne' copies('rod', \ isInProd)
return 0
endProcedure sqlIni
/*--- get default db2System ------------------------------------------*/
sqlDefaultSys: procedure expose m.
parse arg
if sysvar(sysnode) == 'RZ1' then
return 'DBAF'
else if sysvar(sysnode) == 'RZ4' then
return 'DP4G'
else if sysvar(sysnode) == 'RZX' then
return 'DX0G'
else
call err 'no default subsys for' sysvar(sysnode)
endProcedure sqlDefaultSys
/*--- connect to the db2 subsystem sys -----------------------------*/
sqlConnect: procedure expose m.
parse upper arg sys, ggRetOk
call sqlIni
address tso "SUBCOM DSNREXX"
if rc <> 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
if sys = '-' then
return 0
if sys == '' then
sys = sqlDefaultSys()
m.sql_dbSys = sys
ggSqlStmt = 'connect' sys
address dsnRexx ggSqlStmt
if rc = 0 then
return 0
interpret sqlErrorHandler(rc, ggRetOk, ggSqlStmt)
return sqlCode
endProcedure sqlConnect
/*--- diconnect from db2 ---------------------------------------------*/
sqlDisconnect: procedure expose m.
parse arg retOk
if m.sql_dbSys == '' then
return 0
ggSqlStmt = 'disconnect'
m.sql_dbSys = ''
m.sql_csmHost = ''
address dsnRexx ggSqlStmt
if rc = 0 then
return 0
interpret sqlErrorHandler(rc, retOk, ggSqlStmt)
return sqlCode
endProcedure sqlDisconnect
/*--- reset sql cursor 'c'cx fields ----------------------------------*/
sqlReset: procedure expose m.
parse arg cx
m.sql.cx.updateCount = ''
m.sql.cx.resultSet = ''
m.sql.cx.d.sqlD = 'noSqlDA'
m.sql.cx.i.sqlD = 'noDescInp'
m.sql.cx.fetchVars = ''
m.sql.cx.fetchFlds = ''
m.sql.cx.fetchClass = ''
m.sql.cx.type = ''
return
endProcedue sqlReset
/*--- execute a query from sql, with one resultset -------------------*/
sqlQuery: procedure expose m.
parse arg cx, src, feVa, retOk
call sqlReset cx
s1 = ''
if pos(left(feVa, 1), '?:') < 1 then
s1 = 'into :M.SQL.'cx'.D'
res = sqlExec('prepare s'cx s1 'from :src', retOk)
if res < 0 then
return res
call sqlFetchVars cx, feVa
call sqlExec 'declare c'cx 'cursor for s'cx
res = sqlExec('open c'cx, retOk)
if res < 0 then
return res
m.sql.cx.updateCount = sqlErrd.3
m.sql.cx.resultSet = cx
return res
endProcedure sqlQuery
/*--- prepare a query from sql, with one resultset -------------------*/
sqlQueryPrepare: procedure expose m.
parse arg cx, src, feVa, retOk
call sqlReset cx
s1 = ''
if feVa == '' | feVa = 'd' then
s1 = 'into :M.SQL.'cx'.D'
res = sqlExec('prepare s'cx s1 'from :src', retOk)
if res < 0 then
return res
call sqlFetchVars cx, feVa
call sqlExec 'declare c'cx 'cursor for s'cx
return sqlExec('describe input s'cx 'into :M.SQL.'cx'.I')
endProcedure sqlQueryPrepare
sqlQueryExecute: procedure expose m.
parse arg cx retOk
do ix=1 to arg()-1
call sqlDASet cx , 'I', ix, arg(ix+1)
end
res = sqlExec('open c'cx 'using descriptor :M.SQL.'cx'.I', retOk)
if res < 0 then
return res
m.sql.cx.updateCount = sqlErrd.3
m.sql.cx.resultSet = cx
return res
endProcedure sqlQueryExecute
/*--- fetch next row to m.dst.* at end return false ------------------*/
sqlFetch: procedure expose m.
parse arg cx, dst, retOk
fetCode = sqlExec('fetch c'cx 'into' m.sql.cx.fetchVars, 100 retOk)
if fetCode == 100 then
return 0
if fetCode < 0 then
return fetCode
interpret m.sql.cx.fetchCode
return 1
endProcedure sqlFetch
/*--- close cursor 'c'cx ---------------------------------------------*/
sqlClose: procedure expose m.
parse arg cx, retOk
return sqlExec('close c'cx, retOk)
endProcedure sqlClose
/*-- execute an sql with no resultset, but possibly outParms ---------*/
sqlUpdate: procedure expose m.
parse arg cx, src, retOk
m.sql.cx.updateCount = ''
m.sql.cx.resultSet = ''
bx = verify(src, '( ')
if bx > 0 then
fun = translate(word(substr(src, bx), 1))
if fun = 'SET' then do
w2 = translate(word(substr(src, bx), 2))
if \ abbrev(w2, ':') then
return sqlExec('execute immediate :src', retOk)
trace ?r
ex = pos('=', w2)
if ex = 0 then
ex = length(w2)+1
var = strip(substr(w2, 2, ex-2))
if var = '' then
call err 'bad hostVar in' src
m.sql.outVar = var
src2 = 'set :M.sql.out.'var substr(w, ex) subword(src, 3)
return sqlExec(src2, retOk)
end
if fun == 'DECLARE' then do
if 'GLOBAL' == translate(word(substr(src, bx), 2)) then
return sqlExec('execute immediate :src', retOk)
end
res = sqlExec(src, retOk)
if wordPos(fun, 'DELETE INSERT UPDATE') > 0 then
m.sql.cx.updateCount = sqlErrd.3
return res
endProcedure sqlUpdate
/*-- prepare an update -----------------------------------------------*/
sqlUpdatePrepare: procedure expose m.
parse arg cx, src, retOk
res = sqlExec('prepare s'cx 'from :src', retOk)
return sqlExec('describe input s'cx 'into :M.SQL.'cx'.I')
endProcedure sqlUpdatePrepare
/*-- execute a prepared update with the given arguments --------------*/
sqlUpdateExecute: procedure expose m.
parse arg cx retOk
do ix=1 to arg()-1
call sqlDASet cx , 'I', ix, arg(ix+1)
end
res = sqlExec('execute s'cx 'using descriptor :M.SQL.'cx'.I',
, retOk)
m.sql.cx.updateCount = sqlErrd.3
return res
endProcedure sqlUpdateExecute
/*-- execute a query, update or call ---------------------------------*/
sqlExecute: procedure expose m.
parse arg cx, src, retOk
f = translate(word(src, 1))
bx = pos('(', f)
if bx > 0 then
f = left(f, max(1, bx-1))
m.sql.cx.fun = f
if f == 'SELECT' | f == 'WITH' | f == '(' then
return sqlQuery(cx, src, , retOk)
else if f == 'CALL' then
call err 'implement sql call for:' src
else
return sqlUpdate(cx, src, retOk)
endProcedure sqlExecute
/*-- fetch all rows to stem and close --------------------------------*/
sqlFetch2St: procedure expose m.
parse arg cx, dst, retOK
do sx=1 while sqlFetch(cx, dst'.'sx)
end
res = sx-1
m.dst.0 = sx-1
call sqlClose cx
return m.dst.0
endProcedure sqlFetch2St
/*-- execute a query, copy result to stem ----------------------------*/
sql2St: procedure expose m.
parse arg src, dst, feVa, retOK
cx = m.sql_defCurs
res = sqlQuery(cx, src, feVa, retOk)
return sqlFetch2St(cx, dst, retOk)
endProcedure sql2St
/*-- return first column of the only row and close -------------------*/
sqlFetch2One: procedure expose m.
parse arg cx, dst, retNone
f1 = sqlFetch(cx, dst)
if f1 then
f2 = sqlFetch(cx, dst'.2')
call sqlClose cx
if \ f1 then
if retNone \== '' then
return substr(retNone, 2)
else
call err 'sqlFetch2One: no row returned'
else if f2 then
call err 'sqlFetch2One: more than 1 row'
if m.sql.cx.fetchFlds == '' then do
c1 = substr(word(m.sql.cx.fetchVars, 1), 2)
res = value(c1)
return res
end
c1 = word(m.sql.cx.fetchFlds, 1)
return m.dst.c1
endProcedure sqlFetch2One
/*-- execute a query and return first column of the only row
if > 1 row fail, if 0 rows return arg(3) or fail ----------*/
sql2One: procedure expose m.
parse arg src, dst, feVa, retOk, retNone
cx = m.sql_defCurs
call sqlQuery cx, src, feVa, retOk
return sqlFetch2One(cx, dst, retNone)
endProcedure sql2One
/*--- describe table and return sqlDA --------------------------------*/
sqlDescribeTable: procedure expose m.
parse upper arg tb, force
if force == 1 | \ datatype(m.sql.table.tb.sqlD, 'n') then
call sqlExec 'describe table :tb into :M.SQL.TABLE.'tb
return 'SQL.TABLE.'tb
endProcedure sqlDescribeTable
/*--- return select column list for table tb
omit Blobs (blobMax < 0) or substr(blob, 1, blobMax) ----------*/
sqlColList: procedure expose m.
parse arg tb al, blobMax
sd = sqlDescribeTable(tb)
bs = ''
lst = ''
if al \== '' & right(al, 1) \== '.' then
al = al'.'
do sx=1 to m.sd.sqld
if wordPos(m.sd.sx.sqlType, '404 405 408 409 412 413') < 1 then
lst = lst',' al || m.sd.sx.sqlName
else do
bs = bs m.sd.sx.sqlName
if blobMax >= 0 then
lst = lst', length('al || m.sd.sx.sqlName')' ,
m.sd.sx.sqlName'Len' ,
|| ', substr('al || m.sd.sx.sqlName ,
|| ', 1,' blobMax')' m.sd.sx.sqlName
end
end
m.sd.colList = substr(lst, 3)
m.sd.blobs = strip(bs)
return substr(lst, 3)
endProcedure sqlColList
/*--- use describe output to generate column names,
'' use names from ca (rexxified)
nms+ use names, check ca for null values
?('?'?nm)+ use names, check for null if preceeded by ?
:... use string as is
fetchVariables and sqlNull names ---------------------*/
sqlFetchVars: procedure expose m.
parse arg cx, src, cd
st = 'SQL.'cx'.COL'
if abbrev(src, ':') then do
m.sql.cx.fetchVars = src
m.sql.cx.fetchCode = cd
m.sql.cx.fetchFlds = ''
return
end
m.sql.cx.fetchVars = ''
if abbrev(src, '?') then do
call err implement + rxFetchVars ?????? /*
r = substr(src, 2)
do wx=1 to words(src)
cn = word(src, wx)
if abbrev(cn, '?') then
call sqlRexxAddVar substr(cn, 2), 0, 1
else
call sqlRexxAddVar cn, 0, 0
end ????????????? */
end
else if src <> '' then do
ff = src
end
else do
ff = ''
do kx=1 to m.sql.cx.d.sqlD
ff = sqlNiceVarsAdd(ff, m.sql.cx.d.kx.sqlName)
end
end
m.sql.cx.fetchFlds = ff
if m.sql.cx.d.sqlD <> words(ff) then
call err 'sqlFetchVars sqlD='m.sql.cx.d.sqlD ,
'<>' words(ff) 'fields of' ff
sNu = ''
sFe = ''
do kx=1 to m.sql.cx.d.sqlD
nm = word(ff, kx)
sFe = sFe', :m.dst.'nm
if m.sql.cx.d.kx.sqlType // 2 then do
sFe = sFe' :m.dst.'nm'.sqlInd'
sNu = sNu 'if m.dst.'nm'.sqlInd < 0 then' ,
'm.dst.'nm '= m.sqlNull;'
end
end
m.sql.cx.fetchVars = substr(sFe, 3)
m.sql.cx.fetchCode = sNu cd
return
endProcedure sqlFetchVars
/* ????????????
sqlRexxAddVar:
parse arg nm, nicify, hasNulls
nm = sqlAddVar(st, nm, nicify)
if \ hasNulls then
vrs = vrs', :m.dst.'nm
else do
vrs = vrs', :m.dst.'nm ':m.dst.'nm'.sqlInd'
sNu = sNu 'if m.dst.'nm'.sqlInd < 0 then' ,
'm.dst.'nm '= m.sqlNull;'
end
return
endSubroutine sqlRexxAddVar ?????? */
sqlNiceVarsAdd: procedure expose m.
parse arg old, nx rest
upper nx
cx = verifId(nx)
if cx > 0 then /* avoid bad characters for classNew| */
nx = left(nx, cx-1)
if nx <> '' & wordPos(nx, old) < 1 0 then
return old nx
else
return old 'COL' || (words(old) + 1)
endProcedure sqlNiceVarsAdd
/*--- set one value in a DA, handle nulls ----------------------------*/
sqlDASet: procedure expose m.
parse arg cx, da, ix, val
m.sql.cx.da.ix.sqlData = val
m.sql.cx.da.ix.sqlInd = - (val == m.sqlNull)
/* data types schienen einmal nicht zu funktionieren .......
if wordPos(m.da.ix.sqlType, '384 385 388 389 392 393') > 0 then
m.da.ix.sqlType = 448 + (m.da.ix.sqlType // 2) */
return
endProcedure sqlDASet
sqlCommit: procedure expose m.
parse arg src
return sqlUpdate(, 'commit')
endProcedure sqlCommit
/*--- execute sql thru the dsnRexx interface -------------------------*/
sqlExec: /* no procedure, to keep variables sql... */
parse arg ggSqlStmt, ggRetOk
m.sql_HaHi = ''
address dsnRexx 'execSql' ggSqlStmt
/* say 'sqlCode' sqlCode 'rc' rc 'for' ggSqlStmt ggNo */
if rc = 0 then
return 0
interpret sqlErrorHandler(rc, ggRetOk, ggSqlStmt)
return sqlCode
endProcedure sqlExec
sqlExecMsg: procedure expose m.
parse arg sql
sc = sqlExec(sql, '*')
return sqlMsgLine(sc, , sql)
sqlErrorHandler: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
parse arg drC, retOk, verb rest
if drC == 0 then
return 'return 0'
if pos('-', retOK) < 1 then
retOK = retOk m.sql_retOk
if wordPos(drC, '1 -1') < 1 then do
eMsg = "'dsnRexx rc="drC"' sqlmsg()"
end
else if pos('*', retOK) > 0 | wordPos(sqlCode, retOK) > 0 then do
if sqlCode < 0 & pos('say', retOK) > 0 then
return "call outNl errMsg(' }'sqlMsg())"
else
return ''
end
else do
upper verb
if verb == 'DROP' then do
if (sqlCode == -204 | sqlCode == -458) ,
& wordPos('dne', retok) > 0 then
return 'return' sqlCode
if sqlCode = -672 & wordPos('rod', retok) > 0 then do
hahi = m.sql_HaHi || sqlMsgLine(sqlCode,
, 'tb='sqlErrMc ,verb rest)'\n'
haHi = haHi || sqlExecMsg('alter table' SqlErrMc ,
'drop restrict on drop')
call sqlExec verb rest
m.sql_HaHi = hahi
return ''
end
end
if drC < 0 then
eMsg = "sqlmsg()"
else if (sqlCode<>0 | sqlWarn.0 ^==' ') & pos('w',retOK)<1 then
return "call outNl errMsg(' }'sqlMsg()); return" sqlCode
else
return ''
end
if wordPos('rb', retok) > 0 then
eMsg = eMsg " || '\n"sqlExecMsg('rollback')"'"
if wordPos('ret', retok) < 1 then
return "call err" eMsg
m.sql_errRet = 1
return 'call outNl' eMsg
endProcedure sqlErrorHandler
sqlMsgLine: procedure expose m. sqlErrD.
parse arg res, cnt, src, plus
verb = translate(word(src, 1))
if datatype(res, 'n') then
res = 'sqlCode' res
if cnt \== '' then do
res = res',' cnt
vx = wordPos(translate(word(src,1)), 'DELETE INSERT UPDATE')
if datatype(cnt, 'n') then
if vx > 0 then
res = res 'rows' word('deleted inserted updated', vx)
else if cnt <> 0 then
res = res 'rows updated'
end
if plus \== '' then
res = res',' plus
if abbrev(res, ', ') then
res = substr(res, 3)
if src \== '' then do
ll = 75 - length(res)
aa = strip(src)
if length(aa) > ll then
aa = space(aa, 1)
if length(aa) > ll then
aa = left(aa, ll-3)'...'
res = res':' aa
end
return res
endProcedure sqlMsgLine
/*--- send a command to db2 through the TSO dsn processor ------------*/
sqlDsn: procedure expose m.
parse arg st, sys, cmd, rcOk
x = outtrap('M.'st'.')
push 'END'
push cmd
address tso 'DSN SYSTEM('sys')'
rr = rc
x = outtrap(off)
if rr = 0 | rcOk = '*' | wordPos(rr, rcOk) > 0 then
return rr
fl = max(1, m.st.0 - 10)
em = 'rc' rr 'for DSN SYSTEM('sys') cmd' cmd,
'\nOuputlines' fl '-' m.st.0':'
do lx=fl to m.st.0
em = em '\n' strip(m.st.lx, 't')
end
call err em
endProcedure sqlDsn
/*--- issue an sql error message -------------------------------------*/
sqlMsg: /* no procedure, to keep variables sql... */
if \ dataType(sqlCode, 'n') then do
ggRes = 'sqlCode' sqlCode 'not numeric\n'sqlCaMsg()
end
else do
ggRes = sqlDsntiar(sql2CA())
ggWa = sqlMsgWarn()
if ggWa \= '' then
ggRes = ggRes'\nwarnings' ggWa
if m.sqlCAMsg == 1 then
ggRes = ggRes'\n'sqlCaMsg()'\n'sqlCaMsg(sqlCa2Rx(sqlCa))
end
ggSt = 'SQL_HOST'
ggVa = 'SQL_HOST.VAR'
ggBe = 'SQL_HOST.BEF'
call sqlHostVars ggSqlStmt, 12, ggSt
ggFrom = 'ggSqlStmt'
ggW1 = translate(word(ggSqlStmt, 1))
ggW2 = translate(word(ggSqlStmt, 2))
if ggW1 == 'PREPARE' then
ggFrom = sqlHostVarFind(ggSt, 'FROM')
else if ggW1 ggW2 == 'EXECUTE IMMEDIATE' then
ggFrom = sqlHostVarFind(ggSt, 1)
ggPos = 0
if datatype(sqlErrd.5, 'n') & sqlErrd.5 > 0 then do
ggPos = sqlErrd.5
ggRes = ggRes || sqlMsgSrcPos(value(ggFrom), sqlErrd.5)
end
if ggFrom == 'ggSqlStmt' then do
ggRes = ggRes'\nsql =' sqlShorten(ggSqlStmt, 2000, ggPos)
end
else do
ggRes = ggRes'\nsql =' sqlShorten(value(ggFrom), 2000, ggPos)
ggRes = ggRes'\nstmt =' sqlShorten(ggSqlStmt, 2000)
end
ggPref = '\nwith'
do ggXX=1 to m.ggSt.0
if ggFrom = m.ggVa.ggXX then
iterate
ggRes = ggRes || ggPref m.ggBe.ggXX ':'m.ggVa.ggXX ,
'=' sqlShorten(value(m.ggVa.ggXX), 210)
ggPref = '\n '
end
if m.sqlSuMsg == 1 | (m.sqlSuMsg == 2 & m.sql_csmhost \== '') then
ggRes = ggRes'\nsubsys =' m.sql_dbSys ,
|| ', host =' m.sql_csmhost
return ggRes
endSubroutine sqlMsg
sqlShorten: procedure expose m.
parse arg txt, maxL, pos
if length(txt) <= maxL then
return txt
if \ datatype(pos, 'n') | pos < 1 then
pos = 1
ex = pos + min(60, maxL%7)
if ex <= maxL - 4 then
return left(txt, maxL-4) '...'
if ex >= length(txt) then
return left(txt, 67) '...\n'substr(txt, length(txt)-maxL+72)
else
return left(txt, 67) '...\n'substr(txt, ex-maxL+76, maxL-75) ,
'...'
endProcedure sqlShorten
/*--- use dsnTiar to translate sql Info to error text ----------------*/
sqlDsnTiar: procedure expose m.
parse arg ca
if -438 = sqlCa2Rx(ca) then
return '\nSQLCODE = -438:',
'APPLICATION RAISED ERROR WITH sqlState' sqlState ,
'and DIAGNOSTIC TEXT:' sqlErrMc
liLe = 78
msLe = liLe * 10
msg = d2c(msLe,2) || left('', msLe)
len = d2c(liLe, 4)
ADDRESS LINKPGM "DSNTIAR ca msg len"
if rc = 0 then nop
else if rc = 4 then say 'warn linkPgm dsnTiar rc' rc 'sqlCa' ca
else call err 'linkPgm dsnTiar rc' rc 'sqlCa' ca
res = strip(substr(msg, 13, liLe-10))
cx = pos(', ERROR: ', res)
if cx > 0 then
res = left(res, cx-1)':' strip(substr(res, cx+9))
do c=3+liLe by liLe to msLe while substr(msg, c, 10) = ''
res = res'\n 'strip(substr(msg, c+10, liLe-10))
end
return res
endProcedure sqlDsnTiar
/*--- format all rexx sqlCa fields into a message --------------------*/
sqlCaMsg:
return 'sqlCode' sqlCode 'sqlState='sqlState ,
'\n errMC='translate(sqlErrMc, ',', 'ff'x) ,
'\n warnings='sqlWarnCat('+') 'erP='sqlErrP ,
'\n errD.1='sqlErrD.1 '2='sqlErrD.2 '3='sqlErrD.3 ,
'\n errD.4='sqlErrD.4 '5='sqlErrD.5 '6='sqlErrD.6
endProcedure sqlCaMsg
/*--- format the sqlCA into the dsnTiar SQLCA ------------------------*/
sql2Ca: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
if \ (datatype(sqlcode, 'n') & datatype(sqlErrD.1, 'n') ,
& datatype(sqlErrD.3, 'n')) then
return err('sqlCode etc. not numeric\nsqlCa =' sqlCaMsg())
if digits() < 10 then
numeric digits 10
sqlCa = 'SQLCA ' || d2c(136, 4) || d2c(sqlCode, 4) ,
|| d2c(min(70, length(sqlErrMc)), 2)left(sqlErrMc, 70) ,
|| left(sqlErrP, 8) ,
|| d2c(sqlErrD.1, 4)d2c(sqlErrD.2, 4)d2c(sqlErrD.3, 4) ,
|| d2c(sqlErrD.4, 4)d2c(sqlErrD.5, 4)d2c(sqlErrD.6, 4) ,
|| sqlWarnCat() || sqlState
if length(sqlCa) <> 136 then
call err 'sqlCa length' length(sqlCa) 'not 136' ,
'\n'sqlCaMsg() '==>' ca', hex='c2x(ca)
return sqlCa
endProcedure sql2Ca
/*--- extract the fields from the SqlCA and put it to rexx vars ------*/
sqlCA2Rx: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
parse arg ca
numeric digits 10
if length(ca) < 136 | c2d(substr(ca, 9, 4), 4) <> 136 then
call err 'bad sqlCa len' length(ca) 'not 136:' ca', hex='c2x(ca)
sqlCode = c2d(substr(ca, 13 ,4), 4)
sqlErrMC = substr(ca, 19, c2d(substr(ca, 17, 2), 2))
sqlErrP = substr(ca, 89, 8)
do ix=1 to 6
sqlErrD.ix = c2d(substr(ca, 93 + 4 * ix, 4), 4)
end
do ix=0 to 10
sqlWarn.ix = substr(ca, 121 + ix, 1)
end
sqlState = substr(ca, 132, 5)
return sqlCode
endProcedure sqlCA2Rx
/*--- concat the sql warnings with Separator sep --------------------*/
sqlWarnCat: procedure expose m. sqlWarn.
parse arg sep
return sqlWarn.0 || sep,
|| sqlWarn.1||sqlWarn.2||sqlWarn.3||sqlWarn.4||sqlWarn.5||sep ,
|| sqlWarn.6||sqlWarn.7||sqlWarn.8||sqlWarn.9||sqlWarn.10||sep
endProcedure sqlWarnCat
/*--- make the text for sqlWarnings ----------------------------------*/
sqlMsgWarn: procedure expose m. sqlWarn.
r = ''
text =' 1=W var truncated, 1=S scrollable, 1=N nonScrollable,' ,
'2=W nulls in aggregate,' ,
'3=W more cols than vars,' ,
'3=Z more result sets than locators,' ,
'4=W no where, 4=D sensitive dynamic, 4=I insensitive,' ,
'4=S sensitive static,' ,
'5=W not valid sql, 5=1 readOnly, 5=2 readDelete,' ,
'5=3 readDeleteUpdate,' ,
'6=W day changed to month range,' ,
'7=W dec digits truncated,' ,
'8=W char substituted,' ,
'9=W arith excep in count, 9=Z multipe result sets,' ,
'10=W char conversion err in ca,'
do wx = 1 to 10
w = sqlWarn.wx
if w = ' ' then
iterate
t = wx'='w
cx = pos(' 'wx'='w' ', text)
ex = pos(',' , text, cx + 1)
if cx > 0 & ex > cx then
r = r substr(text, cx+1, ex-cx)
else
r = r wx'='w '?,'
end
r = strip(r, 't', ',')
if r = '' & sqlwarn.0 <> '' then
call err 'sqlWarn.0='sqlWarn.0 'but all warns empty'
return r
endProcedure sqlMsgWarn
/*--- show in the source src the point pos (where error occured)
a few lines from src around pos and arrow to pos ----------*/
sqlMsgSrcPos: procedure expose m.
parse arg src, pos
liLe = 68
liCn = 3
afLe = 25
t1 = space(left(src, pos), 1)
t2 = left(' ', substr(src, pos, 1) == ' ' ,
| substr(src, pos+1, 1) == ' ') ,
|| space(substr(src, pos+1), 1)
afLe = min(afLe, length(t2))
if length(t1) + afLe > liLe * liCn then
t1 = '...'right(t1, liLe * liCn - afLe -3)
else if length(t1)+length(t2) > liLe then
t1 = left(' ', (liCn * liLe - length(t1) -afLe) // liLe)||t1
pL = length(t1) // liLe
if length(t2) <= liLe-pL then
tx = t1 || t2
else
tx = t1 || left(t2, liLe-pL-3)'...'
res = '\nsrc' strip(substr(tx, 1, liLe), 't')
do cx=1+liLe by liLe to length(tx)
res = res || '\n +' strip(substr(tx, cx, liLe), 't')
end
loc = 'pos' pos 'of' length(src)
if length(loc)+6 < pL then
return res'\n >' right('>>>'loc'>>>', pL)
else
return res'\n >' left('', pL-1)'<<<'loc'<<<'
endProcdedure sqlMsgSrcPos
/*--- get the hostVars in the sql in src and the word before ---------*/
sqlHostVars: procedure expose m.
parse arg src, cnt, st
cx = 1
sx = 1
do cnt
cx = pos(':', src, cx) + 1
if cx < 2 then
leave
if pos(substr(src, cx, 1), m.ut_rxN1) > 0 then
iterate
ex = verify(src, m.ut_rxDot, 'n', cx)
if ex < 1 then
m.st.var.sx = substr(src, cx)
else
m.st.var.sx = substr(src, cx, ex - cx)
if m.st.var.sx == '' | length(m.st.var.sx) > 100 then
iterate
/* search word before */
do bE = cx-2 by -1 to 1 ,
while substr(src, bE, 1) == ' '
end
do bB = bE by -1 to max(1, bE-20),
while pos(substr(src, bB, 1), m.ut_alfa) > 0
end
if bB < bE & bB >= 0 then
m.st.bef.sx = substr(src, bB+1, bE-bB)
else
m.st.bef.sx = ''
sx = sx + 1
end
m.st.0 = sx-1
return sx
endProcedure sqlHostVars
/*--- find the name of hostvar, by index or by before ----------------*/
sqlHostVarFind: procedure expose m.
parse arg st, fnd
if datatype(fnd, 'n') & fnd <= m.st.0 then
return m.st.var.fnd
do ix=1 to m.st.0
if translate(m.st.bef.ix) = fnd then
return m.st.var.ix
end
return ''
endSubroutine sqlHostVarFind
/* copy SQL end **************************************************/
/* copy err begin *** errorhandling, messages, help ****************/
errIni: procedure expose m.
if m.err.ini == 1 then
return
m.err.ini = 1
m.err.handler = ''
m.err.cleanup = ';'
m.err.opt = ''
parse source m.err.os .
m.err.ispf = 0
m.err.screen = 0
if m.err.os \== 'LINUX' then do
address tso 'profile MsgId' /* brauchen wir in tsoAlloc| */
if sysVar('sysISPF') = 'ACTIVE' then do
m.err.ispf = 1
address ispExec 'vget zScreen shared'
m.err.screen = zScreen
end
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 stackHistory
if ggOpt == '' & m.err.handler \== '' then
interpret m.err.handler
call errSay 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_cat == 'f' then
x = show + stackHistory + by + bad + arithmetic + conversion
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_ddAll') == 'VAR' then
call tsoFree m.tso_ddAll, 1
return
endProcedure errCleanup
/*--- say an errorMessage msg with pref and linesplits --------------*/
errSay: procedure expose m.
parse arg msg
return sayNl(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_cat = 'f'
do while substr(msg, 2, 1) == '}'
parse var msg m.err_cat '}' msg
end
if m.err_cat == ' ' | m.err_cat == 'o' then
return msg
pTxt = ',fatal error,error,input error,scanErr,warning,onlyMsg,'
px = pos(','m.err_cat, pTxt)
if px < 1 then do
px = 1
m.err_cat = 'f'
end
pre = substr(pTxt, px+1, pos(',', pTxt, px+2)-px-1)
if m.err_cat == 's' then
return pre msg
parse source . . s3 . /* current rexx */
return pre 'in' s3':' msg
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
outNL: procedure expose m.
parse arg msg
bx = 1
do lx=1 to 20
ex = pos('\n', msg, bx)
if ex < bx then
leave
call out substr(msg, bx, ex-bx)
bx = ex+2
end
call out substr(msg, bx)
return
endProcedure outNL
/*--- say (part of) the lines of a stem ----------------------------*/
sayNl: procedure expose m.
parse arg msg
bx = 1
do lx=1 to 20
ex = pos('\n', msg, bx)
if ex < bx then
leave
say strip(substr(msg, bx, ex-bx), 't')
bx = ex+2
end
say strip(substr(msg, bx), 't')
return 0
endProcedure sayNl
/*--- 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'
/* 012345678901234567890123456789 */
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'+-*/=()¢!{}<> .:,;?|''"%&#@$£\_'
m.ut_base64 = m.ut_alfUC || m.ut_alfLc || m.ut_digits'+-'
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')
/*--- 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(strip(s, 't')) >= len then
return strip(s, 't')
return left(s, len)
endProcedure lefPad
/*--- right without truncation ---------------------------------------*/
rigPad: procedure expose m
parse arg s, len
if length(strip(s, 'l')) >= len then
return strip(s, 'l')
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
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
utInter: procedure expose m.
interpret arg(1)
return
endProcedure utInter
/* copy ut end ********************************************************/ 6
/* copy out begin ******************************************************
out interface simple with say only
***********************************************************************/
/*--- output a message to the current destination -------------------*/
out: procedure expose m.
parse arg msg
say msg
return
endProcedure out
/* copy out end *****************************************************/
}¢--- A540769.WK.REXX(TECSVUNO) cre=2015-08-19 mod=2015-08-19-20.46.51 A540769 ---
/* rexx **************************************************************
tecSvUnl <dbSys>
searches DatasetNames for XC and XR unloads and punches
loads all partitions from db2Catalog / XC&XR Controltables
into oa1p.???tecSvUnl
with stage, staUpd, unl and Pun DatasetNames and timestamps
6. 7.15 wk neu
*********************************************************************/
call errReset 'h'
call timeIni
call mapIni
parse upper arg dbSys
if dbSys == '' then dbSys = dp4g
if length(dbSys) <> 4 | \ abbrev(dbSys, 'D') then
call errHelp 'bad dbSys:' dbSys
m.uTb = OA1P.tQZ005TecSvUnload
m.strt = timestampNow()
say m.strt 'start tecSvUnl' dbSys 'refresh tecSvUnload'
call sqlConnect dbSys
if wordPos(dbSys, 'DBOF DE0G') > 0 then do
say 'search xc/xr unloads'
call loadCtrl
m.sg_errX = m.sg.0
m.infoErr = ''
call recPun 'XC.XC01A1P.A2*.**'
call recPun 'XC.XC01A1P.A5*.**'
call recPun 'XR.XR01A1P.A2*.**'
call delInsert
do ex = 1 to words(m.infoErr)
e1 = word(m.infoErr, ex)
say e1 m.infoErr.e1
end
end
else if wordPos(dbSys, 'DVBP DEVG') > 0 then do
say 'collect ELAR metaInfo'
call elarDelIns
end
call sqlDisconnect
say timestampNow() 'tecSvUnl end'
exit
/*--- find sysRec und sysPun for each partition
from datasetList
solves the following problems
1) dsn of sysRec and sysPun are not stored in stage tables
2) there is only one pun for several partitions
3) &uniq for pun and rec does NOT agree
we look for the newest punch of this TS after the unload
---------------------------------------------------------------------*/
recPun: procedure expose m.
parse arg msk
call csiOpen cq, msk
pp = 0
cRec = 0
cDup = 0
cPun = 0
do cx=0
if \ csiNext(cq, cr) then
m.cr = '?end'
parse var m.cr p '.' db '.' ts '.' pa '.' ty '.' ti
if \ abbrev(m.cr, pr) then do /* change of table space */
if cx \== 0 then do /* handle old TS */
cRec = cRec + m.lr.0
cPun = cPun + m.lp.0
call sort lp, lq, '>>=' /* sort punch by timestamp */
do lx=1 to m.lr.0 /* for each unl search pun */
rt = word(m.lr.lx, 1)
do ly=1 to m.lq.0 while rt << m.lq.ly
end
if ly > 1 & (ly > m.lq.0 | rt >>= m.lq.ly) then
ly = ly - 1
if ly > 0 then
call unlPunPut m.lr.lx, m.lq.ly
else
call unlPunPut m.lr.lx
end
end
if m.cr == '?end' then do
say timeStampNow() 'recPun' msk':' cx 'dsns,' ,
cPun 'pun,' cRec 'rec,' cDup 'dups'
return
end
pr = p'.'db'.'ts'.' /* ini fields for new TS */
m.lp.0 = 0
m.lr.0 = 0
end
/* analyze fields in dsn */
if verify(pa, '0123456789', 'n',2) >0 | \abbrev(pa,'P') then do
call addErr db, ts, , '-' m.cr, , ', badPart' pa
iterate
end
if ti == '' then
iterate
err = ''
if length(ti) == 8 then
tf = timeLrsn2LZT(timeUniq2Lrsn(ti))
else if \(translate(ti, 000000000, 123456789)='D000000')then do
tf = m.timestamp_01
err = err', badDate' ti
end
else do
tf = '20'translate('12-34-56', substr(ti, 2), '123456'),
|| '-00.00.00'
e1 = timestampCheck(tf)
if e1 <> '' then do
err = err', badDate' ti'>'e1
tf = m.timestamp_01
end
end
if ty == 'SYSPCH' then
call mAdd lp, tf m.cr err
else if ty == 'SYSREC' then do
ly = m.lr.0
lz = word(m.lr.ly, 2)
if \ abbrev(lz, pr || pa) then
call mAdd lr, tf m.cr err
else do /* use newest Rec and put old in error */
cDup = cDup + 1
if tf << m.lr.ly then
m.lr.ly = m.lr.ly err', dupRec' ti
else
m.lr.ly = tf m.cr subWord(m.lr.ly, 3) err,
', dupRec' substr(word(m.lr.ly, 2),
, lastPos('.', word(m.lr.ly, 2))+1)
end
end
else
call errAdd db, ts, pa, tf m.cr, , ', badType' ty
end
return
endProcedure recPun
/*--- put rec and pun in StaGetable stem ----------------------------*/
unlPunPut: procedure expose m.
parse arg unTs aUn e1, puTs aPu e2, e3
parse value aUn with p '.' db '.' ts '.P' pa '.' ty '.' ti
ee = e1 e2 e3
if aPu = '' then do
ee = ',noPunch:' ee
puTs = m.timestamp_01
end
else do
diff = timestampDiff(puTs, unTs)
if (diff < 0 | diff > 0.4) ,
/* ??? & ( diff > 4 | m.lq.ly >> '2015-01-10' ) */ then
ee = ee', punNotSoon' diff
end
if 0 & ee <> '' then
say db ts substr(pa, 2) 'unl' unTs aUn 'pun' puTs aPu ee
ky = db'.'ts'.'format(pa)
if symbol('m.sg.ky') <> 'VAR' then do
call addErr db, ts, format(pa), unTs aUn, puTs aPu,
, ', notInCtrlTb'ee
return
end
else if m.done.ky = 1 then
call err', alreadyDone:' k
m.done.k = 1
o = m.sg.ky
if m.o.unl <> '' then
call err ky 'unl already set' m.o.unl
m.o.unlTst = unTs
m.o.unl = aUn
m.o.punTst = puTs
m.o.pun = aPu
call putInfoErr o, ee
return
endProcedure unlPunPut
putInfoErr: procedure expose m.
parse arg gg, aErr
ee = m.gg.err',' aErr',' m.gg.info
rE = ''
RI = ''
do while ee <> ''
parse var ee a ',' ee
if a = '' then
iterate
parse var a a1 a2
if wordPos(a1, m.infoErr) > 0 then
m.infoErr.a1 = m.infoErr.a1 + 1
else do
m.infoErr = m.infoErr a1
m.infoErr.a1 = 1
end
if a1 = 'dupRec' then
rI = rI',' a
else
rE = rE',' a
end
m.gg.info = space(substr(rI, 3), 1)
m.gg.err = space(substr(rE, 3), 1)
return
endProcedure putInfoErr
addErr: procedure expose m.
m.sg_errX = m.sg_errX + 1
gg = 'SG.'m.sg_errX
parse arg m.gg.db, m.gg.ts, m.gg.pa,
, m.gg.unlTst m.gg.unl e1, m.gg.punTst m.gg.pun e2, e3
ee = e1 e2 e3
ky = m.gg.db'.'m.gg.ts'.'m.gg.pa
if m.done.ky = 1 | \ datatype(m.gg.pa, 'n') ,
| verify(m.gg.pa, '+-0123456789') <> 0 ,
| length(m.gg.pa) > 4 then do
ee = ',pa='m.gg.pa ee
m.gg.pa = m.sg.0 - m.sg_errX
if m.gg.pa <= -3000 then do
ee = ',db='m.gg.db ee
m.gg.db = 'e'm.gg.pa
m.gg.pa = -30000
end
end
m.gg.stage = 'er'
m.gg.staUpd = m.timestamp_01
m.gg.staTb = ''
if timestampCheck(m.gg.unlTst) <> '' then
m.gg.unlTst = m.timestamp_01
if timestampCheck(m.gg.punTs) <> '' then
m.gg.punTs = m.timestamp_01
m.gg.info = ''
m.gg.err = ''
call putInfoErr gg, ee
return
endProcedure addErr
/* select from stage Control tables
$</loadCtrl/
select t.dbname db, t.tsname ts, p.partition pa
, value(XC106_DOC_STATE, XC406_PART_STATUS, xr106_DOC_STATE
, '-' ) stage
, value(XC106_TS_UPDATE, XC406_UPDATE_TS , xr106_TS_UPDATE
, '1111-11-11-11.11.11.111111') staUpd
, case when XC106_DOC_STATE is not null then 'TXC106A1'
when XC406_PART_STATUS is not null then 'TXC406A1'
when Xr106_doc_state is not null then 'TXR106A1'
else left(t.dbName, 2) || 'miss'
end staTb
, '1111-11-11-11.11.11.111111' unlTst, '' unl
, '1111-11-11-11.11.11.111111' punTst, '' pun
, '' info
, '' err
from sysibm.systables t
join sysibm.sysTablePart p
on t.dbName = p.dbName and t.tsName = p.tsName
left join OA1P.TXC106A1
on t.name = 'TXC200A1'
and t.creator
= 'OA1P' || substr(xc106_doc_tabColId, 3, 2)
and xc106_doc_tabColId
= 'XC' || substr(t.creator, 5, 2)
and smallInt(xc106_doc_part_no) = p.partition
and xc106_doc_part_no = right('0000' || p.partition, 4)
left join OA1P.TXC406A1
on t.name like 'TXC5%'
and t.name = xc406_table_name
and smallInt(xc406_part_number) = p.partition
and xc406_part_number = right('000' || p.partition, 3)
left join OA1P.Txr106A1
on t.name like 'TXR2%'
and t.name = xr106_doc_tb_name
and smallInt(xr106_doc_part_no) = p.partition
and xr106_doc_part_no = right('000' || p.partition, 3)
where (t.dbName = 'XC01A1P'
AND (t.tsName LIKE 'A2%' or t.tsName LIKE 'A5%' )
AND NOT (t.tsName = 'A500A'))
or (t.dbName = 'XR01A1P' and t.tsName LIKE 'A2%')
order by t.dbName, t.tsName, p.partition
$/loadCtrl/
*/
/*--- load partition stage info from table into stem SG -------------*/
loadCtrl: procedure expose m.
sql = mCat(mapInline('loadCtrl'), ' ')
call sql2st sql, sg
say timestampNow() m.sg.0 'rows from stage tables'
do sx=1 to m.sg.0
k = strip(m.sg.sx.db)'.'strip(m.sg.sx.TS)'.'format(m.sg.sx.PA)
if symbol('m.sg.k') == 'VAR' then
call err 'duplicate' k
m.sg.k = 'SG.'sx
end
return
endProcedure loadCtrl
/*
$</elarIns/
insert into oa1p.tqz005TecSvUnload
with sU (area, n, seg, pa, stage, sTb, hkTS) as
(
select storageArea, storageArea_N, segment, partNumber, stage
, 'xbi003', LASTHKTS
from BUA.TXBI003 R
union all select '?', enStorAr, right('000' || enSeg, 3), 1, ' a'
, 'xba201', cast(null as timestamp)
from bua.txba201
)
, sC (area, areaN, areaC, seg, pa, stage, sTb, hkTs) as
( /* xba201 may contain storArea Numbers
missing in xbi003, thus calculate area from areaN */
select area, n
, case when n <= 999 then right('000' || n, 3)
when n <= 35657 /* 1296 = 36**2 */
then substr('0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ'
, (n + 10998) / 1296 + 1, 1)
|| substr('0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ'
, mod(n + 10998, 1296) / 36 + 1, 1)
|| substr('0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ'
, mod(n + 10998, 36) + 1, 1)
end
, seg, pa, stage, sTb, hkTS
from sU
)
, seg (seg, t8, pa, stage, sTb, hkTS, err) as
(
select areaC || seg, 'XB' || areaC || seg, pa, max(stage)
, max(sTb), max(hkTS)
, case when min(areaN) <> max(areaN)
then 'areaC=' || areaC || ' >1 Nums'
|| min(sTb) || '-' || max(sTb)
when max(case when area <> '?' and area <> areaC
then 1 else 0 end) = 1
then max(case when area <> '?' and area <> areaC
then 'area=' || area || ' <> calc=' || areaC
else '' end)
when sum(case when sTb = 'xbi003' then 0 else 1 end) > 1
then '>1 xbi003' || areaC || seg || ' ' || pa
when sum(case when sTb = 'xbi003' then 1 else 0 end) > 1
then '>1 xba201' || areaC || seg || ' ' || pa
else '' end
from sC
group by areaC, seg, pa
)
, uU as
(
select substr(earess, 4, 8) db
, substr(earess, 13
, min(8, locate('.', earess || '.', 13) - 13)) ts
, partNumber pa, eaRess, '1' sTb
from BUA.TXBC021 t
where EYRESS = 5000 and ESRESS = 0
union all select substr(earess, 4, 8) db
, substr(earess, 13
, min(8, locate('.', earess || '.', 13) - 13)) ts
, partNumber pa, eaRess, 's' sTb
from BUA.TXBC021s t
where EYRESS = 5000 and ESRESS = 0
)
, unl (db, ts, pa, unl, sTb, err) as
(
select db, ts, pa, max(eaRess) eaRess, max(sTb)
, case when count(*) <> 1
then 'duplicates ' || min(sTb) || '-' || max(sTb)
else max(
case when earess not like 'XB.XB%' then 'eaRess not XB.XB%'
when locate('.', earess, 4) <> 12 then 'eaRess db len'
when locate('.', earess, 13) not between 14 and 21
then 'eaRess ts len'
else '' end) end err
from uU
group by db, ts, pa
)
, tp (db, ts, pa, t8) as
(
select t.dbName, t.tsName, partition, left(t.name, 8)
from sysibm.sysTables t
join sysibm.sysTablePart p on
t.dbName = p.dbName and t.tsName = p.tsName
where t.dbName like 'XB%'
)
, j (db, ts, pa, stage, unl, sTb, hkts, err) as
(
select value(tp.db, unl.db, '?seg')
, value(tp.ts, unl.ts, seg.seg)
, value(tp.pa, unl.pa, seg.pa)
, case when seg.stage is not null then seg.stage
when tp.ts like '%WWW%' then ' w'
else ' ' end
, value(unl.unl, '')
, value(seg.sTb, '') || ',' || value(unl.sTb, '')
, hkTS
, case when tp.db is null then 'notInDB2 ' else '' end
||case when seg.stage not in
('RW', 'CL', 'UL', 'DL', ' ', ' a', ' w', ' r')
then 'badStage=' || stage || ' '
when seg.stage in ('UL', 'DL') and unl is null or unl=''
then 'noUnload '
when seg.stage not in ('CL', 'DL', 'UL') and unl <> ''
then 'UnloadInBadStage '
else '' end
||case when seg.stage is not null then seg.err || ' '
when tp.ts like '%WWW%' then ''
else 'notIn xbi003/xba201 ' end
|| value(unl.err || ' ', '')
/* missing in TXBI003? correct stage? */
from tp
full outer join seg
on tp.t8 = seg.t8 and tp.pa = seg.pa
full outer join unl
on tp.db = unl.db and tp.ts = unl.ts and tp.pa = unl.pa
)
select db, ts, pa, stage
, '0001-01-01-00.00.00'
, case when (sTb = '' or strip(sTb) = ',' or sTb is null)
and stage = ' w'
then 'www' else value(sTb, '') end
, value(hkts, '0001-01-01-00.00.00')
, unl
, '0001-01-01-00.00.00'
, ''
, ''
, err
from j
$/elarIns/
*/
/*--- load partition stage info from table into stem SG -------------*/
elarDelIns: procedure expose m.
call sqlUpdate , 'delete from' m.uTb
call sqlUpdate 1, mCat(mapInline('elarIns'), ' ')
call insRefreshCommit 'elar' m.sql.1.updateCount 'inserts'
return
endProcedure elarIns
/*--- delete and reload partition table -----------------------------*/
delInsert: procedure expose m.
call sqlUpdate , 'delete from' m.uTb
call sqlUpdatePrepare 7, 'insert into' m.uTb,
'values (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?)'
cUnl = 0
cTru = 0
cErr = 0
do dx=1 to m.sg_errX
o = 'SG.'dx
ii = space(m.o.info, 1)
ee = space(m.o.err , 1)
cUnl = cUnl + (m.o.unl <> '')
cErr = cErr + (ee <> '')
if length(ii) > 70 then do
ii = left(ii, 67)'...'
ee = 'truncInfo' ee
cTru = cTru + 1
end
if length(ee) > 70 then do
ee = left('truncErr' ee, 67)'...'
cTru = cTru + 1
end
call sqlUpdateExecute 7 , m.o.db, m.o.ts, m.o.pa ,
, m.o.stage, m.o.staUpd, m.o.staTb ,
, m.o.unlTst, m.o.unl, m.o.punTst, m.o.pun ,
, ii, ee
end
call insRefreshCommit m.sg.0 "parts," cUnl "unloads," ,
cErr "errors, "cTru "truncates"
say now "reload:" m.sg.0 "parts," cUnl "unloads," ,
cErr "errors," cTru "truncates"
return
endProcedure delInsert
insRefreshCommit: procedure expose m.
parse arg info, err
now = timestampNow()
call sqlUpdate , "insert into" m.uTb ,
"values('', '', -99, ' r', '"m.strt"', 'refresh'" ,
|| ", '"m.strt"', 'refresh begin'" ,
|| ", '"now"', 'refresh end'" ,
|| ", '"info"', '"err"')"
call sqlCommit
return
endProcedure insRefreshCommit
/* copy dsnList begin **************************************************
csi interface: see dfs managing catalogs chapt. 11
returncode/reason see message IDC3009I
**********************************************************************/
/*--- specify dsn mask and fields to start a csi catalog search --------
arguments:
m objectPointer
dsnMask specifies the dsns with wildcards:
% 1 character
* 0 - n character in one level
** 0 - n levels
fields a (space separated) list of field names -------------*/
csiOpen: procedure expose m.
parse arg m, dsnMask, fields
m.m.fld.0 = words(fields)
ffix = d2c(m.m.fld.0, 2)
do x=1 to m.m.fld.0
m.m.fld.x = translate(word(fields, x))
ffix = ffix || left(m.m.fld.x, 8)
end
if dsnMask \== '' & right(dsnMask, 1) \== ' ' ,
& pos('*', dsnMask) < 1 & length(dsnMask) < 42 then
dsnMask = dsnMask'.**'
m.m.filt = left(dsnMask, 149) ,
|| left('Y', 3) , /* resume offset 149 */
|| ffix /* csiNumEn offset 152 */
WORKLEN = 1024 * 64
m.m.work = D2C(WORKLEN,4) || COPIES('00'X,WORKLEN-4)
m.m.pos = workLen + 1
return
endProcedure csiOpen
/*--- put the next dsn into m.o and m.o.* (for other fields)
return 1 if next dsn exists 0 otherwise ------------------------*/
csiNext: procedure expose m.
parse arg m, o
usedL = C2D(SUBSTR(m.m.work,9,4)) /* GET AMOUNT OF WORK AREA USED */
px = m.m.pos
do forever
if px > usedL then do
if substr(m.m.filt, 150, 1) \== 'Y' then do
m.m.pos = px
m.o = ''
return 0
end
reason = left('', 4)
ADDRESS LINKPGM 'IGGCSI00 reason m.'m'.filt m.'m'.work'
if rc == 0 & substr(reason, 3, 2) == '0000'x then
nop
else if rc == 4 & substr(reason, 3, 2) == '0464'x then
say 'data set entry with error'
else
call err 'call csi returns' rc,
'rc' c2d(substr(reason, 4,1)),
'reason' c2d(substr(reason, 3,1)),
'module' substr(reason, 1,2)
usedL = C2D(SUBSTR(m.m.work,9,4)) /* GET WORK AREA USED */
numFD = C2D(SUBSTR(m.m.work,13,2)) /* no flds + 1 */
if numFd <> m.m.fld.0 + 1 then
call err 'csiNumFd' numFd 'not' m.m.fld.0 '+' 1
px = 15
iterate
end
eType = substr(m.m.work, px+1, 1)
m.o = strip(substr(m.m.work, px+2, 44), 't')
flag = substr(m.m.work, px, 1)
/* say 'eType' eType m.o 'flag' c2x(flag) */
if eType == '0' then do
if flag \== '00'x & flag \== '40'x then
call err 'flag' c2x(flag) 'for catalog' m.o
px = px + 50 /* length of catalog entry */
iterate
end
else do
if \ abbrev(x2b(c2x(flag)), '101') then
call err 'call csi entry flag' x2b(c2x(flag)),
'rc' c2d(substr(m.m.work, px+49,1)),
'reason' c2d(substr(m.m.work, px+48,1)),
'module' substr(m.m.work, px+46, 2),
'for entry' m.o,
'see qw IDC3009I'
py = px + 46
tl = c2d(substr(m.m.work, py, 2))
pl = py + 4
pf = py + m.m.fld.0 * 2 + 4
do fx = 1 to m.m.fld.0
fi = m.m.fld.fx
fl = c2d(substr(m.m.work, pl, 2))
m.o.fi = substr(m.m.work, pf, fl)
if fi = 'MGMTCLAS' then
m.o.fi = substr(m.o.fi, 3, c2d(left(m.o.fi ,2)))
else if wordPos(fi, 'COMUDSIZ NOBYTTRK') > 0 then
m.o.fi = utc2d(m.o.fi)
pf = pf + fl
pl = pl + 2
end
if py + tl <> pf then
call err 'length mismatch for entry' m.o
m.m.pos = pf
return 1
end
end
endProcedure csiNext
/*--- if dsn is arcived return 'arcive'
if dsn is tape return 'tape'
otherwise return managment class ------------------------------*/
csiArcTape: procedure expose m.
parse arg vo, cl, dt, dsn
if vo = '' then
say err '||| no volume for dsn' dsn
else if vo = 'ARCIVE' then
res = 'arcive'
else if cl <> '' then
res = cl
else if abbrev(vo, 'SHR') then
res = 'SHR'
else
res = 'tape'
if res = 'arcive' then
return res
/*if abbrev(res, 'ar') \= abbrev(dt, '00'x) , */
if abbrev(res, 'ta') \= abbrev(c2x(left(dt, 1)), '7') ,
| (left(res, 1) >= 'A') \= abbrev(dt, '30'x) then
say '||| mismatch cl' cl 'vo' vo 'dt' c2x(dt) 'dsn' dsn
return res
endProcedure csiArcTape
/*--- mbrList with listDS -----------------------------------------*/
mbrList: procedure expose m.
parse arg m, pds
msk = strip(dsnGetMbr(pds))
if msk == '*' then
msk = ''
parse value dsnCsmSys(dsnSetMbr(pds)) with sys '/' dsn
if sys == '*' then do
call adrTso listDS "'"dsn"'" members
oy = m.tso_trap.0 + 99
mFound = 0
mx = 0
do ox=1 to m.tso_trap.0
if mFound then do
if msk \== '' then
if \ match(strip(m.tso_trap.ox), msk) then
iterate
mx = mx +1
m.m.mx = strip(m.tso_trap.ox)
end
else
mFound = m.tso_trap.ox == '--MEMBERS--'
end
end
else do
if msk <> '' then
msk = 'member('translate(msk, '%', '?')')'
mbr_name.0 = -99
call adrCsm "mbrList system("sys") dataset('"dsn"')" msk ,
"index(' ') short"
do mx=1 to mbr_name.0
m.m.mx = strip(mbr_name.mx)
end
mx = mbr_name.0
end
m.m.0 = mx
return mx
endProcedure mbrList
/* copy dsnList end ************************************************/
/* copy sort begin ****************************************************/
sortComparator: procedure expose m.
parse arg cmp, le, ri
if cmp == '' then
cmp = '<<='
if length(cmp) < 6 then
m.sort_comparator = 'cmp =' le cmp ri
else if pos(';', cmp) < 1 then
m.sort_comparator = "aLe =" le"; aRi =" ri"; cmp =" cmp
else
m.sort_comparator = "aLe =" le "; aRi =" ri";" cmp
return
endProcedure sort
sortWords: procedure expose m.
parse arg wrds, cmp
if words(wrds) <= 1 then
return strip(wrds)
m.sort_ii.0 = words(wrds)
do sx=1 to m.sort_ii.0
m.sort_ii.sx = word(wrds, sx)
end
call sort sort_ii, sort_oo, cmp
r = m.sort_oo.1
do sx=2 to m.sort_oo.0
r = r m.sort_oo.sx
end
return r
endProcedure sortWords
sortWordsQ: procedure expose m.
parse arg wrds, cmp
call sortComparator cmp, 'word(le, lx)', 'word(ri, rx)'
return strip(sortWord1(wrds))
endProcedure sortWordsQ
sortWord1: procedure expose m.
parse arg wrds
if words(wrds) <= 1 then
return wrds
h = words(wrds) % 2
le = sortWord1(subWord(wrds, 1, h))
ri = sortWord1(subWord(wrds, h+1))
lx = 1
rx = 1
res = ''
do forever
interpret m.sort_comparator
if cmp then do
res = res word(le, lx)
if lx >= words(le) then
return res subword(ri, rx)
lx = lx + 1
end
else do
res = res word(ri, rx)
if rx >= words(ri) then
return res subword(le, lx)
rx = rx + 1
end
end
endProcedure sortWord1
sort: procedure expose m.
parse arg i, o, cmp
call sortComparator cmp, 'm.l.l0', 'm.r.r0'
call sort1 i, 1, m.i.0, o, 1, sort_work, 1
m.o.0 = m.i.0
return
endProcedure sort
sort1: procedure expose m.
parse arg i, i0, le, o, o0, w, w0
if le <= 3 then do
if le = 3 then do
call sortMerge i, i0, i0+1, i, i0+1, i0+2, w, w0
call sortMerge i, i0+2, i0+3, w, w0, w0+2, o, o0
end
else if le = 2 then
call sortMerge i, i0, i0+1, i, i0+1, i0+2, o, o0
else if le = 1 then
m.o.o0 = m.i.i0
return
end
h = (le + 1) % 2
call sort1 i, i0, h, o, o0+le-h, w, w0
call sort1 i, i0+h, le-h, w, w0, o, o0
call sortMerge o, o0+le-h, o0+le, w, w0, w0+le-h, o, o0
return
endProcedure sort1
sortMerge: procedure expose m.
parse arg l, l0, le, r, r0, re, o, o0
do while l0 < le & r0 < re
interpret m.sort_comparator
if cmp then do
m.o.o0 = m.l.l0
l0 = l0 + 1
end
else do
m.o.o0 = m.r.r0
r0 = r0 + 1
end
o0 = o0 + 1
end
do while l0 < le
m.o.o0 = m.l.l0
l0 = l0 + 1
o0 = o0 + 1
end
do while r0 < re
m.o.o0 = m.r.r0
r0 = r0 + 1
o0 = o0 + 1
end
return
endProcedure sortMerge
/* copy sort end ****************************************************/
/* copy map begin ******************************************************
a map stores values at keys
it may also maintain a list of keys
the basic ideas are similar to the java Interface java.util.Map
contrary to stems we also handle keys longer then 250 bytes
***********************************************************************/
/*--- initialize the module ------------------------------------------*/
mapIni: procedure expose m.
if m.map_ini = 1 then
return
m.map_ini = 1
call mIni
m.map.0 = 0
m.map_inlineSearch = 1
call mapReset map_inlineName, map_inline
return
endProcedure mapIni
mapInline: procedure expose m.
parse arg pName, opt
if mapHasKey(map_inlineName, pName) then do
im = mapGet(map_inlineName, pName)
if pos('l', opt) < 1 & symbol('m.im.0') \== 'VAR' then do
m.im.0 = m.im.lEnd - m.im.lBegin - 1
do ix=1 to m.im.0
m.im.ix = strip(sourceline(ix+m.im.lBegin), 't')
end
end
return im
end
name = '/'
do lx = m.map_inlineSearch to sourceline()
if \ abbrev(sourceline(lx), '$') then
iterate
li = sourceline(lx)
s1 = pos('/', li)+ 1
if s1 < 3 | s1 > 4 then
iterate
s2 = pos('/', li, s1)
if s2 <= s1 then
iterate
if s1 == 3 then do
if name \== substr(li, s1, s2-s1) then
iterate
im = 'map_inline.' || (m.map_inline.0+1)
call mapAdd map_inlineName, name, im
m.im.lBegin = lBeg
m.im.lEnd = lx
m.im.mark = mrk
if name == pName then do
m.map_inlineSearch = lx+1
return mapInline(pName)
end
name = '/'
end
else if \ mapHasKey(map_inlineName,
, substr(li, s1, s2-s1)) then do
lBeg = lx
mrk = substr(li, 2, s1-3)
name = substr(li, s1, s2-s1)
end
else do
name = '/'
end
end
if pos('r', opt) > 0 then
return ''
return err('no inline data /'pName'/ found')
endProcedure mapInline
/*--- create a new map ----------------------------------------------*/
mapNew: procedure expose m.
parse arg opt
m.map.0 = m.map.0 + 1
return mapReset('MAP.'m.map.0 , opt)
endProcedure mapNew
/*--- make an empty map, if opt <> '' maintain stem of keys
('K' in map_keys, '=' in a else in opt) --------------*/
mapReset: procedure expose m.
parse arg a, opt
if symbol('m.map_keys.a') == 'VAR' then
call mapClear a
if opt = '=' then
st = a
else if translate(opt) = 'K' then
st = 'MAP_KEYS.'a
else
st = opt
m.map_keys.a = st
if st \== '' then
m.st.0 = 0
return a
endProcedure
/*--- add a new key value pair to the map ----------------------------*/
mapAdd: procedure expose m.
parse arg a, ky, val
vv = mapAdr(a, ky, 'a')
if vv == '' then
return err('duplicate in mapAdd('a',' ky',' val')')
m.vv = val
return val
endProcedure mapAdd
/*--- change the value at a key or add key value ---------------------*/
mapPut: procedure expose m.
parse arg a, ky, val
vv = mapAdr(a, ky, 'p')
m.vv = val
return val
endProcedure mapPut
/*--- return 1 if key ky exists in map a, 0 otherwise ----------------*/
mapHasKey: procedure expose m.
parse arg a, ky
return mapAdr(a, ky, 'g') \== ''
endProcedure mapHasKey
/*--- return the value of key ky in map a if it exists,
else if called with a third argument return third argument
else issue an error ----------------------------------------*/
mapGet: procedure expose m.
parse arg a, ky
vv = mapAdr(a, ky, 'g')
if vv \== '' then
return m.vv
else if arg() > 2 then
return arg(3)
else
return err('missing key in mapGet('a',' ky')')
endProcedure mapGet
/*--- return a stem of all keys --------------------------------------*/
mapKeys: procedure expose m.
parse arg a
if m.map_keys.a == '' then
call err 'mapKeys('a') with no keys'
return m.map_keys.a
endProcedure mapKeys
/*--- remove a key from the map, do nothing if it is missing ---------*/
mapRemove: procedure expose m.
parse arg a, ky
vv = mapAdr(a, ky, 'g')
if vv == '' then
return ''
if m.map_keys.a \== '' then do
trace ?R /* not tested yet ???wkTest */
k = m.map_keys.a
mx = m.k.0
do i=1 to mx
if m.k.i == ky then do
m.k.i = m.k.mx
m.k.0 = mx - 1
return
end
end
end
val = m.vv
drop m.a.ky
return val
endProcedure mapRemove
/*--- remove all entries ---------------------------------------------*/
mapClear: procedure expose m.
parse arg a
st = mapKeys(a)
liLe = 247 - length(a)
do kx=1 to m.st.0
ky = m.st.kx
drop m.st.kx
if length(ky) < liLe then do
drop m.a.ky
end
else do
adr = mapAdr(a, ky, 'g')
if adr \== '' then do
ha = left(adr, length(adr) - 2)
do i = 1 to m.ha.0
vv = ha'v'i
drop m.ha.i m.vv
end
drop m.ha.0
end
end
end
m.st.0 = 0
return a
endProcedure mapClear
/*--- return the value pointer for a key, '' if non existing
f = 'g' return address if exists otherwise ''
'p' return address if exists otherwise newly added address
'a' return '' if exists otherwise newly added address ---*/
mapAdr: procedure expose m.
parse arg a, ky, f
if length(ky) + length(a) < 247 then do
res = a'.'ky
if symbol('m.res') == 'VAR' then
return copies(res, f \== 'a')
else if f == 'g' then
return ''
end
else do
len = length(ky)
q = len % 2
ha = a'.'len || left(ky, 80) || substr(ky,
, len % 2 - 40, 85-length(len)-length(a)) || right(ky, 80)
if symbol('M.ha.0') == 'VAR' then do
do i=1 to m.ha.0
if m.ha.i == ky then
return copies(ha'v'i, f \== 'a')
end
end
else do
i = 1
end
if f == 'g' then
return ''
if i > 9 then
call err 'overflow long key' y 'in map' a 'hash' ha'.K.'i
m.ha.0 = i
m.ha.i = ky
res = ha'v'i
end
if m.map_keys.a \== '' then
call mAdd m.map_keys.a, ky
return res
endProcedure mapAdr
/* copy map end *******************************************************/
/* copy m begin ********************************************************
we use variables as follows
m. stem m: all global data and object data that must survive
a procedure call (m for memory in Memoria of B5000)
m.<mbr>.** and m.<mbr>_**: every rexx Module (copy) should only
allocate these addresses to avoid address conficts
with <mbr> the name of therexx module
we pass parameters around (e.g. a=address, m=memory, st=stem)
and the called function may use m.a or m.a.subField etc.
gg*: local variable in subroutines without procedure
everything else: temporary data within procedure
every subroutine is declared as procedure expose m.
(also if no m. variable is used, because e.g. of error handling)
the few subroutines that cannot use procedure, should use only
variables starting with gg
***********************************************************************/
/*---make an area -----*/
mNewArea: procedure expose m.
parse arg nm, adr
ax = m.m_area.0 + 1
m.m_area.0 = ax
m.m_area.ax = nm
if adr == '=' then
adr = nm
else if adr == '' then
adr = 'M.'ax
if symbol('m.m_2a.nm') == 'VAR' then
call err 'area name' nm 'already used'
if symbol('m.m_2a.adr') == 'VAR' then
call err 'adr' adr 'for area' nm 'already used'
m.m_2a.adr = adr
m.m_2a.nm = adr
m.adr.0 = 0
m.m_free.adr.0 = 0
return nm
endProcedure mNewArea
mNew: procedure expose m. ggArea
parse arg name
if symbol('m.m_2a.name') \== 'VAR' then
call err 'area' name 'does not exists'
adr = m.m_2a.name
if m.m_free.adr.0 > 0 then do
fx = m.m_free.adr.0
m.m_free.adr.0 = fx-1
return m.m_free.adr.fx
end
m.adr.0 = m.adr.0 + 1
return adr'.'m.adr.0
endProcedure mNew
mFree: procedure expose m.
parse arg m
adr = left(m, lastPos('.', m)-1)
fx = m.m_free.adr.0 + 1
m.m_free.adr.0 = fx
m.m_free.adr.fx = m
return ''
endProcedure mFree
/*--- iterate over all allocate elements of an area ------------------*/
mIterBegin: procedure expose m.
parse arg nm
return m.m_2a.nm'.0'
endProcedure mIterBegin
mIter: procedure expose m.
parse arg cur
if cur == '' then
return ''
lx = lastPos('.', cur)
adr = left(cur, lx-1)
ix = substr(cur, lx+1)
do ix=ix+1 to m.adr.0
n = adr'.'ix
do fx=1 to m.m_free.adr.0 while m.m_free.adr.fx \== n
end
if fx > m.m_free.adr.0 then
return n
end
return ''
endProcedure mIter
/*--- get m.a --------------------------------------------------------*/
mGet: procedure expose m.
parse arg a
return m.a
endProcedure mGet
/*--- put value v into m.a -------------------------------------------*/
mPut: procedure expose m.
parse arg a, v
m.a = v
return v
endProcedure mPut
/*--- cut stem a to length len ---------------------------------------*/
mCut: procedure expose m.
parse arg a, len
m.a.0 = len
return a
endProcedure mCut
/*--- add one or several arguments to stem m.a -----------------------*/
mAdd: procedure expose m.
parse arg a
ix = m.a.0
do ax = 2 to arg()
ix = ix + 1
m.a.ix = arg(ax)
end
m.a.0 = ix
return a'.'ix
endProcedure mAdd
/*--- pop last element from stem m.a ---------------------------------*/
mPop: procedure expose m.
parse arg a
ix = m.a.0
if ix < 1 then
call err 'pop from empty stem' a
m.a.0 = ix-1
return m.a.ix
endProcedure mPop
/*--- create the inverse map of a stem -------------------------------*/
mInverse: procedure expose m.
parse arg a, i
do x=1 to m.a.0
v = m.a.x
m.i.v = x
end
return m.a.0
endProcedure inverse
/*--- add to m.dst.* a (sub)sequence of m.src.* ----------------------*/
mAddSt: procedure expose m.
parse arg dst, src, fx , tx
dx = m.dst.0
if fx == '' then
fx = 1
if tx == '' then
tx = m.src.0
do sx = fx to tx
dx = dx + 1
m.dst.dx = m.src.sx
end
m.dst.0 = dx
return
endProcedure mAddSt
/*--- find position of first occurrence of ele in stem m,
return 0 if nonemove a part of a stem -----------------------*/
mPos: procedure expose m.
parse arg m, ele, sx
if sx == '' then
sx = 1
do x=sx to m.m.0
if m.m.x = ele then
return x
end
return 0
endProcedure mPos
/*--- move a part of a stem ------------------------------------------*/
mMove: procedure expose m.
parse arg m, sx, dx
if dx < sx then do
y = dx
do x=sx to m.m.0
m.m.y = m.m.x
y = y + 1
end
end
else if dx > sx then do
y = m.m.0 + dx - sx
do x=m.m.0 by -1 to sx
m.m.y = m.m.x
y = y - 1
end
end
m.m.0 = m.m.0 + dx - sx
return
endProcedure mMove
/*--- insert a stem into another ------------------------------------*/
mInsert: procedure expose m.
parse arg m, tx, st
call mMove m, tx, tx+m.st.0
do sx=1 to m.st.0
dx = tx-1+sx
m.m.dx = m.st.sx
end
return
endProcedure mInsert
/*--- strip all elements of a stem -----------------------------------*/
mStrip: procedure expose m.
parse arg st, opt
if opt == '' then
opt = 'b'
do x=1 to m.st.0
m.st.x = strip(m.st.x, opt)
end
return st
endProcedure mStrip
/* cat the lines of a stem with separator ---------------------------*/
mCat: procedure expose m.
parse arg st, sep
if m.st.0 < 1 then
return ''
res = m.st.1
do sx=2 to m.st.0
res = res || sep || m.st.sx
end
return res
endProcedure mCat
mIni: procedure expose m.
if m.m_ini == 1 then
return
m.m_ini = 1
call utIni
m.m_area.0 = 0
call mNewArea
return
endProcedure mIni
/* copy m end *********************************************************/
/* copy time begin ****************************************************
timestamp format yz34-56-78-hi.mn.st.abcdef
11.12.14 wk: added lrsn2uniq
11.05.13 wk: numeric digits transparent: in jeder Procedure drin
time2jul, tst externalisiert
**********************************************************************/
/*--- timestamp to julian --------------------------------------------*/
time2jul: procedure expose m.
parse arg yyyy '-' mm '-' dd '-'
if yyyy < 1100 then
yyyy = 11 || right(yyyy, 2, 0)
/* date function cannot convert to julian, only from julian
use b (days since start of time epoch) instead */
return right(yyyy, 2) ,
|| right(date('b', yyyy || mm || dd, 's') ,
- date('b', yyyy-1 || '1231', 's') , 3, 0)
endProcedure time2jul
/*--- current timestamp ---------------------------------------------*/
timestampNow: procedure expose m.
parse value date('s') time('l') with y 5 m 7 d t
return y'-'m'-'d'-'translate(t, '.', ':')
/*--- timestamp expand: expand to timestamp of 26 chars -------------*/
timestampExp: procedure expose m.
parse arg tst .
if length(tst) < m.timeStamp_Len then
return overlay(tst, m.timeStamp_01)
else
return left(tst, timeStamp_Len)
endProcedure tiemstampExp
/*--- timestamp check return '' if correct or error text ------------*/
timestampcheck: procedure expose m.
parse arg tst
if length(tst) < m.timestamp_d0Len | \ abbrev(m.timestamp_00,
, translate(tst, '000000000', '123456789')) then
return 'bad timestamp' tst
parse arg yyyy '-' mo '-' dd '-' hh '.' mm '.' ss '.' u
if mo < 1 | mo > 12 then
return 'bad month in timestamp' tst
if dd < 1 | dd > 3 || substr('101010110101', mo, 1) then
return 'bad day in timestamp' tst
if mo = 2 then
if dd > date('d', yyyy'0301', 's') - 32 then
return 'bad day in timestamp' tst
if hh > 23 & \ abbrev(24 00 00 000000, hh mm ss u) then
return 'bad hour in timestamp' tst
if mm > 59 then
return 'bad minute in timestamp' tst
if ss > 59 then
return 'bad second in timestamp' tst
return ''
endProcedure timestampCheck
/*--- timestamp to days since 1.1.0001 ------------------------------*/
timestamp2days: procedure expose m.
parse arg yyyy '-' mo '-' dd '-' hh '.' mm '.' ss
numeric digits 15
return date('b', yyyy || mo || dd, 's') ,
+ (((hh * 60) + mm) * 60 + ss) / 86400
/*--- timestamp diff in days ----------------------------------------*/
timestampDiff: procedure expose m.
parse arg t1, t2
numeric digits 15
return timestamp2days(t1) - timestamp2Days(t2)
/*--- convert 2 digit year to 4 digit -------------------------------*/
timeYear24: procedure expose m.
parse arg s
y = left(date('S'), 4)
s4 = left(y, 2)right(s, 2, 0)
if s4 > y + 30 then
return (left(y, 2) - 1)substr(s4, 3)
else if s4 < y - 69 then
return (left(y, 2) + 1)substr(s4, 3)
else
return s4
endProcedure timeYear24
/*--- convert 2 or 4 digit year Y (A=0...T=19) ----------------------*/
timeYear2Y: procedure expose m.
parse arg y
return substr('ABCDEFGHIJKLMNOPQRST' , ((y + 10) // 20) + 1, 1)
/*--- convert 2 or 4 digit year Y (A=0...T=19) ----------------------*/
timeY2Year: procedure expose m.
parse arg i
j = pos(i, 'ABCDEFGHIJKLMNOPQRST') - 1
if j < 0 then
call err 'timeYearY24 bad input' i
y = left(date('S'), 4)
r = y - (y+10) // 20 + j
if r < y - 15 then
return r + 20
else if r > y + 4 then
return r - 20
else
return r
endProcedure timeY2Year
/*--- convert numeric month to M (Jan=B=1, dec=12=M) ----------------*/
timeMonth2M: procedure expose m.
parse arg m
return substr('BCDEFGHIJKLM', m, 1)
/*--- convert M to numeric Month (Jan=B=1, dec=12=M) ----------------*/
timeM2Month: procedure expose m.
parse arg m
p = pos(m, 'BCDEFGHIJKLM')
if p= 0 then
call err 'bad M month' m
return right(p, 2, 0)
/*--- convert numeric hour 78 to H8 (A=0..D=3) ----------------------*/
timeHour2H: procedure expose m.
parse arg h
h = right(h, 2, 0)
return substr('ABCD', left(h, 1)+1, 1)substr(h, 2)
/*--- convert H8 to numeric Hour 78 (A=0..D=3) ----------------------*/
timeH2Hour: procedure expose m.
parse arg h
p = pos(left(h, 1), 'ABCD') - 1
if p < 0 | length(h) \== 2 then
call err 'bad H hour' h
return p || substr(h, 2)
/*--- read timeZoneOffset and leapSeconds registers
and set variables for uniq ----------------------------------*/
timeIni: procedure expose m.
parse arg debug
numeric digits 25
/* offsets documented in z/OS Data Areas Vol.1 */
cvtOH = '00000010' /* cvt control block Address */
cvtext2O = x2d('00000560') /* offset to extension 2 */
cvtldtoO = x2d('00000038') /* offset to timezone */
cvtlsoO = x2d('00000050') /* offset to leapSeconds */
/* CVT CB address + extention2 */
cvtExt2A = C2D(STORAGE(cvtOH,4)) + cvtext2O
/* cvtLdto timeZone address +offset */
m.time_Zone = c2d(STORAGE(d2x(cvtext2A+cvtldtoO, 8), 8))
m.time_StckUnit = 1e-6 / 256 / 16
/* cvtLso LeapSecs address +offset */
m.time_Leap = c2d(STORAGE(d2x(cvtext2A+cvtlsoO, 8), 8))
m.time_LZT_TAI10_us16 = (m.time_zone - m.time_leap) % 256
m.time_UQDigits = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ012345678'
/* find lrsn of day 0, 0 out last 6 bits */
m.time_UQZero = x2d(left(timeTAI102Lrsn( ,
'2004-12-31-00.00.22.000000'), 14)) % 64 * 64
m.timeStamp_00 = '0000-00-00-00.00.00.000000'
m.timeStamp_01 = '0001-01-01-00.00.00.000000'
m.timeStamp_99 = '9999-12-31-23.59.59.999999'
m.timeStamp_len = length(m.timestamp_00)
m.timeStamp_d0Llen = m.timestamp_len - 7
m.time_ini = 1
return
endSubroutine timeIni
/*--- TAI10 timestamp yyyy-mm.... -> stckE value char(16)
BLSUETID is described in z/OS MVS IPCS Customization -------*/
timeTAI102stckE: procedure expose m.
/* timestamp must include microSeconds |||*/
parse arg year'-'mo'-'da'-'hh'.'mm'.'secs
tDate = mo'/'da'/'year hh':'mm'.'secs
ACC=left('', 16, '00'x)
ADDRESS LINKPGM "BLSUETID TDATE ACC"
RETURN acc
endProcedure timeTAI102stckE
timeTAI102lrsn: procedure expose m.
parse arg tst
return c2x(left(timeTAI102StckE(tst), 10))
timeLZT2stckE: procedure expose m.
parse arg tst
numeric digits 23
s =timeTAI102StckE(tst)
return d2c(c2d(left(s, 8)) - m.time_lzt_TAI10_us16,8) || substr(s,9)
endProcedure timeLZT2stckE
timeLZT2lrsn: procedure expose m.
parse arg tst
return c2x(left(timeLZT2StckE(tst), 10))
/*--- expand lrsn to 20 hexDigits -------------------------------*/
timeLrsnExp: procedure expose m.
parse arg s
return left(copies('00', length(s) <= 12 & \abbrev(s, 0))s, 20,0)
/*--- expand stcK(e) to 16 Byte ---------------------------------*/
timeStckExp: procedure expose m.
parse arg s
return left(copies('00'x, length(s) <= 8 & s >> '09'x)s, 16,'00'x)
/*--- conversion from StckE Clock Value to TAI10 Timestamp
BLSUETOD is described in z/OS MVS IPCS Customization --------*/
timeStckE2TAI10: PROCEDURE expose m.
parse arg stck /* must be 16 characters ||||| */
TDATE = left('' , 26)
ADDRESS LINKPGM "BLSUETOD stck TDATE"
/* return format : mo/dd/yyyy hh:mm:ss.uuuuuu */
/* Timestamp format: yyyy-mm-dd-hh.mm.ss.uuuuuu */
parse var TDATE mo '/' dd '/' yyyy hh ':' mm ':' secs
RETURN yyyy'-'mo'-'dd'-'hh'.'mm'.'secs
endProcedure timeStckE2TAI10
/*--- conversion from Lrsn Clock Value to TAI10 Timestamp ----------*/
timeLrsn2TAI10:
return timeStckE2TAI10(x2c(arg(1))'000000000000'x)
/*--- conversion from Lrsn Clock Value to LZT Local Zurich Time -----*/
timeStckE2LZT: procedure expose m.
parse arg s
numeric digits 23
return timeStckE2TAI10(d2c(c2d(left(s, 8)) ,
+ m.time_LZT_TAI10_us16, 8) || substr(s, 9))
endProcedure timeStckE2LZT
/*--- conversion from Lrsn Clock Value to LZT Local Zurich Time -----*/
timeLrsn2LZT: procedure expose m.
parse arg lrsn
return timeStckE2LZT(x2c(lrsn) || '000000000000'x)
/* convert a lrsn to the uniq variable ********************************/
timeLrsn2uniq: procedure expose m.
parse arg lrsn
/* unique are bits 0:41 of the TodClock value
minus 31.12.2004 represented
by base 35 by 'ABC...YZ01..8'
*/
lrsn = left(timeLrsnExp(lrsn), 14)
numeric digits 20
diff = x2d(lrsn) - m.time_UQZero
if diff < 0 then
return'< 2005'
return right(i2q(diff % 64, m.time_UQDigits), 8, 'A')
endProcedure timeLrsn2Uniq
/* convert a uniq variable to lrsn ************************************/
timeUniq2lrsn: procedure expose m.
parse arg uniq
numeric digits 15
u1 = q2i(left(uniq, 8, 'A'), m.time_UQDigits) * 64
lrsn = '00'right(d2x(u1 + m.time_UQZero), 12, 0)'000000'
return lrsn
endProcedure uniq2lrsn
/*--- translate a number in q-system to decimal
arg digits givs the digits corresponding to 012.. in the q sysem
q = length(digits) --------------------------------------------*/
q2i: procedure expose m.
parse arg v, digits
b = length(digits)
i = 0
do x = 1 to length(v)
q = substr(v, x, 1)
r = pos(q, digits)
if r < 1 then
call err 'bad digit' q 'in' v 'valid digits' digits
i = i * b + r - 1
end
return i
endProcedure q2i
/*--- translate a decimal number to q-system - inverse of q2i --------*/
i2q: procedure expose m.
parse arg i, digits
if i = 0 then
return left(digits, 1)
b = length(digits)
v = ''
do while i > 0
v = substr(digits, 1 + (i // b), 1) || v
i = i % b
end
return v
endProcedure i2q
/* copy time end -----------------------------------------------------*/
/* copy SQL begin ***************************************************
Achtung: inc generiert sql aus sqlRx, Aenderungen nur in sqlRx|
sql interface
***********************************************************************/
/*--- initialize sql -----------------------------------------------*/
sqlIni: procedure expose m.
if m.sql_ini == 1 then
return
m.sql_ini = 1
call utIni
m.sqlNull = '---'
m.sqlInd = 'sqlInd'
m.sql_defCurs= 49
m.sqlCAMsg = 0
m.sqlSuMsg = 2
m.sql_dbSys = ''
m.sql_csmhost = ''
isInProd = wordPos(sysvar(sysNode), 'RZ2') > 0
m.sql_retOk = 'dne' copies('rod', \ isInProd)
return 0
endProcedure sqlIni
/*--- get default db2System ------------------------------------------*/
sqlDefaultSys: procedure expose m.
parse arg
if sysvar(sysnode) == 'RZ1' then
return 'DBAF'
else if sysvar(sysnode) == 'RZ4' then
return 'DP4G'
else
call err 'no default subsys for' sysvar(sysnode)
endProcedure sqlDefaultSys
/*--- connect to the db2 subsystem sys -----------------------------*/
sqlConnect: procedure expose m.
parse upper arg sys, ggRetOk
call sqlIni
address tso "SUBCOM DSNREXX"
if rc <> 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
if sys = '-' then
return 0
if sys == '' then
sys = sqlDefaultSys()
m.sql_dbSys = sys
ggSqlStmt = 'connect' sys
address dsnRexx ggSqlStmt
if rc = 0 then
return 0
interpret sqlErrorHandler(rc, ggRetOk, ggSqlStmt)
return sqlCode
endProcedure sqlConnect
/*--- diconnect from db2 ---------------------------------------------*/
sqlDisconnect: procedure expose m.
parse arg retOk
if m.sql_dbSys == '' then
return 0
ggSqlStmt = 'disconnect'
m.sql_dbSys = ''
m.sql_csmHost = ''
address dsnRexx ggSqlStmt
if rc = 0 then
return 0
interpret sqlErrorHandler(rc, retOk, ggSqlStmt)
return sqlCode
endProcedure sqlDisconnect
/*--- reset sql cursor 'c'cx fields ----------------------------------*/
sqlReset: procedure expose m.
parse arg cx
m.sql.cx.updateCount = ''
m.sql.cx.resultSet = ''
m.sql.cx.d.sqlD = 'noSqlDA'
m.sql.cx.i.sqlD = 'noDescInp'
m.sql.cx.fetchVars = ''
m.sql.cx.fetchFlds = ''
m.sql.cx.fetchClass = ''
m.sql.cx.type = ''
return
endProcedue sqlReset
/*--- execute a query from sql, with one resultset -------------------*/
sqlQuery: procedure expose m.
parse arg cx, src, feVa, retOk
call sqlReset cx
s1 = ''
if pos(left(feVa, 1), '?:') < 1 then
s1 = 'into :M.SQL.'cx'.D'
res = sqlExec('prepare s'cx s1 'from :src', retOk)
if res < 0 then
return res
call sqlFetchVars cx, feVa
call sqlExec 'declare c'cx 'cursor for s'cx
res = sqlExec('open c'cx, retOk)
if res < 0 then
return res
m.sql.cx.updateCount = sqlErrd.3
m.sql.cx.resultSet = cx
return res
endProcedure sqlQuery
/*--- prepare a query from sql, with one resultset -------------------*/
sqlQueryPrepare: procedure expose m.
parse arg cx, src, feVa, retOk
call sqlReset cx
s1 = ''
if feVa == '' | feVa = 'd' then
s1 = 'into :M.SQL.'cx'.D'
res = sqlExec('prepare s'cx s1 'from :src', retOk)
if res < 0 then
return res
call sqlFetchVars cx, feVa
call sqlExec 'declare c'cx 'cursor for s'cx
return sqlExec('describe input s'cx 'into :M.SQL.'cx'.I')
endProcedure sqlQueryPrepare
sqlQueryExecute: procedure expose m.
parse arg cx retOk
do ix=1 to arg()-1
call sqlDASet cx , 'I', ix, arg(ix+1)
end
res = sqlExec('open c'cx 'using descriptor :M.SQL.'cx'.I', retOk)
if res < 0 then
return res
m.sql.cx.updateCount = sqlErrd.3
m.sql.cx.resultSet = cx
return res
endProcedure sqlQueryExecute
/*--- fetch next row to m.dst.* at end return false ------------------*/
sqlFetch: procedure expose m.
parse arg cx, dst, retOk
fetCode = sqlExec('fetch c'cx 'into' m.sql.cx.fetchVars, 100 retOk)
if fetCode == 100 then
return 0
if fetCode < 0 then
return fetCode
interpret m.sql.cx.fetchCode
return 1
endProcedure sqlFetch
/*--- close cursor 'c'cx ---------------------------------------------*/
sqlClose: procedure expose m.
parse arg cx, retOk
return sqlExec('close c'cx, retOk)
endProcedure sqlClose
/*-- execute an sql with no resultset, but possibly outParms ---------*/
sqlUpdate: procedure expose m.
parse arg cx, src, retOk
m.sql.cx.updateCount = ''
m.sql.cx.resultSet = ''
bx = verify(src, '( ')
if bx > 0 then
fun = translate(word(substr(src, bx), 1))
if fun = 'SET' then do
w2 = translate(word(substr(src, bx), 2))
if \ abbrev(w2, ':') then
return sqlExec('execute immediate :src', retOk)
trace ?r
ex = pos('=', w2)
if ex = 0 then
ex = length(w2)+1
var = strip(substr(w2, 2, ex-2))
if var = '' then
call err 'bad hostVar in' src
m.sql.outVar = var
src2 = 'set :M.sql.out.'var substr(w, ex) subword(src, 3)
return sqlExec(src2, retOk)
end
if fun == 'DECLARE' then do
if 'GLOBAL' == translate(word(substr(src, bx), 2)) then
return sqlExec('execute immediate :src', retOk)
end
res = sqlExec(src, retOk)
if wordPos(fun, 'DELETE INSERT UPDATE') > 0 then
m.sql.cx.updateCount = sqlErrd.3
return res
endProcedure sqlUpdate
/*-- prepare an update -----------------------------------------------*/
sqlUpdatePrepare: procedure expose m.
parse arg cx, src, retOk
res = sqlExec('prepare s'cx 'from :src', retOk)
return sqlExec('describe input s'cx 'into :M.SQL.'cx'.I')
endProcedure sqlUpdatePrepare
/*-- execute a prepared update with the given arguments --------------*/
sqlUpdateExecute: procedure expose m.
parse arg cx retOk
do ix=1 to arg()-1
call sqlDASet cx , 'I', ix, arg(ix+1)
end
res = sqlExec('execute s'cx 'using descriptor :M.SQL.'cx'.I',
, retOk)
m.sql.cx.updateCount = sqlErrd.3
return res
endProcedure sqlUpdateExecute
/*-- execute a query, update or call ---------------------------------*/
sqlExecute: procedure expose m.
parse arg cx, src, retOk
f = translate(word(src, 1))
bx = pos('(', f)
if bx > 0 then
f = left(f, max(1, bx-1))
m.sql.cx.fun = f
if f == 'SELECT' | f == 'WITH' | f == '(' then
return sqlQuery(cx, src, , retOk)
else if f == 'CALL' then
call err 'implement sql call for:' src
else
return sqlUpdate(cx, src, retOk)
endProcedure sqlExecute
/*-- fetch all rows to stem and close --------------------------------*/
sqlFetch2St: procedure expose m.
parse arg cx, dst, retOK
do sx=1 while sqlFetch(cx, dst'.'sx)
end
res = sx-1
m.dst.0 = sx-1
call sqlClose cx
return m.dst.0
endProcedure sqlFetch2St
/*-- execute a query, copy result to stem ----------------------------*/
sql2St: procedure expose m.
parse arg src, dst, feVa, retOK
cx = m.sql_defCurs
res = sqlQuery(cx, src, feVa, retOk)
return sqlFetch2St(cx, dst, retOk)
endProcedure sql2St
/*-- return first column of the only row and close -------------------*/
sqlFetch2One: procedure expose m.
parse arg cx, dst, retNone
f1 = sqlFetch(cx, dst)
if f1 then
f2 = sqlFetch(cx, dst'.2')
call sqlClose cx
if \ f1 then
if retNone \== '' then
return substr(retNone, 2)
else
call err 'sqlFetch2One: no row returned'
else if f2 then
call err 'sqlFetch2One: more than 1 row'
if m.sql.cx.fetchFlds == '' then do
c1 = substr(word(m.sql.cx.fetchVars, 1), 2)
res = value(c1)
return res
end
c1 = word(m.sql.cx.fetchFlds, 1)
return m.dst.c1
endProcedure sqlFetch2One
/*-- execute a query and return first column of the only row
if > 1 row fail, if 0 rows return arg(3) or fail ----------*/
sql2One: procedure expose m.
parse arg src, dst, feVa, retOk, retNone
cx = m.sql_defCurs
call sqlQuery cx, src, feVa, retOk
return sqlFetch2One(cx, dst, retNone)
endProcedure sql2One
/*--- describe table and return sqlDA --------------------------------*/
sqlDescribeTable: procedure expose m.
parse upper arg tb, force
if force == 1 | \ datatype(m.sql.table.tb.sqlD, 'n') then
call sqlExec 'describe table :tb into :M.SQL.TABLE.'tb
return 'SQL.TABLE.'tb
endProcedure sqlDescribeTable
/*--- return select column list for table tb
omit Blobs (blobMax < 0) or substr(blob, 1, blobMax) ----------*/
sqlColList: procedure expose m.
parse arg tb al, blobMax
sd = sqlDescribeTable(tb)
bs = ''
lst = ''
if al \== '' & right(al, 1) \== '.' then
al = al'.'
do sx=1 to m.sd.sqld
if wordPos(m.sd.sx.sqlType, '404 405 408 409 412 413') < 1 then
lst = lst',' al || m.sd.sx.sqlName
else do
bs = bs m.sd.sx.sqlName
if blobMax >= 0 then
lst = lst', length('al || m.sd.sx.sqlName')' ,
m.sd.sx.sqlName'Len' ,
|| ', substr('al || m.sd.sx.sqlName ,
|| ', 1,' blobMax')' m.sd.sx.sqlName
end
end
m.sd.colList = substr(lst, 3)
m.sd.blobs = strip(bs)
return substr(lst, 3)
endProcedure sqlColList
/*--- use describe output to generate column names,
'' use names from ca (rexxified)
nms+ use names, check ca for null values
?('?'?nm)+ use names, check for null if preceeded by ?
:... use string as is
fetchVariables and sqlNull names ---------------------*/
sqlFetchVars: procedure expose m.
parse arg cx, src, cd
st = 'SQL.'cx'.COL'
if abbrev(src, ':') then do
m.sql.cx.fetchVars = src
m.sql.cx.fetchCode = cd
m.sql.cx.fetchFlds = ''
return
end
m.sql.cx.fetchVars = ''
if abbrev(src, '?') then do
call err implement + rxFetchVars ?
r = substr(src, 2)
do wx=1 to words(src)
cn = word(src, wx)
if abbrev(cn, '?') then
call sqlRexxAddVar substr(cn, 2), 0, 1
else
call sqlRexxAddVar cn, 0, 0
end ????????????? */
end
else if src <> '' then do
ff = src
end
else do
ff = ''
do kx=1 to m.sql.cx.d.sqlD
ff = sqlNiceVarsAdd(ff, m.sql.cx.d.kx.sqlName)
end
end
m.sql.cx.fetchFlds = ff
if m.sql.cx.d.sqlD <> words(ff) then
call err 'sqlFetchVars sqlD='m.sql.cx.d.sqlD ,
'<>' words(ff) 'fields of' ff
sNu = ''
sFe = ''
do kx=1 to m.sql.cx.d.sqlD
nm = word(ff, kx)
sFe = sFe', :m.dst.'nm
if m.sql.cx.d.kx.sqlType // 2 then do
sFe = sFe' :m.dst.'nm'.sqlInd'
sNu = sNu 'if m.dst.'nm'.sqlInd < 0 then' ,
'm.dst.'nm '= m.sqlNull;'
end
end
m.sql.cx.fetchVars = substr(sFe, 3)
m.sql.cx.fetchCode = sNu cd
return
endProcedure sqlFetchVars
/* ????????????
sqlRexxAddVar:
parse arg nm, nicify, hasNulls
nm = sqlAddVar(st, nm, nicify)
if \ hasNulls then
vrs = vrs', :m.dst.'nm
else do
vrs = vrs', :m.dst.'nm ':m.dst.'nm'.sqlInd'
sNu = sNu 'if m.dst.'nm'.sqlInd < 0 then' ,
'm.dst.'nm '= m.sqlNull;'
end
return
endSubroutine sqlRexxAddVar ?????? */
sqlNiceVarsAdd: procedure expose m.
parse arg old, nx rest
upper nx
cx = verifId(nx)
if cx > 0 then /* avoid bad characters for classNew| */
nx = left(nx, cx-1)
if nx <> '' & wordPos(nx, old) < 1 0 then
return old nx
else
return old 'COL' || (words(old) + 1)
endProcedure sqlNiceVarsAdd
/*--- set one value in a DA, handle nulls ----------------------------*/
sqlDASet: procedure expose m.
parse arg cx, da, ix, val
m.sql.cx.da.ix.sqlData = val
m.sql.cx.da.ix.sqlInd = - (val == m.sqlNull)
/* data types schienen einmal nicht zu funktionieren .......
if wordPos(m.da.ix.sqlType, '384 385 388 389 392 393') > 0 then
m.da.ix.sqlType = 448 + (m.da.ix.sqlType // 2) */
return
endProcedure sqlDASet
sqlCommit: procedure expose m.
parse arg src
return sqlUpdate(, 'commit')
endProcedure sqlCommit
/*--- execute sql thru the dsnRexx interface -------------------------*/
sqlExec: /* no procedure, to keep variables sql... */
parse arg ggSqlStmt, ggRetOk
m.sql_HaHi = ''
address dsnRexx 'execSql' ggSqlStmt
/* say 'sqlCode' sqlCode 'rc' rc 'for' ggSqlStmt ggNo */
if rc = 0 then
return 0
interpret sqlErrorHandler(rc, ggRetOk, ggSqlStmt)
return sqlCode
endProcedure sqlExec
sqlExecMsg: procedure expose m.
parse arg sql
sc = sqlExec(sql, '*')
return sqlMsgLine(sc, , sql)
sqlErrorHandler: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
parse arg drC, retOk, verb rest
if drC == 0 then
return 'return 0'
if pos('-', retOK) < 1 then
retOK = retOk m.sql_retOk
if wordPos(drC, '1 -1') < 1 then do
eMsg = "'dsnRexx rc="drC"' sqlmsg()"
end
else if pos('*', retOK) > 0 | wordPos(sqlCode, retOK) > 0 then do
if sqlCode < 0 & pos('say', retOK) > 0 then
return "call outNl errMsg(' }'sqlMsg())"
else
return ''
end
else do
upper verb
if verb == 'DROP' then do
if (sqlCode == -204 | sqlCode == -458) ,
& wordPos('dne', retok) > 0 then
return 'return' sqlCode
if sqlCode = -672 & wordPos('rod', retok) > 0 then do
hahi = m.sql_HaHi || sqlMsgLine(sqlCode,
, 'tb='sqlErrMc ,verb rest)'\n'
haHi = haHi || sqlExecMsg('alter table' SqlErrMc ,
'drop restrict on drop')
call sqlExec verb rest
m.sql_HaHi = hahi
return ''
end
end
if drC < 0 then
eMsg = "sqlmsg()"
else if (sqlCode<>0 | sqlWarn.0 ^==' ') & pos('w',retOK)<1 then
return "call outNl errMsg(' }'sqlMsg()); return" sqlCode
else
return ''
end
if wordPos('rb', retok) > 0 then
eMsg = eMsg " || '\n"sqlExecMsg('rollback')"'"
if wordPos('ret', retok) < 1 then
return "call err" eMsg
m.sql_errRet = 1
return 'call outNl' eMsg
endProcedure sqlErrorHandler
sqlMsgLine: procedure expose m. sqlErrD.
parse arg res, cnt, src, plus
verb = translate(word(src, 1))
if datatype(res, 'n') then
res = 'sqlCode' res
if cnt \== '' then do
res = res',' cnt
vx = wordPos(translate(word(src,1)), 'DELETE INSERT UPDATE')
if datatype(cnt, 'n') then
if vx > 0 then
res = res 'rows' word('deleted inserted updated', vx)
else if cnt <> 0 then
res = res 'rows updated'
end
if plus \== '' then
res = res',' plus
if abbrev(res, ', ') then
res = substr(res, 3)
if src \== '' then do
ll = 75 - length(res)
aa = strip(src)
if length(aa) > ll then
aa = space(aa, 1)
if length(aa) > ll then
aa = left(aa, ll-3)'...'
res = res':' aa
end
return res
endProcedure sqlMsgLine
/*--- send a command to db2 through the TSO dsn processor ------------*/
sqlDsn: procedure expose m.
parse arg st, sys, cmd, rcOk
x = outtrap('M.'st'.')
push 'END'
push cmd
address tso 'DSN SYSTEM('sys')'
rr = rc
x = outtrap(off)
if rr = 0 | rcOk = '*' | wordPos(rr, rcOk) > 0 then
return rr
fl = max(1, m.st.0 - 10)
em = 'rc' rr 'for DSN SYSTEM('sys') cmd' cmd,
'\nOuputlines' fl '-' m.st.0':'
do lx=fl to m.st.0
em = em '\n' strip(m.st.lx, 't')
end
call err em
endProcedure sqlDsn
/*--- issue an sql error message -------------------------------------*/
sqlMsg: /* no procedure, to keep variables sql... */
if \ dataType(sqlCode, 'n') then do
ggRes = 'sqlCode' sqlCode 'not numeric\n'sqlCaMsg()
end
else do
ggRes = sqlDsntiar(sql2CA())
ggWa = sqlMsgWarn()
if ggWa \= '' then
ggRes = ggRes'\nwarnings' ggWa
if m.sqlCAMsg == 1 then
ggRes = ggRes'\n'sqlCaMsg()'\n'sqlCaMsg(sqlCa2Rx(sqlCa))
end
ggSt = 'SQL_HOST'
ggVa = 'SQL_HOST.VAR'
ggBe = 'SQL_HOST.BEF'
call sqlHostVars ggSqlStmt, 12, ggSt
ggFrom = 'ggSqlStmt'
ggW1 = translate(word(ggSqlStmt, 1))
ggW2 = translate(word(ggSqlStmt, 2))
if ggW1 == 'PREPARE' then
ggFrom = sqlHostVarFind(ggSt, 'FROM')
else if ggW1 ggW2 == 'EXECUTE IMMEDIATE' then
ggFrom = sqlHostVarFind(ggSt, 1)
ggPos = 0
if datatype(sqlErrd.5, 'n') & sqlErrd.5 > 0 then do
ggPos = sqlErrd.5
ggRes = ggRes || sqlMsgSrcPos(value(ggFrom), sqlErrd.5)
end
if ggFrom == 'ggSqlStmt' then do
ggRes = ggRes'\nsql =' sqlShorten(ggSqlStmt, 2000, ggPos)
end
else do
ggRes = ggRes'\nsql =' sqlShorten(value(ggFrom), 2000, ggPos)
ggRes = ggRes'\nstmt =' sqlShorten(ggSqlStmt, 2000)
end
ggPref = '\nwith'
do ggXX=1 to m.ggSt.0
if ggFrom = m.ggVa.ggXX then
iterate
ggRes = ggRes || ggPref m.ggBe.ggXX ':'m.ggVa.ggXX ,
'=' sqlShorten(value(m.ggVa.ggXX), 210)
ggPref = '\n '
end
if m.sqlSuMsg == 1 | (m.sqlSuMsg == 2 & m.sql_csmhost \== '') then
ggRes = ggRes'\nsubsys =' m.sql_dbSys ,
|| ', host =' m.sql_csmhost
return ggRes
endSubroutine sqlMsg
sqlShorten: procedure expose m.
parse arg txt, maxL, pos
if length(txt) <= maxL then
return txt
if \ datatype(pos, 'n') | pos < 1 then
pos = 1
ex = pos + min(60, maxL%7)
if ex <= maxL - 4 then
return left(txt, maxL-4) '...'
if ex >= length(txt) then
return left(txt, 67) '...\n'substr(txt, length(txt)-maxL+72)
else
return left(txt, 67) '...\n'substr(txt, ex-maxL+76, maxL-75) ,
'...'
endProcedure sqlShorten
/*--- use dsnTiar to translate sql Info to error text ----------------*/
sqlDsnTiar: procedure expose m.
parse arg ca
if -438 = sqlCa2Rx(ca) then
return '\nSQLCODE = -438:',
'APPLICATION RAISED ERROR WITH sqlState' sqlState ,
'and DIAGNOSTIC TEXT:' sqlErrMc
liLe = 78
msLe = liLe * 10
msg = d2c(msLe,2) || left('', msLe)
len = d2c(liLe, 4)
ADDRESS LINKPGM "DSNTIAR ca msg len"
if rc = 0 then nop
else if rc = 4 then say 'warn linkPgm dsnTiar rc' rc 'sqlCa' ca
else call err 'linkPgm dsnTiar rc' rc 'sqlCa' ca
res = strip(substr(msg, 13, liLe-10))
cx = pos(', ERROR: ', res)
if cx > 0 then
res = left(res, cx-1)':' strip(substr(res, cx+9))
do c=3+liLe by liLe to msLe while substr(msg, c, 10) = ''
res = res'\n 'strip(substr(msg, c+10, liLe-10))
end
return res
endProcedure sqlDsnTiar
/*--- format all rexx sqlCa fields into a message --------------------*/
sqlCaMsg:
return 'sqlCode' sqlCode 'sqlState='sqlState ,
'\n errMC='translate(sqlErrMc, ',', 'ff'x) ,
'\n warnings='sqlWarnCat('+') 'erP='sqlErrP ,
'\n errD.1='sqlErrD.1 '2='sqlErrD.2 '3='sqlErrD.3 ,
'\n errD.4='sqlErrD.4 '5='sqlErrD.5 '6='sqlErrD.6
endProcedure sqlCaMsg
/*--- format the sqlCA into the dsnTiar SQLCA ------------------------*/
sql2Ca: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
if \ (datatype(sqlcode, 'n') & datatype(sqlErrD.1, 'n') ,
& datatype(sqlErrD.3, 'n')) then
return err('sqlCode etc. not numeric\nsqlCa =' sqlCaMsg())
if digits() < 10 then
numeric digits 10
sqlCa = 'SQLCA ' || d2c(136, 4) || d2c(sqlCode, 4) ,
|| d2c(min(70, length(sqlErrMc)), 2)left(sqlErrMc, 70) ,
|| left(sqlErrP, 8) ,
|| d2c(sqlErrD.1, 4)d2c(sqlErrD.2, 4)d2c(sqlErrD.3, 4) ,
|| d2c(sqlErrD.4, 4)d2c(sqlErrD.5, 4)d2c(sqlErrD.6, 4) ,
|| sqlWarnCat() || sqlState
if length(sqlCa) <> 136 then
call err 'sqlCa length' length(sqlCa) 'not 136' ,
'\n'sqlCaMsg() '==>' ca', hex='c2x(ca)
return sqlCa
endProcedure sql2Ca
/*--- extract the fields from the SqlCA and put it to rexx vars ------*/
sqlCA2Rx: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
parse arg ca
numeric digits 10
if length(ca) < 136 | c2d(substr(ca, 9, 4), 4) <> 136 then
call err 'bad sqlCa len' length(ca) 'not 136:' ca', hex='c2x(ca)
sqlCode = c2d(substr(ca, 13 ,4), 4)
sqlErrMC = substr(ca, 19, c2d(substr(ca, 17, 2), 2))
sqlErrP = substr(ca, 89, 8)
do ix=1 to 6
sqlErrD.ix = c2d(substr(ca, 93 + 4 * ix, 4), 4)
end
do ix=0 to 10
sqlWarn.ix = substr(ca, 121 + ix, 1)
end
sqlState = substr(ca, 132, 5)
return sqlCode
endProcedure sqlCA2Rx
/*--- concat the sql warnings with Separator sep --------------------*/
sqlWarnCat: procedure expose m. sqlWarn.
parse arg sep
return sqlWarn.0 || sep,
|| sqlWarn.1||sqlWarn.2||sqlWarn.3||sqlWarn.4||sqlWarn.5||sep ,
|| sqlWarn.6||sqlWarn.7||sqlWarn.8||sqlWarn.9||sqlWarn.10||sep
endProcedure sqlWarnCat
/*--- make the text for sqlWarnings ----------------------------------*/
sqlMsgWarn: procedure expose m. sqlWarn.
r = ''
text =' 1=W var truncated, 1=S scrollable, 1=N nonScrollable,' ,
'2=W nulls in aggregate,' ,
'3=W more cols than vars,' ,
'3=Z more result sets than locators,' ,
'4=W no where, 4=D sensitive dynamic, 4=I insensitive,' ,
'4=S sensitive static,' ,
'5=W not valid sql, 5=1 readOnly, 5=2 readDelete,' ,
'5=3 readDeleteUpdate,' ,
'6=W day changed to month range,' ,
'7=W dec digits truncated,' ,
'8=W char substituted,' ,
'9=W arith excep in count, 9=Z multipe result sets,' ,
'10=W char conversion err in ca,'
do wx = 1 to 10
w = sqlWarn.wx
if w = ' ' then
iterate
t = wx'='w
cx = pos(' 'wx'='w' ', text)
ex = pos(',' , text, cx + 1)
if cx > 0 & ex > cx then
r = r substr(text, cx+1, ex-cx)
else
r = r wx'='w '?,'
end
r = strip(r, 't', ',')
if r = '' & sqlwarn.0 <> '' then
call err 'sqlWarn.0='sqlWarn.0 'but all warns empty'
return r
endProcedure sqlMsgWarn
/*--- show in the source src the point pos (where error occured)
a few lines from src around pos and arrow to pos ----------*/
sqlMsgSrcPos: procedure expose m.
parse arg src, pos
liLe = 68
liCn = 3
afLe = 25
t1 = space(left(src, pos), 1)
t2 = left(' ', substr(src, pos, 1) == ' ' ,
| substr(src, pos+1, 1) == ' ') ,
|| space(substr(src, pos+1), 1)
afLe = min(afLe, length(t2))
if length(t1) + afLe > liLe * liCn then
t1 = '...'right(t1, liLe * liCn - afLe -3)
else if length(t1)+length(t2) > liLe then
t1 = left(' ', (liCn * liLe - length(t1) -afLe) // liLe)||t1
pL = length(t1) // liLe
if length(t2) <= liLe-pL then
tx = t1 || t2
else
tx = t1 || left(t2, liLe-pL-3)'...'
res = '\nsrc' strip(substr(tx, 1, liLe), 't')
do cx=1+liLe by liLe to length(tx)
res = res || '\n +' strip(substr(tx, cx, liLe), 't')
end
loc = 'pos' pos 'of' length(src)
if length(loc)+6 < pL then
return res'\n >' right('>>>'loc'>>>', pL)
else
return res'\n >' left('', pL-1)'<<<'loc'<<<'
endProcdedure sqlMsgSrcPos
/*--- get the hostVars in the sql in src and the word before ---------*/
sqlHostVars: procedure expose m.
parse arg src, cnt, st
cx = 1
sx = 1
do cnt
cx = pos(':', src, cx) + 1
if cx < 2 then
leave
if pos(substr(src, cx, 1), m.ut_rxN1) > 0 then
iterate
ex = verify(src, m.ut_rxDot, 'n', cx)
if ex < 1 then
m.st.var.sx = substr(src, cx)
else
m.st.var.sx = substr(src, cx, ex - cx)
if m.st.var.sx == '' | length(m.st.var.sx) > 100 then
iterate
/* search word before */
do bE = cx-2 by -1 to 1 ,
while substr(src, bE, 1) == ' '
end
do bB = bE by -1 to max(1, bE-20),
while pos(substr(src, bB, 1), m.ut_alfa) > 0
end
if bB < bE & bB >= 0 then
m.st.bef.sx = substr(src, bB+1, bE-bB)
else
m.st.bef.sx = ''
sx = sx + 1
end
m.st.0 = sx-1
return sx
endProcedure sqlHostVars
/*--- find the name of hostvar, by index or by before ----------------*/
sqlHostVarFind: procedure expose m.
parse arg st, fnd
if datatype(fnd, 'n') & fnd <= m.st.0 then
return m.st.var.fnd
do ix=1 to m.st.0
if translate(m.st.bef.ix) = fnd then
return m.st.var.ix
end
return ''
endSubroutine sqlHostVarFind
/* copy SQL end **************************************************/
/* copy err begin *** errorhandling, messages, help ****************/
errIni: procedure expose m.
if m.err.ini == 1 then
return
m.err.ini = 1
m.err.handler = ''
m.err.cleanup = ';'
m.err.opt = ''
parse source m.err.os .
m.err.ispf = 0
m.err.screen = 0
if m.err.os \== 'LINUX' then do
address tso 'profile MsgId' /* brauchen wir in tsoAlloc| */
if sysVar('sysISPF') = 'ACTIVE' then do
m.err.ispf = 1
address ispExec 'vget zScreen shared'
m.err.screen = zScreen
end
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 stackHistory
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
x = show + stackHistory + by + bad + arithmetic + conversion
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_ddAll') == 'VAR' then
call tsoFree m.tso_ddAll, 1
return
endProcedure errCleanup
/*--- say an errorMessage msg with pref and linesplits --------------*/
errSay: procedure expose m.
parse arg msg
return sayNl(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 res
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
outNL: procedure expose m.
parse arg msg
bx = 1
do lx=1 to 20
ex = pos('\n', msg, bx)
if ex < bx then
leave
call out substr(msg, bx, ex-bx)
bx = ex+2
end
call out substr(msg, bx)
return
endProcedure outNL
/*--- say (part of) the lines of a stem ----------------------------*/
sayNl: procedure expose m.
parse arg msg
bx = 1
do lx=1 to 20
ex = pos('\n', msg, bx)
if ex < bx then
leave
say strip(substr(msg, bx, ex-bx), 't')
bx = ex+2
end
say strip(substr(msg, bx), 't')
return 0
endProcedure sayNl
/*--- 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'
/* 012345678901234567890123456789 */
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')
/*--- 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(strip(s, 't')) >= len then
return strip(s, 't')
return left(s, len)
endProcedure lefPad
/*--- right without truncation ---------------------------------------*/
rigPad: procedure expose m
parse arg s, len
if length(strip(s, 'l')) >= len then
return strip(s, 'l')
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
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
utInter: procedure expose m.
interpret arg(1)
return
endProcedure utInter
/* copy ut end ********************************************************/ 6
/* copy out begin ******************************************************
out interface simple with say only
***********************************************************************/
/*--- output a message to the current destination -------------------*/
out: procedure expose m.
parse arg msg
say msg
return
endProcedure out
/* copy out end *****************************************************/
}¢--- A540769.WK.REXX(TESTWHO) cre=2015-07-14 mod=2015-07-14-08.13.53 A540769 ---
/* rexx */
say 'testWho: A540769.WK.REXX(TESTWHO)'
exit
}¢--- A540769.WK.REXX(TIME) cre=2016-10-26 mod=2016-10-26-09.51.11 A540769 -----
/* copy time begin ****************************************************
timestamp format yz34-56-78-hi.mn.st.abcdef
11.12.14 wk: added lrsn2uniq
11.05.13 wk: numeric digits transparent: in jeder Procedure drin
time2jul, tst externalisiert
**********************************************************************/
/*--- timestamp to julian -------------------------------------------*/
time2jul: procedure expose m.
parse arg yyyy '-' mm '-' dd '-'
if yyyy < 1100 then
yyyy = 11 || right(yyyy, 2, 0)
/* date function cannot convert to julian, only from julian
use b (days since start of time epoch) instead */
return right(yyyy, 2) ,
|| right(date('b', yyyy || mm || dd, 's') ,
- date('b', yyyy-1 || '1231', 's') , 3, 0)
endProcedure time2jul
/*--- current timestamp ---------------------------------------------*/
timestampNow: procedure expose m.
parse value date('s') time('l') with y 5 m 7 d t
return y'-'m'-'d'-'translate(t, '.', ':')
/*--- timestamp expand: expand to timestamp of 26 chars -------------*/
timestampExp: procedure expose m.
parse arg tst .
if length(tst) < m.timeStamp_Len then
return overlay(tst, m.timeStamp_01)
else
return left(tst, timeStamp_Len)
endProcedure tiemstampExp
/*--- timestamp check return '' if correct or error text ------------*/
timestampcheck: procedure expose m.
parse arg tst
if length(tst) < m.timestamp_d0Len | \ abbrev(m.timestamp_11,
, translate(tst, '111111111', '023456789')) then
return 'bad timestamp' tst
parse arg yyyy '-' mo '-' dd '-' hh '.' mm '.' ss '.' u
if mo < 1 | mo > 12 then
return 'bad month in timestamp' tst
if dd < 1 | dd > 3 || substr('101010110101', mo, 1) then
return 'bad day in timestamp' tst
if mo = 2 then
if dd > date('d', yyyy'0301', 's') - 32 then
return 'bad day in timestamp' tst
if hh > 23 & \ abbrev(24 00 00 000000, hh mm ss u) then
return 'bad hour in timestamp' tst
if mm > 59 then
return 'bad minute in timestamp' tst
if ss > 59 then
return 'bad second in timestamp' tst
return ''
endProcedure timestampCheck
/*--- timestamp to days since 1.1.0001 ------------------------------*/
timestamp2days: procedure expose m.
parse arg yyyy '-' mo '-' dd '-' hh '.' mm '.' ss
numeric digits 20
return date('b', yyyy || mo || dd, 's') ,
+ (((hh * 60) + mm) * 60 + ss) / 86400
/*--- days since 1.1.0001 (with time+microsecs) to timestamp --------*/
timeDays2tst: procedure expose m.
parse arg d
numeric digits 20
r = min(format(d // 1 * 86400, 5, 6), 86399.999999)
s = trunc(r)
t = date('s', trunc(d), 'b')
return left(t, 4)'-'substr(t, 5, 2)'-'right(t, 2) ,
|| '-' || right((s % 3600), 2, 0) ,
|| '.' || right((s // 3600 % 60), 2, 0) ,
|| '.' || right((s // 60), 2, 0) ,
|| substr(r, 6)
endProcedure timeDays2tst
/*--- timestamp diff in days ----------------------------------------*/
timestampDiff: procedure expose m.
parse arg t1, t2
numeric digits 20
return timestamp2days(t1) - timestamp2Days(t2)
/*--- convert 2 digit year to 4 digit -------------------------------*/
timeYear24: procedure expose m.
parse arg s
y = left(date('S'), 4)
s4 = left(y, 2)right(s, 2, 0)
if s4 > y + 30 then
return (left(y, 2) - 1)substr(s4, 3)
else if s4 > y - 70 then
return s4
else
return (left(y, 2) + 1)substr(s4, 3)
endProcedure timeYear24
/*--- convert 2 or 4 digit year Y (A=0...Y=24) ----------------------*/
timeYear2Y: procedure expose m.
parse arg y
return substr(m.ut_uc25, (y // 25) + 1, 1)
/*--- convert 1 char year Y (A=0...y=24) to year --------------------*/
timeY2Year: procedure expose m.
parse arg i
j = pos(i, m.ut_uc25) - 1
if j < 0 then
call err 'timeY2Year bad input' i
y = left(date('S'), 4)
r = y - y // 25 + j
if r > y + 4 then
return r - 25
else if r > y - 21 then
return r
else
return r + 25
endProcedure timeY2Year
/*--- convert 2 or 4 digit year Y (A=10...T=29) ----------------------*/
timeYear2Z: procedure expose m.
parse arg y
return substr('ABCDEFGHIJKLMNOPQRST', ((y+10) // 20) + 1, 1)
/*--- convert 1 char year Z (A=10...T=29) to year --------------------*/
timeZ2Year: procedure expose m.
parse arg i
j = pos(i, 'ABCDEFGHIJKLMNOPQRST') - 1
if j < 0 then
call err 'timeZ2Year bad input' i
y = left(date('S'), 4)
r = y - y // 20 + j
if r > y + 4 then
return r - 20
else if r > y - 16 then
return r
else
return r + 20
endProcedure timeZ2Year
/*--- convert numeric month to M (Jan=B=1, dec=12=M) ----------------*/
timeMonth2M: procedure expose m.
parse arg m
return substr('BCDEFGHIJKLM', m, 1)
/*--- convert M to numeric Month (Jan=B=1, dec=12=M) ----------------*/
timeM2Month: procedure expose m.
parse arg m
p = pos(m, 'BCDEFGHIJKLM')
if p= 0 then
call err 'bad M month' m
return right(p, 2, 0)
/*--- read timeZoneOffset and leapSeconds registers
and set variables for uniq ----------------------------------*/
timeIni: procedure expose m.
parse arg debug
if m.time_ini == 1 then
return
m.time_ini = 1
numeric digits 25
/* offsets documented in z/OS Data Areas Vol.1 */
cvtOH = '00000010' /* cvt control block Address */
cvtext2O = x2d('00000560') /* offset to extension 2 */
cvtldtoO = x2d('00000038') /* offset to timezone */
cvtlsoO = x2d('00000050') /* offset to leapSeconds */
/* CVT CB address + extention2 */
cvtExt2A = C2D(STORAGE(cvtOH,4)) + cvtext2O
/* cvtLdto timeZone address +offset */
m.time_Zone = c2d(STORAGE(d2x(cvtext2A+cvtldtoO, 8), 8))
m.time_StckUnit = 1e-6 / 256 / 16
/* cvtLso LeapSecs address +offset */
m.time_Leap = c2d(STORAGE(d2x(cvtext2A+cvtlsoO, 8), 8))
m.time_LZT_TAI10_us16 = (m.time_zone - m.time_leap) % 256
m.time_UQDigits = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ012345678'
/* find lrsn of day 0, 0 out last 6 bits */
m.time_UQZero = x2d(left(timeTAI102Lrsn( ,
'2004-12-31-00.00.22.000000'), 14)) % 64 * 64
m.timeStamp_01 = '0001-01-01-00.00.00.000000'
m.timeStamp_11 = '1111-11-11-11.11.11.111111'
m.timeStamp_99 = '9999-12-31-23.59.59.999999'
m.timeStamp_len = length(m.timestamp_11)
m.timeStamp_d0Llen = m.timestamp_len - 7
return
endSubroutine timeIni
/*--- TAI10 timestamp yyyy-mm.... -> stckE value char(16)
BLSUETID is described in z/OS MVS IPCS Customization -------*/
timeTAI102stckE: procedure expose m.
/* timestamp must include microSeconds |||*/
parse arg year'-'mo'-'da'-'hh'.'mm'.'secs
tDate = mo'/'da'/'year hh':'mm'.'secs
ACC=left('', 16, '00'x)
ADDRESS LINKPGM "BLSUETID TDATE ACC"
RETURN acc
endProcedure timeTAI102stckE
timeTAI102lrsn: procedure expose m.
parse arg tst
return c2x(left(timeTAI102StckE(tst), 10))
timeLZT2stckE: procedure expose m.
parse arg tst
numeric digits 23
s =timeTAI102StckE(tst)
return d2c(c2d(left(s, 8)) - m.time_lzt_TAI10_us16,8) ||substr(s,9)
endProcedure timeLZT2stckE
timeLZT2lrsn: procedure expose m.
parse arg tst
return c2x(left(timeLZT2StckE(tst), 10))
/*--- expand lrsn to 20 hexDigits -------------------------------*/
timeLrsnExp: procedure expose m.
parse arg s
return left(copies('00', length(s) <= 12 & \abbrev(s, 0))s, 20,0)
/*--- expand stcK(e) to 16 Byte ---------------------------------*/
timeStckExp: procedure expose m.
parse arg s
return left(copies('00'x, length(s) <= 8 & s >> '09'x)s, 16,'00'x)
/*--- conversion from StckE Clock Value to TAI10 Timestamp
BLSUETOD is described in z/OS MVS IPCS Customization --------*/
timeStckE2TAI10: PROCEDURE expose m.
parse arg stck /* must be 16 characters ||||| */
TDATE = left('' , 26)
ADDRESS LINKPGM "BLSUETOD stck TDATE"
/* return format : mo/dd/yyyy hh:mm:ss.uuuuuu */
/* Timestamp format: yyyy-mm-dd-hh.mm.ss.uuuuuu */
parse var TDATE mo '/' dd '/' yyyy hh ':' mm ':' secs
RETURN yyyy'-'mo'-'dd'-'hh'.'mm'.'secs
endProcedure timeStckE2TAI10
/*--- conversion from Lrsn Clock Value to TAI10 Timestamp ----------*/
timeLrsn2TAI10:
return timeStckE2TAI10(x2c(arg(1))'000000000000'x)
/*--- conversion from Lrsn Clock Value to LZT Local Zurich Time -----*/
timeStckE2LZT: procedure expose m.
parse arg s
numeric digits 23
return timeStckE2TAI10(d2c(c2d(left(s, 8)) ,
+ m.time_LZT_TAI10_us16, 8) || substr(s, 9))
endProcedure timeStckE2LZT
/*--- conversion from Lrsn Clock Value to LZT Local Zurich Time -----*/
timeLrsn2LZT: procedure expose m.
parse arg lrsn
return timeStckE2LZT(x2c(lrsn) || '000000000000'x)
/* convert a lrsn to the uniq variable *******************************/
timeLrsn2uniq: procedure expose m.
parse arg lrsn
/* unique are bits 0:41 of the TodClock value
minus 31.12.2004 represented
by base 35 by 'ABC...YZ01..8'
*/
lrsn = left(timeLrsnExp(lrsn), 14)
numeric digits 20
diff = x2d(lrsn) - m.time_UQZero
if diff < 0 then
return'< 2005'
return right(i2q(diff % 64, m.time_UQDigits), 8, 'A')
endProcedure timeLrsn2Uniq
/* convert a uniq variable to lrsn ***********************************/
timeUniq2lrsn: procedure expose m.
parse arg uniq
numeric digits 20
u1 = q2i(left(uniq, 8, 'A'), m.time_UQDigits) * 64
lrsn = '00'right(d2x(u1 + m.time_UQZero), 12, 0)'000000'
return lrsn
endProcedure uniq2lrsn
/*--- translate a number in q-system to decimal
arg digits givs the digits corresponding to 012.. in the q sysem
q = length(digits) -------------------------------------------*/
q2i: procedure expose m.
parse arg v, digits
b = length(digits)
i = 0
do x = 1 to length(v)
q = substr(v, x, 1)
r = pos(q, digits)
if r < 1 then
call err 'bad digit' q 'in' v 'valid digits' digits
i = i * b + r - 1
end
return i
endProcedure q2i
/*--- translate a decimal number to q-system - inverse of q2i -------*/
i2q: procedure expose m.
parse arg i, digits
if i = 0 then
return left(digits, 1)
b = length(digits)
v = ''
do while i > 0
v = substr(digits, 1 + (i // b), 1) || v
i = i % b
end
return v
endProcedure i2q
/* copy time end ----------------------------------------------------*/
}¢--- A540769.WK.REXX(TIMELRSN) cre=2011-03-31 mod=2011-03-31-22.15.20 A540769 ---
call timeTest
exit
/*rexx*/
/******************************************************************/
/* LRSN */
/* */
/* 1 FUNCTION Translate Timestamp <-> LRSN (Todclock) */
/* */
/* 2 SUMMARY */
/* TYPE Rexx TSO/ISPF */
/* HISTORY: */
/* 09.11.2006 V1.0 base version (M.Streit,KITD2) */
/* 01.11.2007 V1.1 added uniq (W.Keller,KIUT23) */
/* */
/* Call: tso lrsn (TSO.RZ1.P0.USER.EXEC) */
/* */
/* 3 USAGE rexx lrsn start-procedure */
/* rexx rlrsn programm */
/* panel plrsn Mainpanel */
/* table tlrsn ISPF table */
/* */
/******************************************************************/
debug = 0 /* 0 oder 1 */
/* Check if LogMode 4 used */
lines=SYSVAR(SYSLTERM)
cols =SYSVAR(SYSWTERM)
if lines < 43
then do;
address ISPEXEC;
zmsg000l = "LM4 with 43x80 Chars required"
"setmsg msg(ispz000)"
exit(8);
end ;
/* Create ISPF table if necessary */
address ispexec
"control errors return" /* ISPF Error -> control back to pgm */
"tbopen tlrsn write" /* try to open table */
NAMES ="(CLRSN CTS CTSUTC CUNIQ JULIAN GMTTIME)"
if RC = 0 then do
address ispexec "tbQuery tlrsn names(tnm)"
if tnm <> names then do
say 'old table tLrsn has bad filed names' tnm
say 'drop and recreate table tLrsn' names
address ispexec 'tbEnd tLrsn'
address ispexec 'tberase tLrsn'
rc = 8
end
end
if rc = 8 then do /* if table not found...*/
address ispexec
"tbcreate tlrsn", /* table create */
"names"names "write replace"
if rc > 4 then do
say "Table create error with RC "rc
exit
end
"tbopen tlrsn write" /* table open */
end
if rc = 12 then do
"tbclose tlrsn "
"tbopen tlrsn write" /* try to open table */
if rc > 0 then do
say "Table open error with RC "rc
end
end
"tbtop tlrsn" /* jump to first row */
/* Display panel until PF3 is pressed */
selrows = "ALL" /* Angaben für Panel */
num1 = 1 /* Linien-Pointer */
c = ''
zc = 'CSR'
sdata = 'N'
ptimest = ''
plrsn = ''
do forever /* solange nicht PF3 */
call timeReadCvt
"tbtop tlrsn" /* jump to first row */
"tbdispl tlrsn panel(plrsn)" /* Panel anzeigen bis */
if rc > 4 then leave /* PF3 gedrückt? */
do while rc < 8
if c = 'D' then do
call del_row /* Zeilen löschen */
end
else if c <> ' ' then do
zmsg000s = "Command unknown"
zmsg000l = "Command unknown, only Delete(D) allowed"
"setmsg msg(ispz000)" /* Meldung ausgeben */
leave
end
if ztdSels <= 1 then
leave
"tbdispl tlrsn" /* get next selection */
end
c = ''
if plrsn <> '' then call calcFromLrsn pLrsn
if ptimest <> '' then call calcFromTst pTimeSt
if pUniq <> '' then call calcFromUniq pUniq
end
if sdata='Y' then
"tbclose tlrsn "
else
"tbend tlrsn"
exit
/* expand timestamp and validate it ***********************************/
checkTst: procedure
parse arg pTimeSt
/* ptimest = Timestamp format yyyy-mm-dd-hh.mm.ss.ffffff */
rTimeSt =overlay(ptimest, '1972-01-01-00.00.00.000000')
call timestampParse rTimest
/* check if values in range */
if (yyyy<1972) | (yyyy>2141) then do
zmsg000s = ""
zmsg000l = "year range: 1972-2041"
address ispExec " setmsg msg(ispz000)" /* Meldung ausgeben */
return ''
end
if (mo<1) | (mo>12) then do
zmsg000s = ""
zmsg000l = "month range 1-12"
address ispExec "setmsg msg(ispz000)" /* Meldung ausgeben */
return ''
end
if (dd<1) | (dd>31) then do
zmsg000s = ""
zmsg000l = "day range 1-31"
address ispexec "setmsg msg(ispz000)" /* Meldung ausgeben */
return ''
end
return rTimest
endProckedure checkTst
/* delete current row ***********************************************/
del_row:
address ispexec
rowid_nr=0
"tbget tdbnr rowid(rowid_nr)" /* Curor-Position lesen */
"tbskip tdbnr row("rowid_nr")" /* Cursor auf Row setzen */
"tbdelete tlrsn" /* Zeile löschen */
c = ''
return
/* read timeZoneOffset and leapSeconds registers
and set variables for uniq ***********************************/
read_cvt:
/* offsets documented in z/OS Data Areas Vol.1 */
cvt_off ='00000010' /* (offset = X'10') */
cvtext2_off='00000560'
cvtldto_off='00000038'
cvtlso_off ='00000050'
/* get CVT control block adress */
cvt_adr =C2X(STORAGE(cvt_off,4))
/* get address of extention2 */
cvtext2_adr =D2X(X2D(cvt_adr) + X2D(cvtext2_off))
/* get address of cvtldto timezone value */
cvtldto_adr =D2X(X2D(cvtext2_adr) + X2D(cvtldto_off))
/* get value */
cvtldto =C2X(STORAGE(cvtldto_adr,8))
/* get address of cvtlso leap seconds value */
cvtlso_adr =D2X(X2D(cvtext2_adr) + X2D(cvtlso_off))
/* get value */
cvtlso =C2X(STORAGE(cvtlso_adr,8))
cTZ = x2d(cvtLdto) * 1e-6 / 256 / 16 / 3600
cLS = trunc(x2d(cvtLso) * 1e-6 / 256 / 16)
uniqDigits = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ012345678'
/* find lrsn of day 0 */
uniqZero = left(conv2tod('2004-12-31-00.00.22.000000'), 12)
/* 0 out last 6 bits */
uniqZero = b2x(overlay('000000', x2b(uniqZero), 43))
if debug then do
say "cvt_adr = "cvt_adr
say "cvtext2_adr = "cvtext2_adr
say "cvtldto_adr = "cvtldto_adr
say "cvtldto (TOD-fmt) = "cvtldto,
'=' (x2d(cvtldto) * 16e-6 / 256 / 256) 'secs timezone'
say "cvtldto_adr = "cvtlso_adr
say "cvtlso (TOD-fmt) = "cvtlso ,
'=' (x2d(left(cvtlso, 13)) * 1e-6 ) 'leap secs'
say 'uniqZero' uniqZero ,
'base' length(uniqDigits) 'digits' uniqDigits
end
return
endSubroutin read_cvt
/* calculate all values from timestamp and add row ********************/
calcFromTst:
parse arg pTst
/* Timestamp format: yyyy-mm-dd-hh.mm.ss.ffffff */
rTimeSt = checkTst(pTst)
if rTimeSt = '' then
return
lrsn_cet= CONV2TOD(rTimeSt)
lrsn_cet=LEFT(STRIP(lrsn_cet),16,'0')
if debug then say "LRSN (CET) ="lrsn_cet
cLrsn = D2X(X2D(lrsn_cet) - m.timeZone + m.timeLeap)
if debug then say "LRSN (UTC) ="clrsn
cts = rtimest /*ptimest with overlay */
ctsutc = CONV2TS(clrsn)
gmtTime = substr(ctsutc, 12, 8)
cUniq = lrsn2uniq(cLrsn)
julian = tst2jul(cts)
ptimest = ''
"tbadd tlrsn"
return
endProcedure calcFromTst
/* from lrsn calculate all values add it to our table *****************/
calcFromLrsn:
parse arg lrsn
LRSN=LEFT(STRIP(LRSN),16,'0')
if debug then say "LRSN (UTC) ="LRSN
LRSN_TZ=D2X(X2D(LRSN) + m.timeZone)
if debug then say "LRSN timezone corrected ="LRSN_TZ
LRSN_CET=D2X(X2D(LRSN_TZ) - m.timeLeap)
if debug then say "LRSN timezone and leap seconds corrected ="LRSN_CET
if debug then say ""
if debug then say ""
if debug then say ""
/*********
LEAPSEC = 23
XSEC = X2D('0000000F4240000');
1 2 3 4 5 6 7
CORR = LEAPSEC * XSEC
**********/
if debug then say =CONV2TS(LRSN) "(UTC)"
clrsn = lrsn
cts = CONV2TS(LRSN_CET)
ctsutc = CONV2TS(LRSN)
gmtTime = substr(ctsutc, 12, 8)
cUniq = lrsn2uniq(cLrsn)
julian = tst2jul(cts)
"tbadd tlrsn"
if debug then say "RC="rc
plrsn = ''
return
endProcedure calcFromLrsn
/* from uniq calculate all values and add them to our table ***********/
calcFromUniq:
parse arg uniq
if verify(uniq, m.timeUQDigits) > 0 then do
zmsg000s = "bad uniq"
zmsg000s = ""
zmsg000l = "Uniq allows only characters A-Z and 0-8"
"setmsg msg(ispz000)" /* Meldung ausgeben */
return
end
call calcFromLrsn uniq2Lrsn(uniq)
pUniq = ''
return
calcFromUniq
/* timestamp to julian ************************************************/
tst2jul: procedure
parse arg yyyy '-' mm '-' dd '-'
/* date function cannot convert to julian, only from julian
==> guess a julian <= the correct and
try the next values
*/
j = trunc((mm-1) * 29.5) + dd
yy = right(yyyy, 2)
do j=j by 1
j = right(j, 3, 0)
d = date('s', yy || j, 'j')
if substr(d, 3) = yy || mm || dd then
return yy || j
end
return
/* convert a lrsn to the uniq variable ********************************/
lrsn2uniq: procedure expose m.
parse arg lrsn
/* unique are bits 0:41 of the TodClock value
minus 31.12.2004 represented
by base 35 by 'ABC...YZ01..8'
*/
lrsn = left(lrsn, 12)
diff = x2d(lrsn) - x2d(m.timeUQZero)
if diff < 0 then
return '<2005|'
diff = right(d2x(diff), 12, 0)
if debug then say ' lrsn ' lrsn
if debug then say '- zero ' m.timeUQZero
if debug then say '= ' diff
d42 = b2x(left(right(x2b(diff), 48, 0), 42))
if debug then say 'd42 ' d42
uni = right(i2bd(x2d(d42), m.timeUQDigits), 8, 'A')
if debug then say 'uni ' uni
return uni
endProcedure lrsn2uniq
/* convert a uniq variable to lrsn ************************************/
uniq2lrsn: procedure expose m.
parse arg uniq
uniq = left(uniq, 8, 'A')
d42 = d2x(bd2i(uniq, m.timeUQDigits))
d48 = b2x('00'x2b(d42)'000000')
lrsn = right(d2x(x2d(d48) + x2d(m.timeUQZero)), 12, 0)
return lrsn
endProcedure uniq2lrsn
/* conversion from Timestamp to TOD Clock Value ***********************/
CONV2TOD: PROCEDURE
/* timestamp yyyy-mm.... -> tod value: - leapseconds
BLSUXTID is described in z/OS V1R7.0 MVS IPCS Customization
BLSUXTID format : mo/dd/yyyy hh:mm:ss.ffffff
*/
parse arg tst
call timestampParse tst
tDate = mo'/'dd'/'yyyy' 'hh':'mm':'ss'.'ffffff
ACC=left('', 8)
ADDRESS LINKPGM "BLSUXTID TDATE ACC"
RETURN LEFT(c2x(ACC),16,'0')
endProcedure conv2tod
/* conversion from TOD Clock Value to Timestamp */
/* BLSUXTOD is described in z/OS V1R7.0 MVS IPCS Customization */
/* input -> + leapseconds -> output */
CONV2TS: PROCEDURE
ACC=ARG(1)
ACC=X2C(ACC)
TDATE = COPIES('0' , 26)
ADDRESS LINKPGM "BLSUXTOD ACC TDATE"
/* return format : mo/dd/yyyy hh:mm:ss.ffffff */
/* Timestamp format: yyyy-mm-dd-hh.mm.ss.ffffff */
parse var TDATE mo '/' dd '/' yyyy hh ':' mm ':' ss '.' ffffff
TDATE = yyyy'-'mo'-'dd'-'hh'.'mm'.'ss'.'ffffff
RETURN TDATE
bd2i: procedure expose m.
parse arg v, digits
b = length(digits)
i = 0
do x = 1 to length(v)
q = substr(v, x, 1)
r = pos(q, digits)
if r < 1 then
call err 'bad digit' q 'in' v 'valid digits' digits
i = i * b + r - 1
end
return i
i2bd: procedure expose m.
parse arg i, digits
if i = 0 then
return left(digits, 1)
b = length(digits)
v = ''
do while i > 0
v = substr(digits, 1 + (i // b), 1) || v
i = i % b
end
return v
/* copy time begin ---------------------------------------------------*/
timeTest: procedure
numeric digits 32
t1 = '2011-03-31-14.35.01.234567'
s1 = 'C5E963363741'
say 'Lrsn2Lzt('s1')' timeLrsn2Lzt(s1)
call timeReadCvt 1
say 'tst2jul('t1') ' tst2jul(t1)
say 'Lrsn2Gmt('s1')' timeLrsn2Gmt(s1)
say 'Lrsn2Lzt('s1')' timeLrsn2Lzt(s1)
say 'gmt2Lrsn('t1')' timeGmt2Lrsn(t1)
say 'lzt2Lrsn('t1')' timeLzt2Lrsn(t1)
say 'Lrsn2Gmt(gmt2Lrsn('t1')' timeLrsn2Gmt(timeGmt2Lrsn(t1))
say 'gmt2Lrsn(Lrsn2Gmt('s1')' timeGmt2Lrsn(timeLrsn2Gmt(s1))
say 'Lrsn2LZt(LZt2Lrsn('t1')' timeLrsn2LZt(timeLZt2Lrsn(t1))
say 'LZt2Stc(Lrsn2LZt('s1')(' timeLZt2Lrsn(timeLrsn2LZt(s1))
/* say 'conv2tod('t1')' conv2tod(t1) /* gmt --> stck */
say 'conv2ts('s1')' conv2ts(s1) /* stck --> gmt */
*/ return
endProcedure timeTest
/*--- read timeZoneOffset and leapSeconds registers
and set variables for uniq ----------------------------------*/
timeReadCvt: procedure expose m.
parse arg debug
numeric digits 32
/* offsets documented in z/OS Data Areas Vol.1 */
cvtOH = '00000010' /* cvt control block Address */
cvtext2O = x2d('00000560') /* offset to extension 2 */
cvtldtoO = x2d('00000038') /* offset to timezone */
cvtlsoO = x2d('00000050') /* offset to leapSeconds */
/* CVT CB address + extention2 */
cvtExt2A = C2D(STORAGE(cvtOH,4)) + cvtext2O
/* cvtLdto timeZone address +offset */
m.timeZone = c2d(STORAGE(d2x(cvtext2A+cvtldtoO, 8), 8))
m.timeStckUnit = 1e-6 / 256 / 16
/* cvtLso LeapSecs address +offset */
m.timeLeap = C2D(STORAGE(d2x(cvtext2A+cvtlsoO, 8), 8))
m.timeUQDigits = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ012345678'
/* find lrsn of day 0 */
m.timeUQZero = timeGmt2Lrsn('2004-12-31-00.00.22.000000')
/* 0 out last 6 bits */
m.timeUQZero = b2x(overlay('000000', x2b(m.timeUQZero), 43))
if debug == 1 then do
say 'stckUnit =' m.timeStckUnit
say 'timeLeap =' d2x(m.timeLeap,16) '=' m.timeLeap ,
'=' format(m.timeLeap * m.timeStckUnit, 9,3) 'secs'
say 'timeZone =' d2x(m.timeZone,16) '=' m.timeZone,
'=' format(m.timeZone * m.timeStckUnit, 6,3) 'secs'
say "cvtext2_adr =" d2x(cvtExt2A, 8)
say 'timeUQZero =' m.timeUQZero
say 'timeUQDigis =' ,
length(m.timeUQDigits) 'digits' m.timeUQDigits
end
m.timeReadCvt = 1
return
endSubroutin timeReadCvt
timestampParse:
parse arg yyyy'-'mo'-'dd'-'hh'.'mm'.'ss'.'ffffff
return
/*--- GMT timestamp yyyy-mm.... -> stck value char(8)
BLSUXTID is described in z/OS V1R7.0 MVS IPCS Customization
BLSUXTID format : mo/dd/yyyy hh:mm:ss.ffffff ---------------*/
timeGmt2Stck: procedure expose m.
parse arg tst
call timestampParse tst
tDate = mo'/'dd'/'yyyy' 'hh':'mm':'ss'.'ffffff
ACC=left('', 8, '00'x)
ADDRESS LINKPGM "BLSUXTID TDATE ACC"
RETURN acc
endProcedure timeGmt2Stck
/*--- GMT timestamp yyyy-mm.... -> stck value in hex(16) ------------*/
timeGmt2LRSN:
return c2x(left(timeGmt2Stck(arg(1)), 6))
endProcedure timeGmt2LRSN
/*--- LZT (Locale Zurich Tst -> stck value in hex(16) ---------------*/
timeLZT2LRSN: procedure expose m.
parse arg tst
if m.timeReadCvt \== 1 then
call timeReadCvt
return left(d2x(c2d(timeGmt2Stck(tst)) ,
- m.timeZone + m.timeLeap, 16), 12)
endProcedure timeLZT2LRSN
/*--- conversion from Stck Clock Value to GMT Timestamp
BLSUXTOD is described in z/OS V1R7.0 MVS IPCS Customization
input -> + leapseconds -> output ----------------------------*/
timeStck2Gmt: PROCEDURE expose m.
parse arg stck
stck = left(stck, 8, '00'x)
TDATE = COPIES('0' , 26)
ADDRESS LINKPGM "BLSUXTOD stck TDATE"
/* return format : mo/dd/yyyy hh:mm:ss.ffffff */
/* Timestamp format: yyyy-mm-dd-hh.mm.ss.ffffff */
parse var TDATE mo '/' dd '/' yyyy hh ':' mm ':' ss '.' ffffff
RETURN yyyy'-'mo'-'dd'-'hh'.'mm'.'ss'.'ffffff
endProcedure timeStck2Gmt
/*--- conversion from Lrsn Clock Value to GMT Timestamp -------------*/
timeLrsn2Gmt:
return timeStck2Gmt(x2c(arg(1)))
endProcedure timeLrsn2Gmt
/*--- conversion from Lrsn Clock Value to LZT Local Zurich Time -----*/
timeLrsn2LZT: procedure expose m.
parse arg lrsn
if m.timeReadCvt \== 1 then
call timeReadCvt
return timeStck2Gmt(d2c(x2d(left(lrsn, 16, 0)) ,
+ m.timeZone-m.timeLeap))
endProcedure timeLrsn2LZT
/* copy time end -----------------------------------------------------*/
}¢--- A540769.WK.REXX(TIMING) cre=2016-07-11 mod=2016-07-11-11.46.32 A540769 ---
/* copy timing begin *************************************************/
timing: procedure expose m.
parse arg typ, c2, txt
e1 = time('E')
c1 = strip(sysvar('syscpu'))
s1 = sysvar('syssrv')
if typ == '' then
return strip(f('%c ela=%5i cpu=%8.3i su=%9i' ,
, time(), e1, c1, s1) txt)
if symbol('m.timing_ela') \== 'VAR' then
call err 'timing('typ',' c2',' txt') ohne ini'
if symbol('m.timing.typ.ela') \== 'VAR' then do
m.timing.typ.ela = 0
m.timing.typ.cpu = 0
m.timing.typ.su = 0
m.timing.typ.cnt = 0
m.timing.typ.cn2 = 0
if symbol('m.timing_types') == 'VAR' then
m.timing_types = m.timing_types typ
else
m.timing_types = typ
if symbol('m.timing_say') \== 'VAR' then
m.timing_say = 0
end
m.timing.typ.ela = m.timing.typ.ela + e1 - m.timing_ela
m.timing.typ.cpu = m.timing.typ.cpu + c1 - m.timing_cpu
m.timing.typ.su = m.timing.typ.su + s1 - m.timing_su
m.timing.typ.cnt = m.timing.typ.cnt + 1
if c2 \== '' then
m.timing.typ.cn2 = m.timing.typ.cn2 + c2
m.timing_ela = e1
m.timing_cpu = c1
m.timing_su = s1
if m.timing_say then
say left(typ, 10)right(m.timing.typ.cn2, 10) ,
'ela='m.timing.typ.ela ,
'cpu='m.timing.typ.cpu 'su='m.timing.typ.su txt
return
endProcedure timing
timingSummary: procedure expose m.
say 'timing summary' time()
do tx = 1 to words(m.timing_types)
typ = word(m.timing_types, tx)
say left(typ, 10)right(m.timing.typ.cnt, 7) ,
|| right(m.timing.typ.cn2, 7) ,
'cpu='right(m.timing.typ.cpu, 10) ,
'su='right(m.timing.typ.su, 10)
end
return
endProcedure timingSummary
/* copy timing end *************************************************/
}¢--- A540769.WK.REXX(TKR) cre=2016-07-11 mod=2016-07-11-15.40.21 A540769 ------
/*--- copy tkr begin ---------------------------------------------------
table key relationship
----------------------------------------------------------------------*/
tkrTable: procedure expose m.
parse arg m, key, wh
if m == '' then
m = tkr
dx = pos('.', key)
if dx < 1 then
mt = m'.t.'key
else
mt = key
if m.mt \== 'table' then
if arg() >= 4 then
return arg(4)
else
call err 'not a table' key', mt' mt'->'m.mt
if wh == '' then
return mt
else if wh == 't' then
return m.mt.table
else if wh == 'o' then
return m.mt.order
else if wh == 'f' then
return 'from' m.mt.table 'where' m.mt.cond
else if wh == 'w' then
return m.mt.cond
else if wh == 'e' then
return m.mt.editFun
else
call err 'bad what' wh 'in tkrTable('m',' tb',' wh')'
endProcedure tkrTable
tkrWhere: procedure expose m.
parse arg m, pa ':' wh
if m == '' then
m = tkr
pEx = tkrPath(m, pa)
m.m.path = pEx
sq = wh
do px=words(pEx)-1 by -1 to 1
tt = word(pEx, px)
tf = word(pEx, px+1)
if symbol('m.m.t2t.tt.tf') == 'VAR' then
parse value m.m.t2t.tt.tf 'LEF RIG' with rl fTo fFr
else if symbol('m.m.t2t.tf.tt') == 'VAR' then
parse value m.m.t2t.tf.tt 'RIG LEF' with rl fTo fFr
else
call err 'no relationShip to' tt 'from' tf 'path' pEx,
't.f' m.m.tt.tf 'f.t' m.m.tf.tt
if m.rl.fFr.sql1 \== '' then
sq = m.rl.fFr.sql1 sq')'
else do
kc = min(mGet(m.rl.lef'.'0), mGet(m.rl.rig'.'0))
sq = '('mCatFT(m.rl.fTo, 1, kc, '%qn, %s')')' ,
'in (select' mCatFT(m.rl.fFr, 1, kc, '%qn, %s'),
tkrTable(m,mGet(m.rl.fFr'.'table),'f') sq')'
end
/* kc = min(mGet(m.rl.lef'.'0), mGet(m.rl.rig'.'0))
s2 = '('mCatFT(m.rl.fTo, 1, kc, '%qn, %s')') in'
if m.rl.fFr.special \== '' then
sq = s2 m.rl.fFr.special sq')'
else
sq = s2 '(select' mCatFT(m.rl.fFr, 1, kc, '%qn, %s'),
tkrTable(m,mGet(m.rl.fFr'.'table),'f') sq')'
sq = '('mCatFT(m.rl.fTo, 1, kc, '%qn, %s')')' ,
'in (select' mCatFT(m.rl.fFr, 1, kc, '%qn, %s'),
tkrTable(m,mGet(m.rl.fFr'.'table),'f') sq')' */
end
return sq
endProcedure tkrWhere
tkrPath: procedure expose m.
parse arg m, sPa
res = word(sPa, 1)
do sx=2 to words(sPa)
p1 = tkrPat1(m, word(sPa, sx-1), word(sPa, sx))
if p1 == '' then
call err 'no path to' word(sPa, sx-1) 'from' word(sPa, sx)
res = res subWord(p1, 2)
end
if m.debug then
say '???' sPa '==path==>' res
return res
endProcedure tkrPath
tkrPatChk: procedure expose m.
parse arg m, pa
p2 = space(pa, 1)
do bx=1 to words(m.m.pathBad)
b1 = word(m.m.pathBad, bx)
if abbrev(b1, 1) then do
wx = wordPos(substr(b1, 2), p2)
if wx > 1 & wx < words(p2) then
return ''
end
else if pos('|', b1) > 0 then do
parse var b1 t1 '|' t2
wx = wordPos(t1, p2)
if wx > 1 & wx < words(p2) then
if word(p2, wx-1) \== t2 & word(p2, wx+1) \== t2 then
return ''
end
else if pos('-', b1) > 0 then do
b2 = translate(b1, ' ', '-')
if pos(' 'b2' ', ' 'p2' ') > 0 then
return ''
b3 = ''
do wx=1 to words(b2)
b3 = word(b2, wx) b3
end
if pos(' 'b3' ', ' 'p2' ') > 0 then
return ''
end
else
call err 'bad pathBad word' b1 'in' m.m.pathBad
end
return strip(p2)
endProcedure tkrPatChk
/*--- return path to tt from tf, fail if not unique ------------------*/
tkrPat1: procedure expose m.
parse arg m, tt, tf
m.m.pathRes.0 = 0
call tkrPat3 m, tt, tf
if m.m.pathRes.0 = 1 then
return m.m.pathRes.1
else if m.m.pathRes.0 < 1 then
call err 'no path to' tt 'from' tf
else if m.m.pathRes.0 > 1 then
call err 'multiple ('m.m.pathRes.0') paths to' tt 'from' tf,
mCat(m'.'pathRes, '\n%s%qn\n%s')
endProcedure tkrPat1
/*--- add minimal paths to tt from tf to pathRes ---------------------*/
tkrPat2: procedure expose m.
parse arg m, tt, tf
call tkrPat3 m, tt, tf
if m.debug then do
say '???' tt '<' tf '--pat2-->' m.m.pathRes.0 'paths'
do px=1 to m.m.pathRes.0
say '???'px'???' m.m.pathRes.px
end
end
return
endProcedure tkrPat2
/*--- add minimal paths to tt from tf to pathRes ---------------------*/
tkrPat3: procedure expose m.
parse arg m, tt, pa1 paR
pa = tkrPatChk(m, pa1 paR)
if pa == '' then
return
if tt = pa1 then do
/* ok target reached, is there already a shorter path? */
do px=1 to m.m.pathRes.0
if wordsIsSub(pa, m.m.pathRes.px) then
return
end
/* remove all longer paths */
qx = 0
do px=1 to m.m.pathRes.0
if wordsIsSub(m.m.pathRes.px, pa) then
iterate
qx = qx+1
m.m.pathRes.qx = m.m.pathRes.px
end
/* add new path */
qx = qx+1
m.m.pathRes.qx = pa
m.m.pathRes.0 = qx
return
end
/* use direct connection if it exists */
if symbol('m.m.t2t.tt.pa1') == 'VAR' ,
| symbol('m.m.t2t.pa1.tt') == 'VAR' then do
call tkrPat2 m, tt, tt pa1 paR
return
end
tb1 = tkrTable(m, pa1)
/* try all connections from pa1 */
do rx=1 to words(m.tb1.rels)
r1 = word(m.tb1.rels, rx)
if mGet(mGet(m.r1.lef'.TABLE')'.ALIAS') == pa1 then
a1 = mGet(mGet(m.r1.rig'.TABLE')'.ALIAS')
else if mGet(mGet(m.r1.rig'.TABLE')'.ALIAS') == pa1 then
a1 = mGet(mGet(m.r1.lef'.TABLE')'.ALIAS')
else
call err 'relationship' tb1 'not connecting' pa1
if wordPos(a1, pa1 paR) > 0 then
iterate
call tkrPat2 m, tt, a1 pa1 paR
end
return
endProcedure tkrPat3
wordsIsSub: procedure expose m.
parse arg long, short
sW = words(short)
if sW = 0 then
return 1
lW = words(long)
if sW > lW then
return 0
else if sW = lW then
return space(long, 1) == space(short, 1)
if word(long, lW) \== word(short, sW) then
return 0
lX = 1
do sX=2 to sW-1
lx = wordPos(word(short, sX), long, lX+1)
if lX <= 1 | sW-sX > lW-lX then
return 0
end
return 1
endProcedure wordsIsSub
tkrType: procedure expose m.
parse arg m, col
if m == '' then
m = tkr
upper col
if wordPos(col, m.m.numeric) > 0 then
return 'n'
cNQ = substr(col, 1+pos('.', col))
if wordPos(cNQ, m.m.numeric) > 0 then
return 'n'
if wordPos(cNQ, m.m.hex) > 0 then
return 'x'
return 'c'
endProcedure tkrType
tkrValue: procedure expose m.
parse arg m, al, col, val
if m == '' then
m = tkr
if pos('.', col) < 1 then
if al == '' then
call err 'no alias'
else
col = al'.'col
tt = tkrType(m, col)
if tt == 'c' then
return quote(val, "'")
if tt == 'n' then
if datatype(val, 'n') then
return val
else
call err 'not numeric' val 'for col' col
if tt == 'x' then
if verify(val, '0123456789abcdefABCDEF', 'n') < 1 then
return "x'"val"'"
else
call err 'not a hex value' val 'for col' col
call err 'unsupport tkrType' tt
endProcedure tkrValue
tkrPred: procedure expose m.
parse arg m, al, col, va
if col == '-' | col == '' | va == '*' then
return ''
if m == '' then
m = tkr
if pos('.', col) < 1 then
if al == '' then
call err 'no alias'
else
col = al'.'col
va = tkrValue(m, , col, va)
if abbrev(va, "'") then
if verify(va, '*%_', 'm') > 0 then
return 'and' col 'like' translate(va, '%', '*')
return 'and' col '=' va
endProcedure tkrPred
tkrIniDb2Cat: procedure expose m.
parse arg m
call sqlCatIni
if m == '' then
m = tkr
if m.m.ini == 1 then
return
m.m.ini = 1
y = 'sysIbm.sys'
mC = tkrIniT(m, 'c' y'Columns', 'tbCreator tbName name',
, 'tbCreator tbName colNo', , , '1')
mCo =tkrIniT(m, 'co' y'Copy',
, 'dbName tsName dsNum instance timestamp' ,
, 'co.dbName, co.tsName, co.timestamp desc',
,,'sqlCatCopy')
call tkrIniK m, mCo, '1plus', 'dbName tsName dsNum instance' ,
'timestamp icType start_Rba dsName pit_Rba'
mDb =tkrIniT(m, 'db' y'Database', 'name')
call tkrIniK m, mDb, 'id iu', 'DBID'
mI = tkrIniT(m, 'i' y'Indexes', 'creator name' ,
, 'tbCreator, tbName, creator, name', , , 'vl')
call tkrIniK m, mI, 't i', 'tbCreator tbName'
call tkrIniK m, mI, 'vl u', 'creator name tbCreator tbName'
call tkrIniK m, mI, 'db1 iu', 'dbName indexSpace'
mIK= tkrIniT(m, 'ik' ,
'sysibm.sysIndexes ik' ,
'left join sysibm.sysKeys ikK' ,
'on ikK.ixCreator = ik.creator' ,
'and ikK.ixName=ik.name' ,
'left join sysibm.sysColumns ikC' ,
'on ikC.tbCreator = ik.tbCreator' ,
'and ikC.tbName = ik.tbName' ,
'and ikC.colNo = ikK.colNo' ,
, 'creator name ikK.colSeq' ,
, 'ik.tbCreator, ik.tbName, ik.creator' ,
|| ', ik.name, ikK.colSeq', , 'sqlCatIxKeys','vl')
call tkrIniK m, mIK, 'vl u', 'creator name colName ',
'tbCreator tbName'
call tkrIniT m, 'ip' y'indexPart', 'ixCreator ixName partition' ,
, , , ,1
mPk =tkrIniT(m, 'pk' y'Package', 'location collid name conToken' ,
, 'location, collid, name, pcTimestamp desc',,,'vl')
call tkrIniK m, mPk, '1plus',
, 'location collid name contoken version type'
call tkrIniK m, mPk, 'vl',
, 'location collid name version'
mPkd=tkrIniT(m, 'pkd' y'PackDep',
, 'dLocation dCollid dName dConToken',,,,'vl')
call tkrIniK m, mPkd, 'b', 'bQualifier bName'
call tkrIniK m, mPkd, 'vl', 'dLocation dCollid dName' ,
'bQualifier bName'
mRc =tkrIniT(m, 'rc' 'oa1p.vqz005Recover', 'db ts pa',
,,,'sqlCatRec')
call tkrIniK m, mRc, '1plus', 'db ts pa fun recover',
'basPTT loadText unlTst unl punTst pun tb'
call tkrIniT m, 'ri' y'IndexSpaceStats' ,
, 'creator name partition' ,
, 'creator name instance partition' ,
, , 'sqlCatIxStats', 1
/* 'dbid isobid partition instance' , */
mRT= tkrIniT(m, 'rt' y'TableSpaceStats' ,
, 'dbId psId partition instance',
, 'dbName name instance partition' ,
, , 'sqlCatTSStats')
call tkrIniK m, mRT, '1plus', 'dbId psId partition instance' ,
'dbName name'
call tkrIniK m, mRT, 'nm u', 'dbName name partition instance'
mT = tkrIniT(m, 't' y'Tables', 'creator name',
, , "t.type not in ('A', 'V')", 'sqlCatTables', 1)
call tkrIniK m, mT, 'db i', 'dbName tsName'
call tkrIniK m, mT, '1plus', 'creator name dbName tsName'
mTg =tkrIniT(m, 'tg' y'Triggers', 'schema name seqno',
, 'tbOwner, tbName, schema, name',,, 1)
call tkrIniK m, mTg, 'tb', 'tbOwner tbName'
call tkrIniT m, 'tp' y'TablePart', 'dbName tsName partition'
mTs =tkrIniT(m, 'ts' y'TableSpace', 'dbName name')
call tkrIniK m, mTs, 'id', 'dbId psId'
call tkrIniT m, 'v' y'Tables', 'creator name',, "v.type = 'V'",,1
mVD =tkrIniT(m, 'vd' y'ViewDep', 'dCreator dName',,,,'vl')
call tkrIniK m, mVd, 'b', 'bCreator bName'
call tkrIniK m, mVd, 'vl', 'dCreator dName bCreator bName'
call trkIniR m, 'c', 'v t'
call trkIniR m, 'co', 'ts tp rt.nm rc'
p0sql = '(SelecT smallInt(0) p FroM sysibm.sysDummy1' ,
'union all select smallInt(32767)p FroM sysibm.sysDummy1)p0'
r1 = tkrRel(m, 'co-tp')
m.r1.rig.sql1 = '(co.dbName, co.tsName, co.dsNum)' ,
'in (select tp.dbName, tp.tsName' ,
', min(tp.partition, p0.p)' ,
'from sysibm.sysTablePart tp,' p0Sql 'where'
r2 = tkrRel(m, 'co-rt')
m.r2.rig.sql1 = '(co.dbName, co.tsName, co.dsNum, co.instance)' ,
'in (select rt.dbName, rt.name' ,
', min(rt.partition, p0.p), rt.instance' ,
'from sysibm.sysTablespaceStats rt,' p0Sql 'where'
call trkIniR m, 'db', 'ts t.db tp rc rt co i.db1'
call trkIniR m, 'i.t', 't'
call trkIniR m, 'i', 'ik ip'
call trkIniR m, 'pk', 'pkd'
call trkIniR m, 'pkd.b', 'i', "pkd.bType in ('I')"
call trkIniR m, 'pkd.b', 't v',
, "pkd.bType in ('A', 'G', 'M', 'S', 'T', 'V')"
call trkIniR m, 'pkd.b', 'ts', "pkd.bType in ('P', 'R')"
call trkIniR m, 'rc', 'tp'
call trkIniR m, 'ri', 'i ip'
call trkIniR m, 'rt', 'ts.id'
call trkIniR m, 'rt.nm', 'tp rc'
call trkIniR m, 'tg.tb', 'v t'
call trkIniR m, 'ts', 't.db tp rc'
call trkIniR m, 'vd.b', 't', "vd.bType in ('G', 'M', 'T', 'V')"
call trkIniR m, 'vd', 'v', "vd.dType in ('V', 'M')"
m.m.pathBad = '1c 1co 1db 1tg pkd|pk vd|v pkd-i-t vkd-i-t'
m.m.numeric = 'PARTITION DBID INSTANCE PSID ISOBID DSNUM'
m.m.hex = 'CONTOKEN'
return
endProcedure tkrIniDb2Cat
tkrIniT: procedure expose m.
parse arg m, ty tb, cols, ord, wh, eFun, vl
mt = m'.t.'ty
if symbol('m.mt') == 'VAR' then
call err 'duplicate table' ty tb ord 'old' mt'->'m.mt
m.mt = 'table'
m.mt.alias = ty
m.mt.table = if(words(tb) == 1, tb ty, tb)
m.mt.uKeys = ''
m.mt.oKeys = ''
m.mt.rels = ''
m.mt.pKey = tkrIniK(m, mt, '1 iu', cols)
m.mt.vlKey = ''
if vl \== '' then
m.mt.vlKey = m'.k.'ty'.'vl
if ord == '' then
m.mt.order = mCat(m.mt.pKey, '%qn, %s')
else if pos(',', ord) < 1 & pos('.', ord) < 1 then
m.mt.order = ty'.'repAll(space(ord, 1), ' ', ',' ty'.')
else
m.mt.order = ord
m.mt.cond = wh || copies(' and', wh \== '')
m.mt.editFun = eFun
return mt
endProcedure tkrIniT
tkrIniK: procedure expose m.
parse arg m, tb, nm oo, cols
if pos(':', cols) > 0 | pos(',', cols) > 0 then
call err 'deimplemented iiKey:' cols
mk = m'.k.'m.tb.alias'.'nm
if symbol('m.mk') == 'VAR' then
call err 'duplicate key' tb nm 'old' mk'->'m.mk
m.mk = 'key'
al = m.tb.alias
m.mk.table = tb
m.mk.name = m.tb.alias'.'nm
m.mk.opt = oo
m.mk.0 = words(cols)
do cx=1 to m.mk.0
c1 = word(cols, cx)
dx = pos('.', c1)
if dx < 1 then do
m.mk.cx = al'.'c1
m.mk.cx.col = translate(c1)
end
else do
m.mk.cx = c1
m.mk.cx.col = translate(substr(c1, dx+1))
end
end
m.mk.colList = mCat(mk, '%qn, %s')
if pos('i', oo) > 0 then
m.tb.uKeys = strip(m.tb.uKeys mk)
else
m.tb.oKeys = strip(m.tb.oKeys mk)
return mk
endProcedure tkrIniK
trkIniR: procedure expose m.
parse arg m, le, aRi, leCo, riCo
le = tkrKey(m, le)
lTb = m.le.table
do rx=1 to words(aRi)
ri = tkrKey(m, word(aRi, rx))
rTb = m.ri.table
ky = m'.r.'m.lTb.alias'-'m.rTb.alias
if symbol('m.ky') == 'VAR' then
call err 'duplicate relationShip' ky 'old' m.ky
m.ky = 'relationShip'
m.ky.lef = le
m.ky.lef.sql1 = ''
m.ky.lef.cond = leCo || copies(' and', leCo \== '')
m.lTb.rels = m.lTb.rels ky
m.ky.rig = ri
m.ky.rig.cond = riCo || copies(' and', riCo \== '')
m.ky.rig.sql1 = ''
m.rTb.rels = m.rTb.rels ky
lr = m'.T2T.'m.lTb.alias'.'m.rTb.alias
if symbol('m.lr') == 'VAR' then
call err 'duplicate relationShip' ky 'old' m.lr
rl = m'.T2T.'m.rTb.alias'.'m.lTb.alias
if symbol('m.rl') == 'VAR' then
call err 'duplicate inverse relationShip' ky 'old' m.rl
m.lr = ky
end
return ky
endProcedure trkIniR
tkrKey: procedure expose m.
parse arg m, key
if m == '' then
m = tkr
dx = pos('.', key)
if dx < 1 then do
mt = m'.t.'key
if m.mt == 'table' then
return m.mt.pKey
ee = 'not a table' key':' mt'->'m.mt
end
dx = pos('.', key, dx+1)
if dx < 1 then do
mk = m'.k.'key
if m.mk == 'key' then
return mk
ee = 'not a key' key', mk' mk'->'m.mk
end
if m.key == 'key' then
return key
ee = 'not a key' key'-->'m.key
if arg() >= 3 then
return arg(3)
call err ee
endProcedure tkrKey
tkrRel: procedure expose m.
parse arg m, key
if m == '' then
m = tkr
if m.key == 'relationShip' then
return key
mr = m'.r.'key
if m.mr == 'relationShip' then
return mr
call err 'not a relationship' key'-->'m.key',' m.mr
endProcedure tkrRel
/* copy tkr end ****************************************************/
}¢--- A540769.WK.REXX(TN) cre=2009-09-03 mod=2009-09-03-10.24.33 A540769 -------
/* copy adrTso begin *************************************************/
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet ---*/
adrTso:
parse arg ggTsoCmd, ggRet
address tso ggTsoCmd
if rc == 0 then return 0
else if ggRet == '*' then return rc
else if wordPos(rc, ggRet) > 0 then return rc
else
call err 'adrTso rc' rc 'for' ggTsoCmd
return /* end adrTso */
/*--- format dsn from tso format to jcl format -----------------------*/
dsn2jcl: procedure expose m.
parse upper arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
cx = pos('~', dsn)
if cx < 1 & addPrefix == 1 then
return sp'.'dsn
do while cx \== 0
le = left(dsn, cx-1)
ri = substr(dsn, cx+1)
if right(le, 1) == '.' | left(ri, 1) == '.' then
dsn = le || sp || ri
else
dsn = le || left('.', le \== '') || sp ,
|| left('.', ri \== '') || ri
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
parse arg dsn, mbr
bx = pos('(', dsn)
if bx > 0 then
dsn = strip(left(dsn, bx-1))
if mbr <> '' then
dsn = dsn'('strip(mbr)')'
return dsn
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn
lx = pos('(', dsn)
rx = pos(')', dsn, lx+1)
if lx < 1 then
return ''
else if lx < rx then
return substr(dsn, lx+1, rx-lx-1)
else
return strip(substr(dsn,lx+1))
endProcedure dsnGetMbr
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: readDDBegin, readDD*, readDDEnd
write: writeBegin, writeDD*, writeEnd
readDD returns true if data read, false at eof
***********************************************************************/
/*--- prepare reading from a DD --------------------------------------*/
readDDBegin: procedure expose m.
return /* end readDDBegin */
/*--- read from DD ggDD into ggSt, return false at eof ---------------*/
readDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskr' ggDD '(stem' ggSt')', 2
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- finish reading DD ggDD ----------------------------------------*/
readDDEnd: procedure expose m.
parse arg ggDD
call adrTso 'execio 0 diskr' ggDD '(finis)'
return /* end readDDEnd */
/*--- prepare writing to DD ggDD -------------------------------------*/
writeDDBegin: procedure expose m.
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 expose m.
parse arg ggDD
call adrTso 'execio 0 diskw' ggDD '(finis)'
return /* end writeDDEnd */
/*--- standardise a dsn spec
word1 dsName or -
word2 dd or -
word3 disp or -
word4 to first : attributes in tso format
after first : attributes for new allocation
----------------------------------------------------------------------*/
dsnSpec: procedure expose m.
parse upper arg spec
rr = '' /* put leading - in separate words */
do sx=1 while words(rr) < 3 & wx \= ''
wx = word(spec, sx)
do while abbrev(wx, '-') & words(rr) < 3
wx = substr(wx, 2)
rr = rr '-'
end
rr = rr wx
end
spec = rr subWord(spec, sx)
na = ''
dd = ''
di = ''
if left(spec, 1) = '&' then /* external spec is handled ok */
spec = strip(substr(spec, 2))
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, '.') | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
di = w
else if w = 'CATALOG' then
di = di'+'w
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
na = strip(substr(w, 5, length(w)-5))
else if na == '' then
na = dsn2jcl(w)
else if dd == '' then
dd = w
else if di == '' then
di = w
else
leave
end
if na == '' then na = '-'
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 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
m.dsnAlloc.dsn = na
if na == '-' & dd \== '-' & di == '-' & at = '' then
return dd
if dd == '-' & pDD \== '' then
dd = pDD
if dd == '-' then do
if symbol('m.adrTso.ddNum') = 'VAR' then
dd = m.adrTso.ddNum + 1
else
dd = 1
m.adrTso.ddNum = dd
dd = 'DD' || dd
end
if di = '-' & pDi \== '' then
di = pDi
if di = '-' then
di = 'SHR'
else if pos('(', na) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if pos('/', ds) > 0 then
return csmAlloc(na dd di rest, retRc)
else
return tsoAlloc(na dd di rest, retRc)
endProcedure dsnAlloc
tsoAlloc: procedure expose m.
parse arg na dd disp rest ':' nn, retRc
c = 'alloc dd('dd')' disp
if na \== '-' then
c = c "DSN('"na"')"
if retRc <> '' | nn == '' then do
alRc = adrTso(c rest, retRc)
if alRc <> 0 then
return alRc
return dd 'call adrTso "free dd('dd')";'
end
do retry=0 by 1
alRc = adrTso(c rest, '*')
if alRc = 0 then
return dd 'call adrTso "free dd('dd')";'
if retry > 0 | nn = '' | wordPos(disp, 'OLD SHR') < 1 ,
| sysDsn("'"m.dsnAlloc.dsn"'") \== 'DATASET NOT FOUND' then
call err 'tsoAlloc rc' alRc 'for' c rest
say 'tsoAlloc rc' alRc 'for' c rest '...trying to create'
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
end
endProcedure tsoAlloc
dsnCreateAtts: procedure expose m.
parse arg dsn, atts, forCsm
bl = 32760
if abbrev(atts, ':') then do
rl = substr(atts, 3)
if abbrev(atts, ':F') then do
if rl = '' then
rl = 80
recfm='f b'
bl = bl - (bl // rl)
end
else do
if rl = '' then
rl = bl-4
recfm = substr(atts, 2, 1) 'B'
end
end
if pos('(', dsn) > 0 then
po = 'dsntype(library) dsorg(po)'
else
po = ''
dsn = dsnSetMbr(dsn)
if forCsm == 1 then
return "dataset('"dsn"')" po,
"recfm("space(recfm, 0)") lrecl("rl") blkSize("bl")" ,
"mgmtclas(COM#A091) space(10, 1000) cylinder"
else
return "dsn('"dsn"')" po,
"recfm("recfm") lrecl("rl") block("bl")" ,
"mgmtclas(COM#A091) space(10, 1000) cyl"
endProcedure dsnCreateAtts
/*--- read the dataset specified in ggDsnSpec to stem ggSt -----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
interpret subword(ggAlloc, 2)
return
endSubroutine readDsn
/*--- write the dataset specified in ggDsnSpec from stem ggSt
write ggCnt records if not empty otherwise ggst0
if ggSay 1 then say ... records written to ... -------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'open finis)'
interpret subword(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
copyDSN: procedure expose m.
parse arg frSpec, toSpec, ggSay
frDD = dsnAlloc(frSpec, 'SHR', 'FRDD')
toDD = dsnAlloc(toSpec, 'OLD', 'TODD')
call readDDBegin word(frDD, 1)
call writeDDBegin word(toDD, 1)
cnt = 0
do while readDD(word(frDD, 1), r.)
call writeDD word(toDD, 1), r.
cnt = cnt + r.0
end
call readDDEnd word(frDD, 1)
call writeDDEnd word(toDD, 1)
interpret ';' subword(frDD, 2) '; ; ;' subword(toDD, 2)
if ggSay == 1 | m.debug == 1 then
say cnt 'records copied from' frSpec 'to' to toSpec
return
endSubroutine writeDsn
/* copy adrTso end ****************************************************/
}¢--- A540769.WK.REXX(TR) cre=2009-04-21 mod=2009-04-21-10.31.28 F540769 -------
/* rexx ***************************************************************/
parse arg fi
call errReset 'h'
say fi
if fi = '' then
fi = '~WK.Text(abc)'
say fi
call readDsn fi, i.
say 'read' fi i.0
say '7:' i.7
exit
/* 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 arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
cx = pos('~', dsn)
if cx < 1 & addPrefix == 1 then
return sp'.'dsn
do while cx ^== 0
le = left(dsn, cx-1)
ri = substr(dsn, cx+1)
if right(le, 1) == '.' | left(ri, 1) == '.' then
dsn = le || sp || ri
else
dsn = le || left('.', le ^== '') || sp ,
|| left('.', ri ^== '') || ri
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
parse arg dsn, mbr
bx = pos('(', dsn)
if bx > 0 then
dsn = strip(left(dsn, bx-1))
if mbr <> '' then
dsn = dsn'('strip(mbr)')'
return dsn
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn
lx = pos('(', dsn)
rx = pos(')', dsn, lx+1)
if lx < 1 then
return ''
else if lx < rx then
return substr(dsn, lx+1, rx-lx-1)
else
return strip(substr(dsn,lx+1))
endProcedure dsnGetMbr
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: readDDBegin, readDD*, readDDEnd
write: writeBegin, writeDD*, writeEnd
readDD returns true if data read, false at eof
***********************************************************************/
/*--- prepare reading from a DD --------------------------------------*/
readDDBegin: procedure expose m.
return /* end readDDBegin */
/*--- read from DD ggDD into ggSt, return false at eof ---------------*/
readDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskr' ggDD '(stem' ggSt')', 2
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- finish reading DD ggDD ----------------------------------------*/
readDDEnd: procedure expose m.
parse arg ggDD
call adrTso 'execio 0 diskr' ggDD '(finis)'
return /* end readDDEnd */
/*--- prepare writing to DD ggDD -------------------------------------*/
writeDDBegin: procedure expose m.
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 expose m.
parse arg ggDD
call adrTso 'execio 0 diskw' ggDD '(finis)'
return /* end writeDDEnd */
/*--- 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, disp, dd, retRc
ds = ''
m.dsnAlloc.dsn = ds
if left(spec, 1) = '-' then
return strip(substr(spec, 2))
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
disp = w
else if w = 'CATALOG' then
disp = disp w
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
ds = strip(substr(w, 5, length(w)-5))
else if ds = '' then
ds = dsn2jcl(w)
else
leave
end
rest = subword(spec, wx)
if abbrev(rest, '.') then
rest = substr(rest, 2)
parse var rest rest ':' nn
if dd <> '' & ds = '' & rest = '' & ^ abbrev(disp, 'SYSO') then
call err "'return" dd"' no longer supported please use -"dd
if dd = '' then do
if symbol('m.adrTso.ddNum') = 'VAR' then
dd = m.adrTso.ddNum + 1
else
dd = 1
m.adrTso.ddNum = dd
dd = 'DD' || dd
end
if disp = '' then
disp = 'SHR'
else if pos('(', ds) < 1 then
nop
else if disp = 'MOD' then
call err 'disp mod for' ds
else
disp = 'SHR'
m.dsnAlloc.dsn = ds
if pos('/', ds) > 0 then
return csmAlloc(dd, disp, ds, rest, nn, retRc)
else
return tsoAlloc(dd, disp, ds, rest, nn, retRc)
endProcedure dsnAlloc
tsoAlloc: procedure expose m.
parse arg dd, disp, dsn, rest, nn, retRc
c = 'alloc dd('dd')' disp
if dsn <> '' then
c = c "DSN('"dsn"')"
if retRc <> '' | nn = '' then do
alRc = adrTso(c rest, retRc)
if alRc <> 0 then
return alRc
return dd 'call adrTso "free dd('dd')";'
end
do retry=0 by 1
alRc = adrTso(c rest, '*')
if alRc = 0 then
return dd 'call adrTso "free dd('dd')";'
if retry > 0 | nn = '' | wordPos(disp, 'OLD SHR') < 1 ,
| sysDsn("'"m.dsnAlloc.dsn"'") ^== 'DATASET NOT FOUND' then
call err 'tsoAlloc rc' alRc 'for' c rest
say 'tsoAlloc rc' alRc 'for' c rest '...trying to create'
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(dsn, nn)
call adrTso 'free dd('dd')'
end
endProcedure tsoAlloc
dsnCreateAtts: procedure expose m.
parse arg dsn, atts, forCsm
bl = 32760
if abbrev(atts, ':') then do
rl = substr(atts, 3)
if abbrev(atts, ':F') then do
if rl = '' then
rl = 80
recfm='f b'
bl = bl - (bl // rl)
end
else do
if rl = '' then
rl = bl-4
recfm = substr(atts, 2, 1) 'B'
end
end
if pos('(', dsn) > 0 then
po = 'dsntype(library) dsorg(po)'
else
po = ''
dsn = dsnSetMbr(dsn)
if forCsm == 1 then
return "dataset('"dsn"')" po,
"recfm("space(recfm, 0)") lrecl("rl") blkSize("bl")" ,
"mgmtclas(s005y000) space(10, 1000) cylinder"
else
return "dsn('"dsn"')" po,
"recfm("recfm") lrecl("rl") block("bl")" ,
"mgmtclas(s005y000) space(10, 1000) cyl"
endProcedure dsnCreateAtts
/*--- read the dataset specified in ggDsnSpec to stem ggSt -----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
interpret subword(ggAlloc, 2)
return
endSubroutine readDsn
/*--- write the dataset specified in ggDsnSpec from stem ggSt
write ggCnt records if not empty otherwise ggst0
if ggSay 1 then say ... records written to ... -------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'open finis)'
interpret subword(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
copyDSN: procedure expose m.
parse arg frSpec, toSpec, ggSay
frDD = dsnAlloc(frSpec, 'SHR', 'FRDD')
toDD = dsnAlloc(toSpec, 'OLD', 'TODD')
call readDDBegin word(frDD, 1)
call writeDDBegin word(toDD, 1)
cnt = 0
do while readDD(word(frDD, 1), r.)
call writeDD word(toDD, 1), r.
cnt = cnt + r.0
end
call readDDEnd word(frDD, 1)
call writeDDEnd word(toDD, 1)
interpret ';' subword(frDD, 2) '; ; ;' subword(toDD, 2)
if ggSay == 1 | m.debug == 1 then
say cnt 'records copied from' frSpec 'to' to toSpec
return
endSubroutine writeDsn
/* copy adrTso end ****************************************************/
/* copy err begin ******************************************************
messages, errorhandling,help
***********************************************************************/
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
parse arg oo, ha
if pos('I', translate(oo)) > 0 then
call adrIsp 'control errors return'
m.err.opt = translate(oo, 'h', 'H')
if ha == '' then
drop m.err.handler
else
m.err.handler = ha
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
drop err handler opt
if ggOpt == '' & symbol('m.err.handler') == 'VAR' then
interpret m.err.handler
call errSay ggTxt
parse source . . ggS3 . /* current rexx */
if ggOpt == '' | ggOpt == '*' then
ggOpt = translate(value('m.err.opt'), 'ht', 'HT')
if pos('h', ggOpt) > 0 then do
say 'fatal error in' ggS3': divide by zero to show stackHistory'
x = 1 / 0
end
say 'fatal error in' ggS3': exit(12)'
exit errSetRc(12)
endSubroutine err
/*--- assert that the passed rexx expression evaluates to true -------*/
assert:
interpret 'assertRes =' arg(1)
if ^ assertRes then
call err 'assert failed' arg(1)':' arg(2)
return
endProcedure assert
/*--- say an errorMessage msg with pref pref
split message in lines at '/n'
say addition message in stem st ---------------------------*/
errSay: procedure expose m.
parse arg msg, st, pref
parse source . . ggS3 . /* current rexx */
if pref == 'e' | (pref == '' & st == '') then
msg = 'fatal error:' msg
else if pref == 'w' then
msgf = 'warning:' msg
else if pref == 0 then
nop
else if right(pref, 1) ^== ' ' then
msg = pref':' msg
else
msg = pref || msg
sx = 0
bx = -1
do lx=1 until bx >= length(msg)
ex = pos('\n', msg, bx+2)
if ex < 1 then
ex = length(msg)+1
if st == '' then do
say substr(msg, bx+2, ex-bx-2)
end
else do
sx = sx+1
m.st.sx = substr(msg, bx+2, ex-bx-2)
m.st.0 = sx
end
bx = ex
end
return
endProcedure errSay
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg, op
say 'fatal error:' msg
call help
call err msg, op
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
----------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if sysVar('sysISPF') = 'ACTIVE' then do
address ispExec vput 'zIspfRc' shared
end
return zIspfRc
endProcedure errSetRc
/*--- 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 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
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
say 'debug' msg
return
endProcedure debug
/*--- return current time and cpu usage ------------------------------*/
timing: procedure expose m.
return time() time('E') sysvar('syscpu') /* sysvar('syssrv') */
/--- display the first comment block of the source as help -----------*/
help: procedure expose m.
parse source . . s3 .
say right(' help for rexx' s3, 79, '*')
do 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 *****************************************************/
}¢--- A540769.WK.REXX(TRANS) cre=2009-04-21 mod=2010-12-01-12.42.11 A540769 ----
/**********************************************************************
synopsis: trans file*
translate the given files
to the characterset of the current OperatingSystem
no file or ?: this help
**** Unterschiede rexx auf z/os und ooRexx ****************************
z/os linux ooRexx
ü '66b7'x ü /*wkTst??? to do */
^ \ not
| ¨ or, concat
%% ~ tilde = object acces syntaxes on z/os
' ' x'05' tab characters
' ' x'3f' was auch immer das ist
upper statement nur in z/os
sysvar function nur in z/os
*** History ***********************************************************
24.01.09 W. Keller neu
**********************************************************************/
parse arg arg
os = errOs()
if 0 then do
call sayChar '£'
call sayChar '%'
call sayChar '|'
call sayChar '¦'
exit
end
arg = 1
if arg = '' | arg = '?' then
exit help()
do ax=1 to words(arg)
fi = word(arg, ax)
say 'translating' fi
if os = 'LINUX' then do
address 'sh' 'cp' fi fi'~'
call transLinux fi'~', fi
end
else do
lib = dsn2Jcl('wk.', 1)
call trans2zOs lib'texv(wshHome)', lib'texv(wshHotr)'
end
end
exit
sayChar: procedure
parse arg ch
say length(ch) ch c2x(ch)
return
transLinux: procedure expose m.
parse arg inp, out
inputobject = .stream%%new(inp)
outputobject = .stream%%new(out)
outputobject%%open(write replace)
signal on notready
all = ''
do y=1
line = inputObject%%linein
line = line%%translate('\|', '|^')
/* achtung £ vom Host wird als 3 Byte Sequence dargestellt,
keyBoard £ wird 2 Byte Sequenz, drum nehmen wir stattdessen % */
do forever
cx = line%%pos(x2c('efbfbd'))
if cx = 0 then
leave
nn = left(line, cx-1)'%'substr(line,cx+3)
say y 'o' line
say y 'n' nn
line = nn
end
outputObject%%lineOut(line)
end
notReady:
say 'notReady' y 'inp' inp
inputobject%%close()
outputobject%%close()
return
endProcedure transLinux
trans2zOs: procedure expose m.
parse arg in, out
call readDsn in, i.
do ix=1 to i.0
li = strip(i.ix, 't')
cx = pos('~', li)
do while cx \= 0
if pos(substr(li,if(cx>1, cx-1, cx+1), 1), '"''') < 1 then
li = left(li, cx-1)'%%'substr(li, cx+1)
cx = pos('~', li, cx+1)
end
cx = pos('05'x, li)
do while cx \= 0
li = left(li, cx-1)' 'substr(li, cx+1)
cx = pos('05'x, li, cx+1)
end
li = strip(translate(li, '| ', '¨'"3F"x), t)
if length(li) > 72 then
say 'line' ix 'too long' length(li)':' li,
'x73' c2x(substr(li, 73))
i.ix = li
end
call writeDsn out, i., , 1
return
endProcedure trans2zOs
if: procedure expose m.
parse arg cond, ifTrue, ifFalse
if cond then
return ifTrue
else
return ifFalse
/* copy adrTso begin *************************************************/
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet ---*/
adrTso:
parse arg ggTsoCmd, ggRet
address tso ggTsoCmd
if rc == 0 then return 0
else if ggRet == '*' then return rc
else if wordPos(rc, ggRet) > 0 then return rc
else
call err 'adrTso rc' rc 'for' ggTsoCmd
return /* end adrTso */
/*--- format dsn from tso format to jcl format -----------------------*/
dsn2jcl: procedure expose m.
parse upper arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
cx = pos('%%', dsn)
if cx < 1 & addPrefix == 1 then
return sp'.'dsn
do while cx ^== 0
le = left(dsn, cx-1)
ri = substr(dsn, cx+1)
if right(le, 1) == '.' | left(ri, 1) == '.' then
dsn = le || sp || ri
else
dsn = le || left('.', le ^== '') || sp ,
|| left('.', ri ^== '') || ri
cx = pos('%%', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
parse arg dsn, mbr
bx = pos('(', dsn)
if bx > 0 then
dsn = strip(left(dsn, bx-1))
if mbr <> '' then
dsn = dsn'('strip(mbr)')'
return dsn
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn
lx = pos('(', dsn)
rx = pos(')', dsn, lx+1)
if lx < 1 then
return ''
else if lx < rx then
return substr(dsn, lx+1, rx-lx-1)
else
return strip(substr(dsn,lx+1))
endProcedure dsnGetMbr
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: readDDBegin, readDD*, readDDEnd
write: writeBegin, writeDD*, writeEnd
readDD returns true if data read, false at eof
***********************************************************************/
/*--- prepare reading from a DD --------------------------------------*/
readDDBegin: procedure expose m.
return /* end readDDBegin */
/*--- read from DD ggDD into ggSt, return false at eof ---------------*/
readDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskr' ggDD '(stem' ggSt')', 2
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- finish reading DD ggDD ----------------------------------------*/
readDDEnd: procedure expose m.
parse arg ggDD
call adrTso 'execio 0 diskr' ggDD '(finis)'
return /* end readDDEnd */
/*--- prepare writing to DD ggDD -------------------------------------*/
writeDDBegin: procedure expose m.
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 expose m.
parse arg ggDD
call adrTso 'execio 0 diskw' ggDD '(finis)'
return /* end writeDDEnd */
/*--- standardise a dsn spec
word1 dsName or -
word2 dd or -
word3 disp or -
word4 to first : attributes in tso format
after first : attributes for new allocation
----------------------------------------------------------------------*/
dsnSpec: procedure expose m.
parse upper arg spec
rr = '' /* put leading - in separate words */
do sx=1 while words(rr) < 3 & wx \= ''
wx = word(spec, sx)
do while abbrev(wx, '-') & words(rr) < 3
wx = substr(wx, 2)
rr = rr '-'
end
rr = rr wx
end
spec = rr subWord(spec, sx)
na = ''
dd = ''
di = ''
if left(spec, 1) = '&' then /* external spec is handled ok */
spec = strip(substr(spec, 2))
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, '.') | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
di = w
else if w = 'CATALOG' then
di = di'+'w
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
na = strip(substr(w, 5, length(w)-5))
else if na == '' then
na = dsn2jcl(w)
else if dd == '' then
dd = w
else if di == '' then
di = w
else
leave
end
if na == '' then na = '-'
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 or a dd
spec '-'<ddName>
datasetName? disposition? '.'? attributes? (':' newAtts)?
disp default disposition
dd default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc -----*/
dsnAlloc: procedure expose m.
parse upper arg spec, pDi, pDD, retRc
parse value dsnSpec(spec) with na dd di rest
if na = '-' then
m.dsnAlloc.dsn = ''
else
m.dsnAlloc.dsn = na
if na == '-' & dd \== '-' & di == '-' & rest = '' then
return dd
if dd == '-' & pDD \== '' then
dd = pDD
if dd == '-' then do
if symbol('m.adrTso.ddNum') = 'VAR' then
dd = m.adrTso.ddNum + 1
else
dd = 1
m.adrTso.ddNum = dd
dd = 'DD' || dd
end
if di = '-' & pDi ^== '' then
di = pDi
if di = '-' then
di = 'SHR'
else if pos('(', na) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if pos('/', ds) > 0 then
return csmAlloc(na dd di rest, retRc)
else
return tsoAlloc(na dd di rest, retRc)
endProcedure dsnAlloc
tsoAlloc: procedure expose m.
parse arg na dd disp rest ':' nn, retRc
c = 'alloc dd('dd')' disp
if na ^== '-' then
c = c "DSN('"na"')"
if retRc <> '' | nn == '' then do
alRc = adrTso(c rest, retRc)
if alRc <> 0 then
return ' ' alRc
return dd 'call adrTso "free dd('dd')";'
end
do retry=0 by 1
alRc = adrTso(c rest, '*')
if alRc = 0 then
return dd 'call adrTso "free dd('dd')";'
if retry > 0 | nn = '' | wordPos(disp, 'OLD SHR') < 1 ,
| sysDsn("'"m.dsnAlloc.dsn"'") ^== 'DATASET NOT FOUND' then
call err 'tsoAlloc rc' alRc 'for' c rest
say 'tsoAlloc rc' alRc 'for' c rest '...trying to create'
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
end
endProcedure tsoAlloc
dsnCreateAtts: procedure expose m.
parse arg dsn, atts, forCsm
bl = 32760
if abbrev(atts, ':') then do
rl = substr(atts, 3)
if abbrev(atts, ':F') then do
if rl = '' then
rl = 80
recfm='f b'
bl = bl - (bl // rl)
end
else do
if rl = '' then
rl = bl-4
recfm = substr(atts, 2, 1) 'B'
end
end
if pos('(', dsn) > 0 then
po = 'dsntype(library) dsorg(po)'
else
po = ''
dsn = dsnSetMbr(dsn)
if forCsm == 1 then
return "dataset('"dsn"')" po,
"recfm("space(recfm, 0)") lrecl("rl") blkSize("bl")" ,
"mgmtclas(COM#A091) space(10, 1000) cylinder"
else
return "dsn('"dsn"')" po,
"recfm("recfm") lrecl("rl") block("bl")" ,
"mgmtclas(COM#A091) space(10, 1000) cyl"
endProcedure dsnCreateAtts
/*--- read the dataset specified in ggDsnSpec to stem ggSt -----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
interpret subword(ggAlloc, 2)
return
endSubroutine readDsn
/*--- write the dataset specified in ggDsnSpec from stem ggSt
write ggCnt records if not empty otherwise ggst0
if ggSay 1 then say ... records written to ... -------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'open finis)'
interpret subword(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
copyDSN: procedure expose m.
parse arg frSpec, toSpec, ggSay
frDD = dsnAlloc(frSpec, 'SHR', 'FRDD')
toDD = dsnAlloc(toSpec, 'OLD', 'TODD')
call readDDBegin word(frDD, 1)
call writeDDBegin word(toDD, 1)
cnt = 0
do while readDD(word(frDD, 1), r.)
call writeDD word(toDD, 1), r.
cnt = cnt + r.0
end
call readDDEnd word(frDD, 1)
call writeDDEnd word(toDD, 1)
interpret ';' subword(frDD, 2) '; ; ;' subword(toDD, 2)
if ggSay == 1 | m.debug == 1 then
say cnt 'records copied from' frSpec 'to' to toSpec
return
endSubroutine writeDsn
/* copy adrTso end ****************************************************/
/* copy err begin ******************************************************
messages, errorhandling,help
***********************************************************************/
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
parse arg oo, ha
if pos('I', translate(oo)) > 0 then
call adrIsp 'control errors return'
m.err.opt = translate(oo, 'th', 'HT')
if ha == '' then
drop m.err.handler
else
m.err.handler = ha
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
if ggOpt == '' & symbol('m.err.handler') == 'VAR' then
interpret value('m.err.handler')
call outDest
call errSay ggTxt, 'e'
if ggOpt == '' & symbol('m.err.opt') == 'VAR' then
ggOpt = value('m.err.opt')
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 then do
call errSay 'divide by zero to show stackHistory', 'e'
x = 1 / 0
end
call errSay 'exit(12)', 'e'
exit errSetRc(12)
endSubroutine err
/*--- assert that the passed rexx expression evaluates to true -------*/
assert:
interpret 'assertRes =' arg(1)
if \ assertRes then
call err 'assert failed' arg(1)':' arg(2)
return
endProcedure assert
/*--- output an errorMessage msg with pref pref
split message in lines at '/n' ---------------------------*/
errSay: procedure expose m.
parse arg msg, pref
parse source . . ggS3 . /* current rexx */
if pref == 'e' then
msg = 'fatal error in' ggS3':' msg
else if pref == 'w' then
msg = 'warning in' ggS3':' msg
else if pref \== '' then
msg = pref':' msg
return outLn(msg)
endProcedure errSay
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg, op
call errSay msg, 'e'
call help
call err msg, op
endProcedure errHelp
/*--- return the Operating System we are running on: TSO or LINUX ---*/
errOS: procedure expose m.
parse source os .
return os
endProcedure errOS
/*--- set rc for ispf: -------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared varible 3IspfRc
back as return code
----------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- output a trace message if m.tr is set -----------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
call out 'debug' msg
return
endProcedure debug
/*--- return current time and cpu usage ------------------------------*/
timing: procedure expose m.
return time() time('E') sysvar('syscpu') /* sysvar('syssrv') */
/*--- display the first comment block of the source as help -----------*/
help: procedure expose m.
parse source . . s3 .
call out right(' help for rexx' s3, 79, '*')
do lx=1 by 1
if pos('/*', sourceLine(lx)) > 0 then
leave
else if lx > 10 then do
call out '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
call out li
end
call out right(' end help for rexx' s3, 79, '*')
return 4
endProcedure help
/*--- output a message to the current destination -------------------*/
out: procedure expose m.
parse arg msg
if symbol('m.err.out') \== 'VAR' then
call outDest
interpret m.err.out
return 0
endProcedure out
/*--- output all lines (separated by '\n') of all args --------------*/
outLn: procedure expose m.
do ax=1 to max(1, arg())
msg = arg(ax)
sx = 0
bx = -1
do lx=1 until bx >= length(msg)
ex = pos('\n', msg, bx+2)
if ex < 1 then
ex = length(msg)+1
call out substr(msg, bx+2, ex-bx-2)
bx = ex
end
end
return 0
endProcedure outLn
/*--- set and return some frequent destinations for out -------------*/
outDest: procedure expose m.
parse arg ty, a
if ty == '' | symbol('m.err.out') \== 'VAR' then
m.err.out = 'say msg'
if ty == 's' then
m.err.out = 'st='quote(a)';sx=m.st.0+1;m.st.0=sx;m.st.sx=msg'
else if ty == 'i' then
m.err.out = a
else if \ abbrev('=', ty) then
call err 'bad type in outDes('ty',' a')'
return m.err.out
endProcedure outDest
/*--- 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
/* copy err end *****************************************************/
}¢--- A540769.WK.REXX(TRAN3) cre=2013-09-23 mod=2013-09-23-07.51.34 A540769 ----
/**********************************************************************
synopsis: trans file*
translate the given files
to the characterset of the current OperatingSystem
no file or ?: this help
**** Unterschiede rexx auf z/os und ooRexx ****************************
z/os linux ooRexx
^ \ not
| ¨ or, concat
$mc$ ~
upper statement nur in z/os
sysvar function nur in z/os
c ¨ | all
c x'05' ' all tabs
*** History ***********************************************************
24.01.09 W. Keller neu
**********************************************************************/
parse arg arg
fun = 'trans'
os = errOs()
if 0 then do
call sayChar '¬'
call sayChar '¢'
call sayChar '|'
call sayChar '!'
call sayChar '¨'
call sayChar '^'
call sayChar '\'
call sayChar '~'
call sayChar '£'
call sayChar '%'
call sayChar '¦'
exit
end
if arg = '' ¨ arg = '?' then
exit help()
do ax=1 to words(arg)
fi = word(arg, ax)
say 'translating' fi
if os = 'LINUX' then do
address 'sh' 'cp' fi fi'~'
if fun == 'trans' then
call transLinux fi'~', fi
else if fun == 'inline' then
call transInline fi'~', fi
else
call err 'bad fun' fun
end
else do
call err 'implement os' os
end
end
exit
sayChar: procedure
parse arg ch
say length(ch) ch c2x(ch)
return
transLinux: procedure expose m.
parse arg inp, out
inputobject = .stream~new(inp)
outputobject = .stream~new(out)
outputobject~open(write replace)
signal on notready
all = ''
do y=1
line = inputObject~linein /* version vom 19.5.13 */
line = line~translate('!\', '|^')
/* achtung £ vom Host wird als 3 Byte Sequence dargestellt,
keyBoard £ wird 2 Byte Sequenz, drum nehmen wir stattdessen % */
line = repAll(line, x2c('c2a2'), '¢')
line = repAll(line, '%%', '~')
line = repAll(line, 'sqlRow#', 'sqlRow/*??? # in zOS*/')
/* line = repAll(line, x2c('efbfbd'), '%')
line = repAll(line, '|', '!')
*/ outputObject~lineOut(line)
end
notReady:
say 'notReady' y 'inp' inp
inputobject~close()
outputobject~close()
return
endProcedure transLinux
transInline: procedure expose m.
parse arg inp, out
inputobject = .stream~new(inp)
outputobject = .stream~new(out)
outputobject~open(write replace)
signal on notready
name = '/'
do y=1
line = inputObject~linein
if abbrev(line, '/*<<') then do
name = substr(word(line, 1), 5)
outputObject~lineOut('/*')
outputObject~lineOut('$</'name'/')
end
else if name \== '/' & abbrev(line, name) then do
outputObject~lineOut('$/'name'/' subword(line, 2))
name = '/'
end
else do
outputObject~lineOut(line)
end
end
notReady:
say 'notReady' y 'inp' inp
inputobject~close()
outputobject~close()
return
endProcedure transInline
repAll:
parse arg line, fr, by
do forever
cx = line~pos(fr)
if cx = 0 then
return line
nn = left(line, cx-1) ¨¨ by ¨¨ substr(line,cx+length(fr))
say 'o' line
say 'n' nn
line = nn
end
/* copy err begin ******************************************************
messages, errorhandling,help
***********************************************************************/
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
parse arg oo, ha
if pos('I', translate(oo)) > 0 then
call adrIsp 'control errors return'
m.err.opt = translate(oo, 'th', 'HT')
if ha == '' then
drop m.err.handler
else
m.err.handler = ha
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
if ggOpt == '' & symbol('m.err.handler') == 'VAR' then
interpret value('m.err.handler')
call outDest
call errSay ggTxt, 'e'
if ggOpt == '' & symbol('m.err.opt') == 'VAR' then
ggOpt = value('m.err.opt')
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 then do
call errSay 'divide by zero to show stackHistory', 'e'
x = 1 / 0
end
call errSay 'exit(12)', 'e'
exit errSetRc(12)
endSubroutine err
/*--- assert that the passed rexx expression evaluates to true -------*/
assert:
interpret 'assertRes =' arg(1)
if \ assertRes then
call err 'assert failed' arg(1)':' arg(2)
return
endProcedure assert
/*--- output an errorMessage msg with pref pref
split message in lines at '/n' ---------------------------*/
errSay: procedure expose m.
parse arg msg, pref
parse source . . ggS3 . /* current rexx */
if pref == 'e' then
msg = 'fatal error in' ggS3':' msg
else if pref == 'w' then
msg = 'warning in' ggS3':' msg
else if pref \== '' then
msg = pref':' msg
return outLn(msg)
endProcedure errSay
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg, op
call errSay msg, 'e'
call help
call err msg, op
endProcedure errHelp
/*--- return the Operating System we are running on: TSO or LINUX ---*/
errOS: procedure expose m.
parse source os .
return os
endProcedure errOS
/*--- set rc for ispf: -------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared varible 3IspfRc
back as return code
----------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- output a trace message if m.tr is set -----------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
call out 'debug' msg
return
endProcedure debug
/*--- return current time and cpu usage ------------------------------*/
timing: procedure expose m.
return time() time('E') sysvar('syscpu') /* sysvar('syssrv') */
/*--- display the first comment block of the source as help ----------*/
help: procedure expose m.
parse source . . s3 .
call out right(' help for rexx' s3, 79, '*')
do lx=1 by 1
if pos('/*', sourceLine(lx)) > 0 then
leave
else if lx > 10 then do
call out '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
call out li
end
call out right(' end help for rexx' s3, 79, '*')
return 4
endProcedure help
/*--- output a message to the current destination -------------------*/
out: procedure expose m.
parse arg msg
if symbol('m.err.out') \== 'VAR' then
call outDest
interpret m.err.out
return 0
endProcedure out
/*--- output all lines (separated by '\n') of all args --------------*/
outLn: procedure expose m.
do ax=1 to max(1, arg())
msg = arg(ax)
sx = 0
bx = -1
do lx=1 until bx >= length(msg)
ex = pos('\n', msg, bx+2)
if ex < 1 then
ex = length(msg)+1
call out substr(msg, bx+2, ex-bx-2)
bx = ex
end
end
return 0
endProcedure outLn
/*--- set and return some frequent destinations for out -------------*/
outDest: procedure expose m.
parse arg ty, a
if ty == '' ¨ symbol('m.err.out') \== 'VAR' then
m.err.out = 'say msg'
if ty == 's' then
m.err.out = 'st='quote(a)';sx=m.st.0+1;m.st.0=sx;m.st.sx=msg'
else if ty == 'i' then
m.err.out = a
else if \ abbrev('=', ty) then
call err 'bad type in outDes('ty',' a')'
return m.err.out
endProcedure outDest
/*--- 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
/* copy err end *****************************************************/
}¢--- A540769.WK.REXX(TST) cre=2015-04-21 mod=2015-04-21-15.54.45 A540769 ------
$>. fEdit('::f222')
call sqlConnect
call sqlSel ,
'select * from sysibm.sysTables fetch first 3 rows only'
$@=¢$table
db ts
DGDB9998 A976
DA540769 A977
$!
$$ wie gehts
$$ !wie gehts
}¢--- A540769.WK.REXX(TSTALL) cre=2016-10-26 mod=2016-10-26-09.51.13 A540769 ---
/* copy tstAll begin ************************************************/
tstAll: procedure expose m.
say 'tstAll' m.myWsh m.myVers
call tstBase
call tstComp
call tstDiv
if m.err_os = 'TSO' then do
call tstZos
call tstTut0
end
call tstTimeTot
return 0
endProcedure tstAll
/*--- with also the slow tests --------------------------------------*/
tstAlLong: procedure expose m.
call tstIni
m.tst_long = 1
return tstAll()
endProcedure tstAll
/****** tstZos *******************************************************/
tstZOs:
call tstTime
call tstTime2Tst
call tstII
call sqlIni
call tstSqlRx
call tstSql
if m.tst_csmRZ \== '' then do
call tstSqlCsm
call tstSqlWsh
call tstSqlWs2
end
call scanReadIni
call tstSqlCall
call tstSqlC
call tstSqlCsv
call tstSqlRxUpd
call tstSqlUpd
call tstSqlUpdPre
call tstSqlE
call tstSqlB
call tstSqlO
call tstSqlO1
call tstSqlO2
call tstSqlStmt
call tstSqlStmts
call tstSqlUpdComLoop
call tstSqlS1
call tstSqlFTab
call tstSqlFTab2
call tstSqlFTab3
call tstSqlFTab4
call tstSqlFTab5
call tstsql4obj
call tstdb2Ut
call tstMain
call tstHookSqlRdr
call tstCsmExWsh
call tstTotal
return
endProcedure tstZOs
/*--- manualTest for csi --------------------------------------------*/
tstCsi: procedure expose m.
if 0 then do
call lmd 'A540769.*K'
call tstCsiCla 'A540769.WK.REXX'
call tstCsiCla 'A540769.AAA.DATASETS'
call tstCsiCla 'A540769.RRR.DATASETS'
end
if 1 then do
call tstCsiOpNx 'A540769.WK.*E*'
call tstCsiOpNx 'A540769.AAA.DATASETS'
call tstCsiOpNx 'A540769.RRR.DATASETS'
end
if 1 then do
call tstCsiNxCl 'A540769.WK.**'
call tstCsiNxCl 'DSN.**'
call tstCsiNxCl 'DP4G.**'
end
return
tstCsiOpNx: procedure expose m.
parse arg ds
m = 'NUE123'
s = 'res89'
flds = 'devtyp volser mgmtclas comudsiz NOBYTTRK UDATASIZ HARBA'
say 'csiOpen' ds
call csiOpen m, ds, flds
do while csiNext(m, s)
say m.s 'dev' c2x(m.s.devTyp) ,
'vol' m.s.volSer 'cla' m.s.mgmtclas,
'comuDsiz' m.s.comuDsiz 'noBytTrk' m.s.noBytTrk,
'udatasiz' c2x(m.s.udatasiz) ,
'harba' c2x(m.s.harba)
end
return
tstCsiNxCl: procedure expose m.
parse arg ds
m = 'ABC123'
s = 'efg89'
flds = 'devtyp volser mgmtclas'
say 'csiOpen' ds
call csiOpen m, ds, flds
say timing() 'begin'
do i=1 while csiNext(m, s)
nn = csiArcTape(m.s.volser, m.s.mgmtClas, m.s.devtyp, m.s)
/* oo = csiCla(strip(m.s))
if oo <> nn then
say nn '<>' oo m.s
*/ if i // 1000 = 0 then
say timing() i nn m.s
end
say timing() (i-1) nn m.s
return
endProcedure tstCsiNxCl
tstMbrList: procedure expose m.
/*
$=/tstMbrList/
### start tst tstMbrList ##########################################
#noPds: -99 mbrs in A540769.TMP.TST.MBRLIST
#1: 1 mbrs in A540769.TMP.TST.MBRLIST
1 EINS
#0: 0 mbrs in A540769.TMP.TST.MBRLIST
#4: 4 mbrs in A540769.TMP.TST.MBRLIST
1 DREI
2 FUENF
3 VIER
4 ZWEI
#*IE*: 3 mbrs in A540769.TMP.TST.MBRLIST(*IE*)
1 IE
2 NNNIE
3 VIER
#*_IE*: 2 mbrs in A540769.TMP.TST.MBRLIST(*?IE*)
1 NNNIE
2 VIER
$/tstMbrList/
*/
call tst t, 'tstMbrList'
/* call tstMbrList1 "RZ2/A540769.WK.REXX(*DA?*)" */
pds = tstFileName('MbrList', 'r')
da.1 = '2ine eins'
call tstMbrList1 pds, '#noPds'
call writeDsn pds'(eins) ::f', da., 1
call tstMbrList1 pds, '#1'
call adrTso "delete '"pds"(eins)'"
call tstMbrList1 pds, '#0'
call writeDsn pds'(zwei) ::f', da., 1
call writeDsn pds'(drei) ::f', da., 1
call writeDsn pds'(vier) ::f', da., 1
call writeDsn pds'(fuenf) ::f', da., 1
call tstMbrList1 pds, '#4'
call writeDsn pds'(ie) ::f', da., 1
call writeDsn pds'(nnnie) ::f', da., 1
call tstMbrList1 pds"(*IE*)", '#*IE*'
call tstMbrList1 pds"(*?IE*)", '#*_IE*'
call adrTso "delete '"pds"'"
call tstEnd t
return
endProcedure tstMbrList
tstMbrList1: procedure expose m.
parse arg pds, txt
call tstOut t, txt':' mbrList(tstMbrList, pds) 'mbrs in' pds
do mx=1 to m.tstMbrList.0
call tstOut t, mx m.tstMbrList.mx
end
return
endProdecure tstMbrList1
/****** tstDiv *******************************************************/
tstDiv:
call tstSort
call tstMat
call tstMatch
call tstTotal
return
endProcedure tstDiv
tstSort: procedure expose m.
call tstSortComp
call tstSortComp '<<='
call tstSortComp 'm.aLe <<= m.aRi'
call tstSortComp 'if 1 then cmp = m.aLe <<= m.aRi;else call err sd'
return
endProcedure tstSort
tstSortComp: procedure expose m.
parse arg cmp
/*
$=/tstSort/
### start tst tstSort #############################################
sort 29 c ACHT DREI DREIZEHN EINS ELF FUENF M.I.25 M.I.26 M.I.27 M+
..I.29 NEUN SECHS SIEBEN VIER VIERZEHN ZEHN ZWEI ZWOELF 0 1 1 1 2 2+
. 3 3 4 4
sort 22 c ACHT DREIZEHN ELF M.I.25 M.I.26 M.I.27 M.I.29 NEUN VIERZ+
EHN ZEHN ZWOELF 0 1 1 1 2 2 3 3 4 4
sort 15 c M.I.25 M.I.26 M.I.27 M.I.29 0 1 1 1 2 2 3 3 4 4
sort 8 c M.I.25 M.I.26 M.I.27 M.I.29 0 1 1
sort 1 M.I.29
sortWords(also als a 05 4 1e2, cmp) a als also 05 1e2 4
sortWords(also als a 05 4, cmp) a als also 05 4
sortWords(also als a 05, cmp) a als also 05
sortWords(also als a, cmp) a als also
sortWords(also als, cmp) als also
sortWords(also, cmp) also
sortWords(, cmp) .
sortWords(also als a 05 4 1e2, <) a als also 4 05 1e2
sortWords(also als a 05 4 1e2, >) 1e2 05 4 also als a
$/tstSort/ */
/*
$=/tstSortAscii/
### start tst tstSortAscii ########################################
sort 29 0 1 1 1 2 2 3 3 4 4 ACHT DREI DREIZEHN EINS ELF FUENF M.I.+
25 M.I.26 M.I.27 M.I.29 NEUN SECHS SIEBEN VIER VIERZEHN ZEHN ZWEI Z+
WOELF c
sort 22 0 1 1 1 2 2 3 3 4 4 ACHT DREIZEHN ELF M.I.25 M.I.26 M.I.27+
. M.I.29 NEUN VIERZEHN ZEHN ZWOELF c
sort 15 0 1 1 1 2 2 3 3 4 4 M.I.25 M.I.26 M.I.27 M.I.29 c
sort 8 0 1 1 M.I.25 M.I.26 M.I.27 M.I.29 c
sort 1 M.I.29
$/tstSortAscii/ */
say '### start with comparator' cmp '###'
if m.err_os == 'LINUX' then
call tst t, "tstSortAscii"
else
call tst t, "tstSort"
call mAdd mCut(i, 0), eins, zwei, drei, vier, fuenf, sechs,
,sieben, acht, neun, zehn, elf, zwoelf, dreizehn, vierzehn
call mAdd i, 1, 2, 3, 4, 4, 3, 2, 1, 0, 1,
, 'M.I.25', 'M.I.26', 'M.I.27', 'c', 'M.I.29'
do yy = m.i.0 by -1 to 1
do x = 0 to yy
m.i.0 = x
call sort i, o, cmp
m = ''
la = ''
if x <> m.o.0 then
call err 'size mismatch' x '<>' m.o.0
do y=1 to m.o.0
m = m m.o.y
if \ (la << m.o.y) then
call err 'sort mismatch' yy x y '\' la '<<' m.o.y
end
end
if yy // 7 = 1 then
call tstOut t, 'sort' yy m
do x = 2 to yy
x1 = x-1
m.i.x1 = m.i.x
end
end
wi = 'also als a 05 4 1e2'
do l=words(wi) by -1 to 0
call tstOut t, 'sortWords('subWord(wi, 1, l)', cmp)' ,
sortWords(subWord(wi, 1, l), cmp)
end
call tstOut t, 'sortWords('wi', <)' sortWords(wi, '<')
call tstOut t, 'sortWords('wi', >)' sortWords(wi, '>')
call tstEnd t
return
endProcedure tstSort
tstMatch: procedure expose m.
/*
$=/tstMatch/
### start tst tstMatch ############################################
match(eins, e?n*) 1 1 2,i,s trans(E?N*) EiNs
match(eins, eins) 1 1 0 trans(EINS) EINS
match(e1nss, e?n*) 1 1 2,1,ss trans(?*) 1ss
match(eiinss, e?n*) 0 0 -9 trans(E?N*) .
match(einss, e?n *) 0 0 -9 trans(E?N *) .
match(ein s, e?n *) 1 1 2,i,s trans(E?N *) EiN s
match(ein abss , ?i*b*) 1 1 3,e,n a,ss trans(?I*B*) eIn aBss .
match(ein abss wie gehtsssxdirx und auch , ) 0 0 -9 trans() .
match(ies000, *000) 1 1 1,ies trans(*000) ies000
match(xx0x0000, *000) 1 1 1,xx0x0 trans(*000) xx0x0000
match(000x00000xx, 000*) 1 1 1,x00000xx trans(000*) 000x00000xx
match(000xx, *0*) 1 1 2,00,xx trans(ab*cd*ef) ab00cdxxef
match(abcdef, *abcdef*) 1 1 2,, trans(*ABCDEF*) ABCDEF
match(abcdef, **abcdef***) 1 1 5,,,,, trans(**ABCDEF***) ABCDEF
match(abcdef, *cd*) 1 1 2,ab,ef trans(*CD*) abCDef
match(abcdef, *abc*def*) 1 1 3,,, trans(*ABC*DEF*) ABCDEF
match(abcdef, *bc*e*) 1 1 3,a,d,f trans(*BC*E*) aBCdEf
match(abcdef, **bc**ef**) 1 1 6,a,,d,,, trans(**BC**EF**) aBCdEF
$/tstMatch/
*/
call tst t, "tstMatch"
call tstOut t, tstMatch1('eins', 'e?n*' )
call tstOut t, tstMatch1('eins', 'eins' )
call tstOut t, tstMatch1('e1nss', 'e?n*', '?*' )
call tstOut t, tstMatch1('eiinss', 'e?n*' )
call tstOut t, tstMatch1('einss', 'e?n *' )
call tstOut t, tstMatch1('ein s', 'e?n *' )
call tstOut t, tstMatch1('ein abss ', '?i*b*' )
call tstOut t, tstMatch1('ein abss wie gehtsssxdirx und auch ' )
call tstOut t, tstMatch1('ies000', '*000' )
call tstOut t, tstMatch1('xx0x0000', '*000' )
call tstOut t, tstMatch1('000x00000xx', '000*' )
call tstOut t, tstMatch1('000xx', '*0*', 'ab*cd*ef' )
call tstOut t, tstMatch1('abcdef', '*abcdef*' )
call tstOut t, tstMatch1('abcdef', '**abcdef***' )
call tstOut t, tstMatch1('abcdef', '*cd*' )
call tstOut t, tstMatch1('abcdef', '*abc*def*' )
call tstOut t, tstMatch1('abcdef', '*bc*e*' )
call tstOut t, tstMatch1('abcdef', '**bc**ef**' )
call tstEnd t
return
tstMatch1:
parse arg w, m, m2
r = 'match('w',' m')' match(w, m) matchVars(w, m, vv) m.vv.0
do x=1 to m.vv.0
r = r','m.vv.x
end
if m2 = '' then
m2 = translate(m)
r = r 'trans('m2')' matchRep(w, m, m2)
return r
endProcedure tstMatch1
tstIntRdr: procedure expose m.
i.1 = "//A540769J JOB (CP00,KE50),'DB2 REO',"
i.2 = "// MSGCLASS=T,TIME=1440,"
i.3 = "// NOTIFY=&SYSUID,REGION=0M,SCHENV=DB2"
i.4 = "//*MAIN CLASS=LOG"
i.5 = "//S1 EXEC PGM=IEFBR14"
call writeDsn 'RR2/intRdr', i., 5, 1
return
endProcedure tstIntRdr
tstII: procedure expose m.
/*
$=/tstII/
### start tst tstII ###############################################
iiDs(org) ORG.U0009.B0106.MLEM43
iiDs(db2) DSN.DB2
iiRz2C(RZ2) 2
*** err: no key=R?Y in II_RZ2C
iiRz2C(R?Y) 0
iiRz2C(RZY) Y
iiDbSys2C(de0G) E
*** err: no key=D??? in II_DB2C
iiDbSys2C(d???) 0
iiDbSys2C(DBOF) F
iiSys2RZ(S27) RZ2
iiMbr2DbSys(DBP5) DVBP
ii_rz RZX RZY RZZ RQ2 RR2 RZ2 RZ4
ii_rz2db.rzx DE0G DEVG DX0G DPXG
rr2/dvbp RR2 R p=R d=RZ2, db DVBP P 1
iiixPut 1: RZ2 2 p=B d=RZ2, db DBOF F 0
iiixPut 1: RZ2 2 p=B d=RZ2, db DVBP P 1
iiixPut 1: RZ2 2 p=B d=RZ2, db DP2G Q 0
*** err: no key=M6R in II_MBR2DB
errHan======= mbr2DbSys(m6r?) 0
errHandlerPush Mbr2DbSys(m7r?) ?no?dbSys?
*** err: no key=M8R in II_MBR2DB
errHandlerPop Mbr2DbSys(m8r?) 0
$/tstII/
*/
call tst t, 'tstII'
call tstOut t, 'iiDs(org) ' iiDs('oRg')
call tstOut t, 'iiDs(db2) ' iiDs(db2)
call tstOut t, 'iiRz2C(RZ2) ' iiRz2C(RZ2)
call tstOut t, 'iiRz2C(R?Y) ' iiRz2C(R?Y)
call tstOut t, 'iiRz2C(RZY) ' iiRz2C(RZY)
call tstOut t, 'iiDbSys2C(de0G) ' iiDbSys2C('de0G')
call tstOut t, 'iiDbSys2C(d???) ' iiDbSys2C('d???')
call tstOut t, 'iiDbSys2C(DBOF) ' iiDbSys2C('DBOF')
call tstOut t, 'iiSys2RZ(S27) ' iiSys2RZ(S27)
call tstOut t, 'iiMbr2DbSys(DBP5)' iiMbr2DbSys(DBP5)
call tstOut t, 'ii_rz ' m.ii_rz
call tstOut t, 'ii_rz2db.rzx ' m.ii_rz2db.rzx
call pipeIni
call iiPut 'rr2/ DvBp '
call tstOut t, 'rr2/dvbp ' ,
vGet('rz') vget('rzC') 'p='vget('rzP') 'd='vget('rzD'),
|| ', db' vGet('dbSys') vGet('dbSysC') vGet('dbSysElar')
w1 = wordPos('RZ2/DBOF', m.ii_rzDb)
do wx=w1 to w1+2
call tstOut t, 'iiixPut' iiIxPut(wx)':' ,
vGet('rz') vget('rzC') 'p='vget('rzP') 'd='vget('rzD'),
|| ', db' vGet('dbSys') vGet('dbSysC') vGet('dbSysElar')
end
call tstOut t, "errHan======= mbr2DbSys(m6r?)" iiMbr2DbSys('m6r?')
call errHandlerPushRet "?no?dbSys?"
call tstOut t, "errHandlerPush Mbr2DbSys(m7r?)" iiMbr2DbSys('m7r?')
call errHandlerPop
call tstOut t, "errHandlerPop Mbr2DbSys(m8r?)" iiMbr2DbSys('m8r?')
call tstEnd t
return
endProcedure tstII
tstTime2tst: procedure expose m.
/*
$=/tstTime2tst/
### start tst tstTime2tst #########################################
2015-05-13-23.45.57.987654 ==> 735730.99025448673611 ==> 2015-05-13+
-23.45.57.987654 1
1956-04-01-23.59.59.999999 ==> 714139.99999999998843 ==> 1956-04-01+
-23.59.59.999999 1
2016-02-29-12.34.56.789087 ==> 736022.52426839221065 ==> 2016-02-29+
-12.34.56.789087 1
1567-08-23-19.59.59.999999 ==> 572203.83333333332176 ==> 1567-08-23+
-19.59.59.999999 1
$/tstTime2tst/
*/
call tst t, 'tstTime2tst'
l = '2015-05-13-23.45.57.987654 1956-04-01-23.59.59.999999' ,
'2016-02-29-12.34.56.789087 1567-08-23-19.59.59.999999'
do lx=1 to 4
v = word(l, lx)
w = timeDays2tst(timestamp2days(v))
call tstOut t, v '==>' timestamp2days(v) '==>' w (v = w)
end
call tstEnd t
return
endProcedure tstTime2tst
tstTime: procedure
/* Winterzeit dez 2011
$=/tstTime/
### start tst tstTime #############################################
05-28-00.00 2days 735745
05-28-04.00 2days 735745.16666666666667
05-28-21.00 2days 735745.9
05-29-00.00 2days 735746
16-05-28-00 2days 736111
16...12 - 15...06 366.25000000000000
2016-05-28-12.23.45 .
2016-05-28-12-23.45 bad timestamp 2016-05-28-12-23
2016.05-28-12.23.45 bad timestamp 2016.05-28-12.23
2016-05-28-12.23.45.987654 .
2016-0b-28-12.23.45 bad timestamp 2016-0b-28-12.23
2016-05-28-12.23.45.9876543 bad timestamp 2016-05-28-12.23
2016-05-28-12.23.45.98-654 bad timestamp 2016-05-28-12.23
2016-00-28-12.23.45 bad month in timestamp 2016-00
2016-05-28-13.23.45 .
2016-15-28-12.23.45 bad month in timestamp 2016-15
2016-05-31-12.23.45 .
2016-04-31-13.23.45 bad day in timestamp 2016-04-3
2015-04-30-12.23.45 .
2016-02-30-12.23.45 bad day in timestamp 2016-02-3
2016-02-29-13.23.45 .
2015-02-29-12.23.45 bad day in timestamp 2015-02-2
2016-07-30-25.00.00 bad hour in timestamp 2016-07-
2016-04-07-24.00.00.0 .
2015-02-19-24.00.01 bad hour in timestamp 2015-02-
Achtung: output haengt von Winter/SommerZ & LeapSecs ab
stckUnit = 0.000000000244140625
timeLeap = 00000018CBA80000 = 106496000000 = 26.000 secs
timeZone = 00001AD274800000 = 29491200000000 = 7200.000 secs
timeUQZero = 207090001374976
timeUQDigis = 35 digits ABCDEFGHIJKLMNOPQRSTUVWXYZ012345678
2jul(2011-03-31-14.35.01.234567) 11090
Lrsn2TAI10(00C5E963363741000000) 2010-05-01-10.35.20.789008
Lrsn2Lzt(00C5E963363741000000) 2010-05-01-12.34.54.789008
TAI102Lrsn(2011-03-31-14.35.01.234567) 00C78D87B86E38700000
lzt2Lrsn(2011-03-31-14.35.01.234567) 00C78D6CFEC560700000
Lrsn2TAI10(TAI102Lrsn(2011-03-31-14.35.01.234567) +
2011-03-31-14.35.01.234567
TAI102Lrsn(Lrsn2TAI10(00C5E963363741000000) 00C5E963363741000000
Lrsn2LZt(LZt2Lrsn(2011-03-31-14.35.01.234567) 2011-03-31-14.35.01.2+
34567
LZt2Stc(Lrsn2LZt(00C5E963363741000000) 00C5E963363741000000
Lrsn2uniq(00C5E963363741000000) CTNR6S7T back 00C5E963363740000000
Lrsn2LZt(LZt2Lrsn(2051-10-31-14.35.01.234567) 2051-10-31-14.35.01+
..234567
Lrsn2TAI10(01010000000000000000) 2043-04-09-14.36.53.414912
$/tstTime/
Winterzeit
timeZone = 00000D693A400000 = 14745600000000 = 3600.000 secs
Lrsn2Lzt(00C5E963363741000000) 2010-05-01-11.34.54.789008
lzt2Lrsn(2011-03-31-14.35.01.234567) 00C78D7A67FFA0700000
Sommerzeit
timeZone = 00001AD274800000 = 29491200000000 = 7200.000 secs
Lrsn2Lzt(00C5E963363741000000) 2010-05-01-12.34.54.789008
lzt2Lrsn(2011-03-31-14.35.01.234567) 00C78D6CFEC560700000
*/
call jIni
call timeIni
call tst t, 'tstTime'
call out '05-28-00.00 2days ' timestamp2days('2015-05-28-00.00.00')
call out '05-28-04.00 2days ' timestamp2days('2015-05-28-04.00.00')
call out '05-28-21.00 2days ' timestamp2days('2015-05-28-21.36.00')
call out '05-29-00.00 2days ' timestamp2days('2015-05-29-00.00.00')
call out '16-05-28-00 2days ' timestamp2days('2016-05-28-00.00.00')
call out '16...12 - 15...06 ' timestampDiff( '2016-05-28-12.23.45',
, '2015-05-28-06.23.45')
l = '2016-05-28-12.23.45 2016-05-28-12-23.45 2016.05-28-12.23.45',
'2016-05-28-12.23.45.987654 2016-0b-28-12.23.45' ,
'2016-05-28-12.23.45.9876543 2016-05-28-12.23.45.98-654' ,
'2016-00-28-12.23.45 2016-05-28-13.23.45 2016-15-28-12.23.45',
'2016-05-31-12.23.45 2016-04-31-13.23.45 2015-04-30-12.23.45',
'2016-02-30-12.23.45 2016-02-29-13.23.45 2015-02-29-12.23.45',
'2016-07-30-25.00.00 2016-04-07-24.00.00.0 2015-02-19-24.00.01'
do lx=1 to words(l)
call out left(word(l, lx), 30),
strip(left(timestampCheck(word(l, lx)), 30), 't')
end
t1 = '2011-03-31-14.35.01.234567'
t2 = '2051-10-31-14.35.01.234567'
s1 = timeLrsnExp('C5E963363741')
s2 = timeLrsnExp('0101')
call out 'Achtung: output haengt von Winter/SommerZ & LeapSecs ab'
numeric digits 15
call out 'stckUnit =' m.time_StckUnit
call out 'timeLeap =' d2x(m.time_Leap,16) '=' m.time_Leap ,
'=' format(m.time_Leap * m.time_StckUnit,9,3) 'secs'
call out 'timeZone =' d2x(m.time_Zone,16) '=' m.time_Zone,
'=' format(m.time_Zone * m.time_StckUnit,6,3) 'secs'
/* call out "cvtext2_adr =" d2x(cvtExt2A, 8) */
call out 'timeUQZero =' m.time_UQZero
call out 'timeUQDigis =' ,
length(m.time_UQDigits) 'digits' m.time_UQDigits
call out '2jul('t1') ' time2jul(t1)
call out 'Lrsn2TAI10('s1')' timelrsn2TAI10(s1)
call out 'Lrsn2Lzt('s1')' timeLrsn2Lzt(s1)
call out 'TAI102Lrsn('t1')' timeTAI102Lrsn(t1)
call out 'lzt2Lrsn('t1')' timeLzt2Lrsn(t1)
call out 'Lrsn2TAI10(TAI102Lrsn('t1')' ,
timeLrsn2TAI10(timeTAI102Lrsn(t1))
call out 'TAI102Lrsn(Lrsn2TAI10('s1')' ,
timeTAI102Lrsn(timelrsn2TAI10(s1))
call out 'Lrsn2LZt(LZt2Lrsn('t1')' timeLrsn2LZt(timeLZt2Lrsn(t1))
call out 'LZt2Stc(Lrsn2LZt('s1')' timeLZt2Lrsn(timeLrsn2LZt(s1))
call out 'Lrsn2uniq('s1')' timeLrsn2Uniq(s1) ,
'back' timeUniq2Lrsn(timeLrsn2Uniq(s1))
call out 'Lrsn2LZt(LZt2Lrsn('t2')' timeLrsn2LZt(timeLZt2Lrsn(t2))
call out 'Lrsn2TAI10('s2')' timelrsn2TAI10(s2)
call tstEnd t
return
endProcedure tstTime
tstMat: procedure expose m.
/*
$=/tstMat/
### start tst tstMat ##############################################
. 0 sqrt 0 isPrime 0 nxPrime 3 permut 1 > 1 2 3 4 5
. 1 sqrt 1 isPrime 0 nxPrime 3 permut 2 > 2 1 3 4 5
. 2 sqrt 1 isPrime 1 nxPrime 3 permut 3 > 1 3 2 4 5
. 3 sqrt 1 isPrime 1 nxPrime 3 permut 3 > 2 3 1 4 5
. 4 sqrt 2 isPrime 0 nxPrime 5 permut 3 > 3 2 1 4 5
. 5 sqrt 2 isPrime 1 nxPrime 5 permut 3 > 3 1 2 4 5
. 6 sqrt 2 isPrime 0 nxPrime 7 permut 4 > 1 2 4 3 5
. 7 sqrt 2 isPrime 1 nxPrime 7 permut 4 > 2 1 4 3 5
. 8 sqrt 2 isPrime 0 nxPrime 11 permut 4 > 1 3 4 2 5
. 9 sqrt 3 isPrime 0 nxPrime 11 permut 4 > 2 3 4 1 5
. 10 sqrt 3 isPrime 0 nxPrime 11 permut 4 > 3 2 4 1 5
. 11 sqrt 3 isPrime 1 nxPrime 11 permut 4 > 3 1 4 2 5
. 12 sqrt 3 isPrime 0 nxPrime 13 permut 4 > 1 4 3 2 5
. 13 sqrt 3 isPrime 1 nxPrime 13 permut 4 > 2 4 3 1 5
. 14 sqrt 3 isPrime 0 nxPrime 17 permut 4 > 1 4 2 3 5
. 15 sqrt 3 isPrime 0 nxPrime 17 permut 4 > 2 4 1 3 5
. 16 sqrt 4 isPrime 0 nxPrime 17 permut 4 > 3 4 1 2 5
. 17 sqrt 4 isPrime 1 nxPrime 17 permut 4 > 3 4 2 1 5
. 18 sqrt 4 isPrime 0 nxPrime 19 permut 4 > 4 2 3 1 5
$/tstMat/
$/tstMat/
*/
call tst t, 'tstMat'
q = 'tst_Mat'
do qx=1 to 20
m.q.qx = qx
end
do i=0 to 18
call permut q, i
call tstOut t, right(i,4) 'sqrt' right(sqrt(i), 2) ,
'isPrime' isPrime(i) 'nxPrime' right(nxPrime(i), 4) ,
'permut' m.q.0 '>' m.q.1 m.q.2 m.q.3 m.q.4 m.q.5
end
call tstEnd t
return
endProcedure tstMat
tstCsmExWsh: procedure expose m.
/*
new lines: 24
$=/tstCsmExWsh/
### start tst tstCsmExWsh #########################################
--- sending v
line eins aus <toRZ>
csm_o1=¢fEins=o1Feins =o1Val fZwei=o1 fZwei!
csm_o2=¢fEins=o2Feins =o2Value fZwei=o2,fwei, und !
line vier end
--- sending e
line eins aus <toRZ>
tstR: @tstWriteoV2 isA :TstCsmExWsh*3
tstR: .fEins = o1Feins
tstR: = o1Val
tstR: .fZwei = o1 fZwei
tstR: @tstWriteoV4 isA :TstCsmExWsh*3
tstR: .fEins = o2Feins
tstR: = o2Value
tstR: .fZwei = o2,fwei, und .
line vier end
--- sending f50
line eins aus <toRZ> .
csm_o1=¢fEins=o1Feins =o1Val fZwei=o1 fZwei! .
csm_o2=¢fEins=o2Feins =o2Value fZwei=o2,fwei, ...!
line vier end .
$/tstCsmExWsh/
*/
call csmIni
call pipeIni
call tst t, "tstCsmExWsh"
call mAdd t.trans, m.tst_csmRz '<toRZ>'
bi = jBuf("$$- 'line eins aus' sysvar(sysnode)" ,
, "cc = classNew('n? TstCsmExWsh u f fEins v, v, f fZwei v')" ,
, "$$. csv2o('csm_o1',cc, 'o1Feins,o1Val,o1 fZwei')" ,
, "$$. csv2o('csm_o2',cc, 'o2Feins,o2Value,""o2,fwei, und ""')" ,
, "$$ line vier end")
call out '--- sending v'
call csmExWsh m.tst_csmRz, bi, 'v'
ww = oNew(m.class_csmExWsh, m.tst_csmRz, bi, 'e')
call out '--- sending e'
call jWriteAll t, ww
call out '--- sending f50'
call csmExWsh m.tst_csmRz, bi, 'f50'
call tstEnd t
return
endProcedure tstCsmExWsh
/****** tstSql *******************************************************/
tstSqlRx: procedure expose m.
/*
$=/tstSqlRx/
### start tst tstSqlRx ############################################
*** err: SQLCODE = -204: A540769.SYSDUMMY IS AN UNDEFINED NAME
. e 1: sql = select * from sysdummy
. e 2: stmt = prepare s7 into :M.SQL.7.D from :src
. e 3: with into :M.SQL.7.D = M.SQL.7.D
fetchA 1 ab=m.abcdef.123.AB=abc ef=efg
fetchA 0 ab=m.abcdef.123.AB=abc ef=efg
fetchB 1 ab=a cd=2 ef=--- ind=-1 gh=d ind=0
fetchB 0 ab=a cd=2 ef=--- ind=-1 gh=d ind=0
fetchC 1 a=a b=2 c=--- d=d
fetchC 0 a=a b=2 c=--- d=d
fetchBT 1 SYSTABLES
fetchBT 0 SYSTABLES
fetchBi 1 SYSINDEXES
fetchBi 0 SYSINDEXES
$/tstSqlRx/ */
call jIni
call tst t, "tstSqlRx"
call sqlConnect , 'e'
cx = 7
call sqlQuery cx, 'select * from sysdummy'
call sqlQuery cx, "select 'abc' , 'efg'",
'from sysibm.sysDummy1',':m.dst.ab, :m.dst.ef'
a = 'abcdef'
b = 123
drop m.a.b.ab m.a.b.ef
do i=1 to 2
call out 'fetchA' sqlFetch(cx, a || '.' || b) ,
'ab=m.'a'.'||b'.'ab'='m.a.b.ab 'ef='m.a.b.ef
end
call sqlClose cx
drop m.a.b.ab m.a.ab.ef a b c
sql = "select 'a' a, 2 b, case when 1=0 then 1 else null end c",
", case when 1=1 then 'd' else null end d",
"from sysibm.sysDummy1"
call sqlQuery cx, sql, 'AB CD EF GH'
st = 'abc.Def.123'
drop m.st.ab m.st.cd m.st.ef m.st.ef.sqlInd m.st.gh m.st.gh.sqlInd
do i=1 to 2
call out 'fetchB' sqlFetch(cx, st) ,
'ab='m.st.ab 'cd='m.st.cd 'ef='m.st.ef 'ind='m.st.ef.sqlInd,
'gh='m.st.gh 'ind='m.st.gh.sqlInd
end
call sqlClose cx
drop m.st.ab m.st.bc m.st.df m.st.df.sqlInd
call sqlQuery cx, sql
st = 'abc.Def.123'
drop m.st.a m.st.b m.st.c m.st.d
do i=1 to 2
call out 'fetchC' sqlFetch(cx, st) ,
'a='m.st.a 'b='m.st.b 'c='m.st.c 'd='m.st.d
end
drop m.st.a m.st.b m.st.c m.st.d
call sqlClose cx
drop m.st.1.a m.st.1.b m.st.1.c m.st.1.d m.st.0
call sqlQueryPrepare cx, "select name" ,
"from sysibm.sysTables" ,
"where creator = 'SYSIBM' and name = ?",':m.nm'
call sqlQueryExecute cx, 'SYSTABLES'
call out 'fetchBT' sqlFetch(cx) m.nm
call out 'fetchBT' sqlFetch(cx) m.nm
call sqlClose cx
call sqlQueryExecute cx, 'SYSINDEXES'
call out 'fetchBi' sqlFetch(cx) m.nm
call out 'fetchBi' sqlFetch(cx) m.nm
call tstEnd t
call sqlDisconnect
return
endProcedure tstSqlRx
tstSql: procedure expose m.
/*
$=/tstSql/
### start tst tstSql ##############################################
*** err: SQLCODE = -204: A540769.SYSDUMMY IS AN UNDEFINED NAME
. e 1: sql = select * from sysdummy
. e 2: stmt = prepare s7 into :M.SQL.7.D from :src
. e 3: with into :M.SQL.7.D = M.SQL.7.D
fetchA 1 ab=m.abcdef.123.AB=abc ef=efg
fetchA 0 ab=m.abcdef.123.AB=abc ef=efg
fetchB 1 ab=a cd=2 ef=--- ind=-1 gh=d ind=0
fetchB 0 ab=a cd=2 ef=--- ind=-1 gh=d ind=0
fetchC 1 a=a b=2 c=--- d=d
fetchC 0 a=a b=2 c=--- d=d
sql2St 1 st.0=1
sql2St:1 a=a b=2 c=--- d=d
sql2One a
sql2One a=a b=2 c=--- d=d
fetchBT 1 SYSTABLES
fetchBT 0 SYSTABLES
fetchBi 1 SYSINDEXES
fetchBi 0 SYSINDEXES
$/tstSql/ */
call jIni
call tst t, "tstSql"
call sqlConnect , 'e'
cx = 7
call sqlQuery cx, 'select * from sysdummy'
call sqlQuery cx, "select 'abc' , 'efg'",
'from sysibm.sysDummy1', ':m.dst.ab, :m.dst.ef'
a = 'abcdef'
b = 123
drop m.a.b.ab m.a.b.ef
do i=1 to 2
call out 'fetchA' sqlFetch(cx, a || '.' || b) ,
'ab=m.'a'.'||b'.'ab'='m.a.b.ab 'ef='m.a.b.ef
end
call sqlClose cx
drop m.a.b.ab m.a.ab.ef a b c
sql = "select 'a' a, 2 b, case when 1=0 then 1 else null end c",
", case when 1=1 then 'd' else null end d",
"from sysibm.sysDummy1"
call sqlQuery cx, sql, 'AB CD EF GH'
st = 'abc.Def.123'
drop m.st.ab m.st.cd m.st.ef m.st.ef.sqlInd m.st.gh m.st.gh.sqlInd
do i=1 to 2
call out 'fetchB' sqlFetch(cx, st) ,
'ab='m.st.ab 'cd='m.st.cd 'ef='m.st.ef 'ind='m.st.ef.sqlInd,
'gh='m.st.gh 'ind='m.st.gh.sqlInd
end
call sqlClose cx
drop m.st.ab m.st.bc m.st.df m.st.df.sqlInd
call sqlQuery cx, sql
st = 'abc.Def.123'
drop m.st.a m.st.b m.st.c m.st.d
do i=1 to 2
call out 'fetchC' sqlFetch(cx, st) ,
'a='m.st.a 'b='m.st.b 'c='m.st.c 'd='m.st.d
end
drop m.st.a m.st.b m.st.c m.st.d
call sqlClose cx
drop m.st.1.a m.st.1.b m.st.1.c m.st.1.d m.st.0
call out 'sql2St' sql2St(sql, st) 'st.0='m.st.0
do i=1 to m.st.0
call out 'sql2St:'i ,
'a='m.st.i.a 'b='m.st.i.b 'c='m.st.i.c 'd='m.st.i.d
end
drop m.st.1.a m.st.1.b m.st.1.c m.st.1.d m.st.0
drop m.st.a m.st.b m.st.c m.st.d m.st.0
call out 'sql2One' sql2One(sql, st)
call out 'sql2One' ,
'a='m.st.a 'b='m.st.b 'c='m.st.c 'd='m.st.d
drop m.st.a m.st.b m.st.c m.st.d m.st.0
call sqlQueryPrepare cx, "select name" ,
"from sysibm.sysTables" ,
"where creator = 'SYSIBM' and name = ?",':m.nm'
call sqlQueryExecute cx, 'SYSTABLES'
call out 'fetchBT' sqlFetch(cx) m.nm
call out 'fetchBT' sqlFetch(cx) m.nm
call sqlClose cx
call sqlQueryExecute cx, 'SYSINDEXES'
call out 'fetchBi' sqlFetch(cx) m.nm
call out 'fetchBi' sqlFetch(cx) m.nm
call tstEnd t
call sqlDisconnect
return
endProcedure tstSql
tstSqlCall: procedure expose m.
/*
$=/tstSqlCall/
### start tst tstSqlCall ##########################################
set sqlid 0
drop proc -204
crea proc 0
call -2 0
resultSets 1 vars=3 2=-1 3=call-2 -2
* resultSet 1 CUR NAME COLTYPE A2
cur=cur2 name=NAME type=VARCHAR len= a1= a2=call-2 a3=
cur=cur2 name=CREATOR type=VARCHAR len= a1= a2=call-2 a3=
cur=cur2 name=TYPE type=CHAR len= a1= a2=call-2 a3=
call -1 0
resultSets 1 vars=3 2=0 3=call-1 -1
* resultSet 1 CUR NAME COLTYPE LENGTH A1
cur=cur1 name=NAME type=VARCHAR len=128 a1=call-1 a2= a3=
call 0 0
resultSets 0 vars=3 2=1 3=call0 0
call 1 0
resultSets 1 vars=3 2=2 3=call1 1
* resultSet 1 CUR NAME COLTYPE LENGTH A1
cur=cur1 name=NAME type=VARCHAR len=128 a1=call1 a2= a3=
call 2 0
resultSets 2 vars=3 2=3 3=call2 2
* resultSet 1 CUR NAME COLTYPE LENGTH A1
cur=cur1 name=NAME type=VARCHAR len=128 a1=call2 a2= a3=
* resultSet 2 CUR NAME COLTYPE A2
cur=cur2 name=NAME type=VARCHAR len= a1= a2=call2 a3=
cur=cur2 name=CREATOR type=VARCHAR len= a1= a2=call2 a3=
cur=cur2 name=TYPE type=CHAR len= a1= a2=call2 a3=
call 3 0
resultSets 3 vars=3 2=4 3=call3 3
* resultSet 1 CUR NAME COLTYPE LENGTH A1
cur=cur1 name=NAME type=VARCHAR len=128 a1=call3 a2= a3=
* resultSet 2 CUR NAME COLTYPE A2
cur=cur2 name=NAME type=VARCHAR len= a1= a2=call3 a3=
cur=cur2 name=CREATOR type=VARCHAR len= a1= a2=call3 a3=
cur=cur2 name=TYPE type=CHAR len= a1= a2=call3 a3=
* resultSet 3 CUR NAME A3
rollback 0
$/tstSqlCall/ */
call tst t, "tstSqlCall"
prc = 'qz91WshTst1.proc1'
c1 = "from sysibm.sysColumns" ,
"where tbCreator = 'SYSIBM' and tbName = 'SYSTABLES'" ,
"order by colNo" ,
"fetch first"
call sqlConnect , 'e'
call tstOut t, 'set sqlid' ,
sqlUpdate(3, "set current sqlid = 'S100447'")
call tstOut t, 'drop proc' sqlUpdate(3, 'drop procedure' prc)
call sqlCommit
call tstOut t, 'crea proc' sqlUpdate(3, 'create procedure' prc ,
"(in a1 varchar(20), inOut cnt int, out res varchar(20))" ,
"version v1 not deterministic reads sql data" ,
"dynamic result sets 3" ,
"begin" ,
"declare prC1 cursor with return for" ,
"select 'cur1' cur, name, colType, length, left(a1, 7) a1" ,
c1 "1 rows only;" ,
"declare prC2 cursor with return for" ,
"select 'cur2' cur, name, colType, left(a1, 7) a2" ,
c1 "3 rows only;" ,
"declare prC3 cursor with return for" ,
"select 'cur2' cur, name, left(a1, 7) a3" ,
"from sysibm.sysTables where 1 = 0;" ,
"if cnt >= 1 or cnt = -1 then open prC1; end if;" ,
"if cnt >= 2 or cnt = -2 then open prC2; end if;" ,
"if cnt >= 3 or cnt = -3 then open prC3; end if;" ,
"set res = strip(left(a1, 10)) || ' ' || cnt;" ,
"set cnt = cnt + 1;" ,
"end" )
d = 'TST_sqlCall'
do qx= -2 to 3
call tstOut t, 'call' qx sqlCall(3,
, "call" prc "(call"qx"," qx", ' ')")
call tstOut t, 'resultSets' m.sql.3.resultSet.0,
'vars='m.sql.3.var.0 ,
'2='m.sql.3.var.2 '3='m.sql.3.var.3
if m.sql.3.resultSet \== '' then
do qy=1 until \ sqlNextResultSet(3)
call tstOut t, '* resultSet' qy m.sql.3.fetchFlds
m.d.length = ''
m.d.colType = ''
m.d.a1 = ''
m.d.a2 = ''
m.d.a3 = ''
do while sqlFetch(3, d)
call tstOut t, 'cur='m.d.cur 'name='m.d.name ,
'type='m.d.colType 'len='m.d.length ,
'a1='m.d.a1 'a2='m.d.a2 'a3='m.d.a3
end
call sqlClose 3
end
end
call tstOut t, 'rollback ' sqlUpdate(3, 'rollback')
call sqlDisconnect
call tstEnd t
return
endProcedure tstSqlCall
tstSqlCsm: procedure expose m.
/*
$=/tstSqlCsm/
### start tst tstSqlCsm ###########################################
*** err: SQLCODE = -204: S100447.SYSDUMMY IS AN UNDEFINED NAME
. e 1: sql = select * from sysdummy
. e 2: sqlCsmExe RZZ/DE0G
1 jRead .ab=abc, .ef=efg
2 jRead .AB=a, .CD=2 .EF=---, .GH=d
$/tstSqlCsm/ */
call pipeIni
call tst t, "tstSqlCsm"
call sqlConnect m.tst_csmRzDb, 'c'
call jOpen sqlRdr('select * from sysdummy'), '<'
f1 = 'ab'
f2 = 'er'
r = jOpen(sqlRdr("select 'abc' , 'efg'",
'from sysibm.sysDummy1', f1 f2), '<')
a = 'abcdef'
b = 123
drop m.a.b.ab m.a.b.ef
do while jRead(r)
dst = m.r
call out '1 jRead .ab='m.dst.f1', .ef='m.dst.f2
end
drop m.a.b.ab m.a.ab.ef a b c
sql = "select 'a' a, 2 b, case when 1=0 then 1 else null end c",
", case when 1=1 then 'd' else null end d",
"from sysibm.sysDummy1"
r = jOpen(sqlRdr(sql, 'AB CD EF GH'), '<')
do while jRead(r)
dst = m.r
call out '2 jRead .AB='m.dst.AB', .CD='m.dst.CD ,
'.EF='m.dst.EF', .GH='m.dst.GH
end
st = 'abc.Def.123'
call tstEnd t
call sqlDisconnect
return
endProcedure tstsqlCsm
tstSqlCSV: procedure expose m.
/*
$=/tstSqlCSV/
### start tst tstSqlCSV ###########################################
NAME,CREATOR,MITCOM,MITQUO,MITNU,COL6
SYSTABLES,SYSIBM ,"a,b","a""b",1,8
SYSTABLESPACE,SYSIBM ,"a,b","a""b",---,8
SYSTABLESPACESTATS,SYSIBM,"a,b","a""b",---,6
$/tstSqlCSV/ */
call sqlConnect , 'r'
call tst t, "tstSqlCSV"
r = csv4ObjRdr(sqlRdr("select name, creator, 'a,b' mitCom",
", 'a""b' mitQuo" ,
", case when name='SYSTABLES' then 1 else null end mitNu" ,
",length(creator)" ,
"from sysibm.sysTables" ,
"where creator = 'SYSIBM' and name like 'SYSTABLES%'",
"fetch first 3 rows only"))
call pipeWriteAll r
call sqlDisConnect
call tstEnd t
return
endProcedure tstSqlCsv
tstSqlB: procedure expose m.
/*
$=/tstSqlB/
### start tst tstSqlB #############################################
#jIn 1# select strip(name) "tb", strip(creator) cr
#jIn 2# , case when name = 'SYSTABLES' then 1 else null end
#jIn 3# from sysibm.sysTables
#jIn 4# where creator = 'SYSIBM' and name like 'SYSTABLES%'
#jIn 5# .
#jIn 6# order by name
#jIn 7# fetch first 3 rows only
#jIn eof 8#
dest1.fet: SYSTABLES SYSIBM 1
dest2.fet: SYSTABLESPACE SYSIBM ---
dest3.fet: SYSTABLESPACESTATS SYSIBM ---
$/tstSqlB/ */
call pipeIni
call tst t, "tstSqlB"
cx = 9
call sqlConnect , 'e'
call jIni
call mAdd mCut(t'.IN', 0),
, 'select strip(name) "tb", strip(creator) cr' ,
, ", case when name = 'SYSTABLES' then 1 else null end" ,
, "from sysibm.sysTables" ,
, "where creator = 'SYSIBM' and name like 'SYSTABLES%'", ,
, "order by name",
, "fetch first 3 rows only"
call sqlQuery cx, in2Str(,' ')
do qx=1 while sqlFetch(cx, 'dest'qx'.fet')
dst = 'dest'qx'.fet'
call out dst':' m.dst.tb m.dst.cr m.dst.col3
drop m.dst.tb m.dst.cr m.dst.col3
end
call sqlClose cx
call sqlDisconnect
call tstEnd t
return
endProcedure tstSqlB
tstSqlFTab: procedure expose m.
/*
$=/tstSqlFTab/
### start tst tstSqlFTab ##########################################
UPDATESTATSTIME----------------NACTIVE------NPAGES-EXTENT-LOADRLAST+
TIME--------------REORGLASTTIME--------------REORGINSERT-REORGDELET+
E-REORGUPDATE-REORGUNCLUS-REORGDISORG-REORGMASSDE-REORGNEARIN-REORG+
FARIND-STATSLASTTIME--------------STATSINSERT-STATSDELETE-STATSUPDA+
TE-STATSMASSDE-COPYLASTTIME---------------COPYUPDATED-COPYCHANGES-C+
OPYUPDATE-COPYUPDATETIME-------------I---DBID---PSID-PARTIT-INSTAN-+
--SPACE-TOTALRO-DATASIZ-UNCOMPR-DBNAME-------NAME---------REORGCL-R+
EORGSC-REORGHA-HASHLASTUS-DRI-L-STATS01-UPDATES-LASTDATACHANGE-----+
----------
--- modified
allg vorher others vorher
db-------ts---------part---inst-UPDATESTATSTIME----------------NACT+
IVE------NPAGES-EXTENT-LOADRLASTTIME--------------REORGLASTTIME----+
----------REORGINSERT-REORGDELETE-REORGUPDATE-REORGUNCLUS-REORGDISO+
RG-REORGMASSDE-REORGNEARIN-REORGFARIND-STATSLASTTIME--------------S+
TATSINSERT-STATSDELETE-STATSUPDATE-STATSMASSDE-COPYLASTTIME--------+
-------COPYUPDATED-COPYCHANGES-COPYUPDATE-COPYUPDATETIME-----------+
--I---DBID---PSID---SPACE-TOTALRO-DATASIZ-UNCOMPR-REORGCL-REORGSC-R+
EORGHA-HASHLASTUS-DRI-L-STATS01-UPDATES-LASTDATACHANGE-------------+
--
db-------ts---------part---inst-UPDATESTATSTIME----------------NACT+
IVE------NPAGES-EXTENT-LOADRLASTTIME--------------REORGLASTTIME----+
----------REORGINSERT-REORGDELETE-REORGUPDATE-REORGUNCLUS-REORGDISO+
RG-REORGMASSDE-REORGNEARIN-REORGFARIND-STATSLASTTIME--------------S+
TATSINSERT-STATSDELETE-STATSUPDATE-STATSMASSDE-COPYLASTTIME--------+
-------COPYUPDATED-COPYCHANGES-COPYUPDATE-COPYUPDATETIME-----------+
--I---DBID---PSID---SPACE-TOTALRO-DATASIZ-UNCOMPR-REORGCL-REORGSC-R+
EORGHA-HASHLASTUS-DRI-L-STATS01-UPDATES-LASTDATACHANGE-------------+
--
allg nachher others nachher
DBNAME INSTANCE +
. NPAGES REORGLASTTIME +
. REORGUPDATES +
. REORGMASSDELETE STATSLASTTIME +
. STATSUPDATES +
. COPYUPDATEDPAGES COPYUPDATETIME +
. PSID DATASIZE REO+
RGSCANACCESS DRIVETYPE UPDATESIZE
. NAME UPDATESTATSTIME +
. EXTENTS +
. REORGINSERTS REORGUNCLUSTINS +
. REORGNEARINDREF +
. STATSINSERTS STATSMASSDELETE +
. COPYCHANGES +
. IBMREQD SPACE UNCOMPRESSEDDATASI+
ZE REORGHASHACCESS LPFACILITY LASTDATACHANGE
. PARTITION NACTIVE+
. LOADRLASTTIME +
. REORGDELETES REORGD+
ISORGLOB REORGFARINDREF +
. STATSDELETES COPYLASTTIME +
. COPYUPDATELRSN +
. DBID TOTALROWS REORGCLUSTE+
RSENS HASHLASTUSED STATS01
$/tstSqlFTab/
*/
call pipeIni
call tst t, 'tstSqlFTab'
call sqlConnect , 'r'
call sqlQuery 17, 'select * from sysibm.sysTablespaceStats' ,
"where dbName = 'xxxDB06' and name = 'SYSTSTAB'"
call sqlFTabOpts fTabReset(abc, 1, ,'-'), 12
call sqlFTabDef abc, 492, '%7e'
call sqlfTab abc, 17
call out '--- modified'
call sqlQuery 17, 'select * from sysibm.sysTablespaceStats' ,
"where dbName = 'xxxDB06' and name = 'SYSTSTAB'"
call sqlFTabOpts fTabReset(abc, 2 1, 1 3 'c', '-'), 12
call sqlFTabDef abc, 492, '%7e'
call ftabAdd abc, DBNAME, '%-8C', 'db', , 'allg vorher' ,
, 'allg nachher'
call ftabAdd abc, NAME , '%-8C', 'ts'
call ftabAdd abc, PARTITION , , 'part'
call ftabAdd abc, INSTANCE , , 'inst'
ox = m.abc.0 + 1
call sqlFTabOthers abc, 17
call fTabSetTit abc, ox, 2, 'others vorher'
call fTabSetTit abc, ox, 3, 'others nachher'
call sqlFTab abc, 17
call tstEnd t
call sqlDisConnect
return
endProcedure tstSqlFTab
tstSqlFTab2: procedure expose m.
/*
$=/tstSqlFTab2/
### start tst tstSqlFTab2 #########################################
Und Eins Oder
. zw aber
Und Eins---------------zw aber---
. und eins 22223
. und eins 22224
Und Eins---------------zw aber---
Und Eins Oder
. zw aber
a-------------b---
aaa 222
a-------------b---
--- row 1 ---------------------------------------------------------+
-------------
. Und Eins Oder und eins
. zw aber 2.2223000e04 22223
--- row 2 ---------------------------------------------------------+
-------------
. Und Eins Oder und eins
. zw aber 2.2224000e04 22224
--- end of 2 rows -------------------------------------------------+
-------------
$/tstSqlFTab2/
*/
call pipeIni
call tst t, 'tstSqlFTab2'
call sqlConnect , 'r'
sq1 = 'select '' und eins'' "Und Eins Oder"',
', 22222 + row_number() over() "zw aber" ',
'from sysibm.sysTables fetch first 2 rows only'
call sqlQuery 17, sq1
call sqlFTab sqlfTabReset(tstSqlFtab2), 17
sq2 = 'select ''aaa'' "a", 222 "b"' ,
'from sysibm.sysTables fetch first 1 rows only'
call sqlQuery 17, sq2
call sqlFTab sqlfTabReset(tstSqlFtab2), 17
call sqlQuery 15, sq1
call sqlFTab sqlfTabOpts(fTabReset(tstSqlFtab2, , , 'c')), 15
call tstEnd t
call sqlDisConnect
return
endProcedure tstSqlFTab2
tstSqlFTab3: procedure expose m.
/*
$=/tstSqlFTab3/
### start tst tstSqlFTab3 #########################################
Und Eins Oder
. zw aber
Und Eins--z---
. und eins 1
. und eins 2
Und Eins--z---
Und Eins Oder
. zw aber
a-----b---
aaa 222
a-----b---
$/tstSqlFTab3/
*/
call pipeIni
call tst t, 'tstSqlFTab3'
call sqlConnect , 'r'
sq1 = 'select '' und eins'' "Und Eins Oder"',
', row_number() over() "zw aber" ',
'from sysibm.sysTables fetch first 2 rows only'
call sqlQuery 7, sq1
ft = sqlFTabOpts(fTabReset('tstSqFTab3', , ,'-a'))
call sqlFTab ft, 7
sq2 = 'select ''aaa'' "a", 222 "b"' ,
'from sysibm.sysTables fetch first 1 rows only'
call sqlQuery 17, sq2
f = sqlfTabReset('tstSqFTab3t')
st = 'tstSqFTab3st'
call sqlFetch2St 17, st
s2 = 'tstSqFTab3s2'
do sx=1 to m.st.0
m.s2.sx = st'.'sx
end
m.s2.0 = m.st.0
call sqlFTabComplete f, 17, 1, 0
call fTabDetect f, s2
call fTabBegin f
do sx=1 to m.st.0
call out f(m.f.fmt, st'.'sx)
end
call fTabEnd f
call tstEnd t
call sqlDisConnect
return
endProcedure tstSqlFTab3
tstSqlFTab4: procedure expose m.
/*
$=/tstSqlFTab4/
### start tst tstSqlFTab4 #########################################
a
1
1 rows fetched: select 1 "a" from sysibm.sysDummy1
sqlCode -204: drop table gibt.EsNicht
a
2
1 rows fetched: select 2 "a" from sysibm.sysDummy1
*** err: SQLCODE = -104: ILLEGAL SYMBOL "Y". SOME SYMBOLS THAT MIGH+
T
. e 1: BE LEGAL ARE: , FROM INTO
. e 2: src select x frm y
. e 3: > <<<pos 14 of 14<<<
. e 4: sql = select x frm y
. e 5: stmt = prepare s49 into :M.SQL.49.D from :src
. e 6: with into :M.SQL.49.D = M.SQL.49.D
sqlCode -104: select x frm y
a
3
1 rows fetched: select 3 "a" from sysibm.sysDummy1
dy => 1
a
1
1 rows fetched: select 1 "a" from sysibm.sysDummy1
sqlCode -204: drop table gibt.EsNicht
a
2
1 rows fetched: select 2 "a" from sysibm.sysDummy1
fatal error in wsM: SQLCODE = -104: ILLEGAL SYMBOL "Y". SOME SYMBO+
LS THAT MIGHT
. BE LEGAL ARE: , FROM INTO
src select x frm y
. > <<<pos 14 of 14<<<
sql = select x frm y
stmt = prepare s49 into :M.SQL.49.D from :src
with into :M.SQL.49.D = M.SQL.49.D
sqlCode 0: rollback
ret => 0
$/tstSqlFTab4/
*/
call pipeIni
call tst t, 'tstSqlFTab4'
eOutOld = m.err_sayOut
m.err_sayOut = 1
call sqlConnect
b = jBuf('select 1 "a" from sysibm.sysDummy1;' ,
, 'drop table gibt.EsNicht;' ,
, 'select 2 "a" from sysibm.sysDummy1;',
, ' select x frm y;',
, 'select 3 "a" from sysibm.sysDummy1;')
call tstout t, 'dy =>' sqlsOut(scanSqlStmtRdr(b, 0))
call tstout t, 'ret =>' sqlsOut(scanSqlStmtRdr(b, 0), 'rb ret')
call tstEnd t
call sqlDisConnect
m.err_sayOut = eOutOld
return
endProcedure tstSqlFTab4
tstSqlFTab5: procedure expose m.
/*
$=/tstSqlFTab5/
### start tst tstSqlFTab5 #########################################
-----D6-------D73------D62---------D92---
. 23456 -123.456 45.00 -123.45
-----D6-------D73------D62---------D92---
$/tstSqlFTab5/
*/
call pipeIni
call tst t, 'tstSqlFTab5'
call sqlConnect , 'e'
sq1 = 'select dec(23456, 6) d6, dec(-123.4567, 7, 3) d73',
', dec(45, 6, 2) d62, dec(-123.45678, 9, 2) d92',
'from sysibm.sysDummy1'
call sqlQuery 17, sq1
call sqlFTab sqlfTabReset(tstSqlFtab5), 17
call tstEnd t
call sqlDisConnect
return
endProcedure tstSqlFTab5
tstSql4Obj: procedure expose m.
/*
$=/tstSql4Obj/
### start tst tstSql4Obj ##########################################
tstR: @tstWriteoV2 isA :tstClass-1 = -11
tstR: .a2i = -11
tstR: .b3b = b3
tstR: .D4 = D4-11+D4++++.
tstR: .fl5 = -111.1
tstR: .ex6 = -.111e-11
insert into cr.insTb -- tstClass-1
. ( , a2i, b3b, D4, fl5, ex6
. ) values .
. ( -11, -11, 'b3', 'D4-11+D4++++', -111.1, -.111e-11
. ) ; .
insert into cr.insTbHex -- tstClass-1
. ( , a2i, b3b, D4, fl5, ex6
. ) values .
. ( -11, -11, 'b3', x'C40760F1F14EC4F44E4E4E4E', -111.1, -.111e-1+
1
. ) ; .
tstR: @tstWriteoV4 isA :tstClass-2
tstR: .c = c83
tstR: .a2i = 83
tstR: .b3b = b3b8
tstR: .D4 = D483+D4++++++++++++++++++++++++++++++++++++++++++++++++
.++++++++++++++++++++++++++++++.
tstR: .fl5 = .183
tstR: .ex6 = .11183e-8
insert into cr.insTb -- tstClass-2
. ( c, a2i, b3b, D4, fl5, ex6
. ) values .
. ( 'c83', 83, 'b3b8'
. , 'D483+D4++++++++++++++++++++++++++++++++++++++++++++++++++++++
'
. || '++++++++++++++++++++++++'
. , .183, .11183e-8
. ) ; .
insert into cr.insTbHex -- tstClass-2
. ( c, a2i, b3b, D4, fl5, ex6
. ) values .
. ( 'c83', 83, 'b3b8'
. , x'C407F8F34EC4F44E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E'
. || '++++++++++++++++++++++++++++++++'
. || x'314E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E'
. , .183, .11183e-8
. ) ; .
$/tstSql4Obj/
*/
call pipeIni
call tst t, 'tstSql4Obj'
call pipe '+N'
call tstDataClassOut '. c3 a2i i b3b c5 D4 c23 fl5 f8n2 ex6 e9n3',
, -11, -11
call tstDataClassOut 'c c3 a2i i b3b c5 D4 c93 fl5 f8n2 ex6 e9n3',
, 83, 83
call pipe 'P|'
do cx=1 while in()
i = m.in
call mAdd t'.'trans, className(objClass(i)) 'tstClass-'cx
call out i
call sql4Obj i, 'cr.insTb'
m.i.d4 = overlay('07'x, m.i.d4, 2)
if length(m.i.d4) >= 62 then
m.i.d4 = overlay('31'x, m.i.d4, 62)
call sql4Obj i, 'cr.insTbHex'
end
call pipe '-'
call tstEnd t
return
endProcedure tstSql4Obj
tstSqlC: procedure expose m.
/*
$=/tstSqlCRx/
### start tst tstSqlCRx ###########################################
*** err: SQLCODE = -104: ILLEGAL SYMBOL "?". SOME SYMBOLS THAT MIGH+
T
. e 1: BE LEGAL ARE: . <IDENTIFIER> JOIN INNER LEFT RIGHT FU+
LL CROSS ,
. e 2: HAVING GROUP
. e 3: src select * from sysibm?sysDummy1
. e 4: > >>>pos 21 of 30>>>
. e 5: sql = select * from sysibm?sysDummy1
. e 6: stmt = prepare s10 into :M.SQL.10.D from :src
. e 7: with into :M.SQL.10.D = M.SQL.10.D
*** err: SQLCODE = -204: NONONO.SYSDUMMY1 IS AN UNDEFINED NAME
. e 1: sql = select * from nonono.sysDummy1
. e 2: stmt = prepare s10 into :M.SQL.10.D from :src
. e 3: with into :M.SQL.10.D = M.SQL.10.D
sys local ==> server CHSKA000DP4G .
fetched a1=abc, i2=12, c3=---
. I1 C2
. 1 eins
2222 zwei
$/tstSqlCRx/
$=/tstSqlCCsm/
### start tst tstSqlCCsm ##########################################
*** err: SQLCODE = -104: ILLEGAL SYMBOL "?". SOME SYMBOLS THAT MIGH+
T
. e 1: BE LEGAL ARE: . <IDENTIFIER> JOIN INNER LEFT RIGHT FU+
LL CROSS ,
. e 2: HAVING GROUP
. e 3: src select * from sysibm?sysDummy1
. e 4: > >>>pos 21 of 30>>>
. e 5: sql = select * from sysibm?sysDummy1
. e 6: sqlCsmExe RZZ/DE0G
*** err: SQLCODE = -204: NONONO.SYSDUMMY1 IS AN UNDEFINED NAME
. e 1: sql = select * from nonono.sysDummy1
. e 2: sqlCsmExe RZZ/DE0G
sys RZZ/DE0G csm ==> server CHROI00ZDE0G .
fetched a1=abc, i2=12, c3=---
. I1 C2
. 1 eins
2222 zwei
$/tstSqlCCsm/
### start tst tstSqlCWsh ##########################################
*** err: sqlWshRdr got fatal error in wsM: SQLCODE = -104: ILLEGAL +
SYMBOL "?". SOME SYMBOLS THAT MIGHT
. e 1: BE LEGAL ARE: . <IDENTIFIER> JOIN INNER LEFT RIGHT FU+
LL CROSS ,
. e 2: HAVING GROUP
. e 3: src select * from sysibm?sysDummy1
. e 4: > >>>pos 21 of 30>>>
. e 5: sql = select * from sysibm?sysDummy1
. e 6: stmt = prepare s10 into :M.SQL.10.D from :src
. e 7: with into :M.SQL.10.D = M.SQL.10.D
*** err: sqlWshRdr got fatal error in wsM: SQLCODE = -204: NONONO.S+
YSDUMMY1 IS AN UNDEFINED NAME
. e 1: sql = select * from nonono.sysDummy1
. e 2: stmt = prepare s10 into :M.SQL.10.D from :src
. e 3: with into :M.SQL.10.D = M.SQL.10.D
sys RZZ/DE0G wsh ==> server CHROI00ZDE0G .
fetched a1=abc, i2=12, c3=---
. I1 C2
. 1 eins
$=/tstSqlCWsh/
### start tst tstSqlCWsh ##########################################
*** err: sqlWshRdr got fatal error in wsM: SQLCODE = -104: ILLEGAL+
. SYMBOL "?". SOME SYMBOLS THAT MIGHT
. e 1: BE LEGAL ARE: . <IDENTIFIER> JOIN INNER LEFT RIGHT FU+
LL CROSS ,
. e 2: HAVING GROUP
. e 3: src select * from sysibm?sysDummy1
. e 4: > >>>pos 21 of 30>>>
. e 5: sql = select * from sysibm?sysDummy1
. e 6: stmt = prepare s10 into :M.SQL.10.D from :src
. e 7: with into :M.SQL.10.D = M.SQL.10.D
. e 8: sqlCode 0: rollback
. e 9: from RZZ Z24 DE0G
*** err: sqlWshRdr got fatal error in wsM: SQLCODE = -204: NONONO.+
SYSDUMMY1 IS AN UNDEFINED NAME
. e 1: sql = select * from nonono.sysDummy1
. e 2: stmt = prepare s10 into :M.SQL.10.D from :src
. e 3: with into :M.SQL.10.D = M.SQL.10.D
. e 4: sqlCode 0: rollback
. e 5: from RZZ Z24 DE0G
sys RZZ/DE0G wsh ==> server CHROI00ZDE0G .
fetched a1=abc, i2=12, c3=---
. I1 C2
. 1 eins
2222 zwei
$/tstSqlCWsh/
*/
call pipeIni
sql1 = "select 1 i1, 'eins' c2 from sysibm.sysDummy1" ,
"union all select 2222 i1, 'zwei' c2 from sysibm.sysDummy1"
do tx=1 to 1 + (m.tst_CsmRZ \== '') * 2
if tx = 1 then do
call tst t, "tstSqlCRx"
call sqlConnect , 'r'
sys = 'local'
end
else if tx=2 then do
call tst t, "tstSqlCCsm"
sys = m.tst_csmRzDb 'csm'
call sqlConnect m.tst_csmRzDb, 'c'
end
else do
call tst t, "tstSqlCWsh"
call sqlConnect m.tst_csmRzDb, 'w'
sys = m.tst_csmRzDb 'wsh'
end
cx = 9
call jOpen sqlRdr('select * from sysibm?sysDummy1'), '<'
call jOpen sqlRdr('select * from nonono.sysDummy1'), '<'
rr = jOpen(sqlRdr("select 'abc' a1, 12 i2, current server srv",
", case when 1=0 then 1 else null end c3",
"from sysibm.sysDummy1"), '<')
do while jRead(rr)
dst = m.rr
call out 'sys' sys '==> server' m.dst.srv
call out 'fetched a1='m.dst.a1', i2='m.dst.i2', c3='m.dst.c3
end
call jClose rr
call fTabAuto , sqlRdr(sql1)
call sqlDisconnect
call tstEnd t
end
return
endProcedure tstSqlC
tstSqlUpd: procedure expose m.
/*
$=/tstSqlUpd/
### start tst tstSqlUpd ###########################################
insert updC 1
insert select updC 2
dest4.fet: 1 eins 2012-04-01-06.07.08.000000 1 updC 0
dest5.fet: 2 zwei 2012-02-29-15.44.33.220000 --- updC 0
dest6.fet: 11 zehn+eins 2012-04-11-06.07.08.000000 1 updC 0
dest7.fet: 12 zehn+zwei 2012-03-10-15.44.33.220000 --- updC 0
SQLCODE = 000, SUCCESSFUL EXECUTION
warnings 4=W no where
sql = select * from final table (update session.dgtt set c2 = 'u' +
|| c2)
stmt = prepare s9 into :M.SQL.9.D from :src
with into :M.SQL.9.D = M.SQL.9.D
dest9.fet: 1 ueins 2012-04-01-06.07.08.000000 updC 4
dest10.fet: 2 uzwei 2012-02-29-15.44.33.220000 updC 4
dest11.fet: 11 uzehn+eins 2012-04-11-06.07.08.000000 updC 4
dest12.fet: 12 uzehn+zwei 2012-03-10-15.44.33.220000 updC 4
$/tstSqlUpd/ */
call tst t, "tstSqlUpd"
cx = 9
qx = 3
call sqlConnect , 'e'
call sqlUpdate,"declare global temporary table session.dgtt",
"(i1 int, c2 varchar(20), t3 timestamp)"
call sqlUpdate,"insert into session.dgtt" ,
"values(1, 'eins', '2012-04-01 06.07.08')"
call sqlUpdate,"insert into session.dgtt" ,
"values(2, 'zwei', '2012-02-29 15:44:33.22')"
call out 'insert updC' m.sql..updateCount
call sqlUpdate,"insert into session.dgtt" ,
"select i1+10, 'zehn+'||strip(c2), t3+10 days",
"from session.dgtt"
call out 'insert select updC' m.sql..updateCount
call sqlQuery cx, 'select d.*' ,
', case when mod(i1,2) = 1 then 1 else null end grad' ,
'from session.dgtt d'
do qx=qx+1 while sqlFetch(cx, 'dest'qx'.fet')
dst = 'dest'qx'.fet'
call out dst':' m.dst.i1 m.dst.c2 m.dst.t3 m.dst.grad ,
'updC' m.sql.cx.updateCount
drop m.dst.i1 m.dst.c2 m.dst.t3 m.dst.grad
end
call sqlClose cx
call sqlQuery cx, "select * from final table (update session.dgtt",
" set c2 = 'u' || c2)"
do qx=qx+1 while sqlFetch(cx, 'dest'qx'.fet')
dst = 'dest'qx'.fet'
call out dst':' m.dst.i1 m.dst.c2 m.dst.t3 ,
'updC' m.sql.cx.updateCount
drop m.dst.i1 m.dst.c2 m.dst.t3 m.dst.grad
end
call sqlDisconnect
call tstEnd t
return
endProcedure tstSqlUpd
tstSqlUpdPre: procedure expose m.
/*
$=/tstSqlUpdPre/
### start tst tstSqlUpdPre ########################################
insert updC 1
insert select updC 2
dest4.fet: 1 eins 2012-04-01-06.07.08.000000 1 updC 0
dest5.fet: 2 zwei 2012-02-29-15.44.33.220000 --- updC 0
dest6.fet: 11 zehn+eins 2012-04-11-06.07.08.000000 1 updC 0
dest7.fet: 12 zehn+zwei 2012-03-10-15.44.33.220000 --- updC 0
SQLCODE = 000, SUCCESSFUL EXECUTION
warnings 4=W no where
sql = select * from final table ( update session.dgtt set c2 = ? ||+
. c2)
stmt = prepare s5 into :M.SQL.5.D from :src
with into :M.SQL.5.D = M.SQL.5.D
dest9.fet: 1 ueins 2012-04-01-06.07.08.000000 updC 4
dest10.fet: 2 uzwei 2012-02-29-15.44.33.220000 updC 4
dest11.fet: 11 uzehn+eins 2012-04-11-06.07.08.000000 updC 4
dest12.fet: 12 uzehn+zwei 2012-03-10-15.44.33.220000 updC 4
$/tstSqlUpdPre/ */
call tst t, "tstSqlUpdPre"
cx = 5
qx = 3
call sqlConnect , 'e'
call sqlUpdate,"declare global temporary table session.dgtt",
"(i1 int, c2 varchar(20), t3 timestamp)"
call sqlUpdatePrepare 5, "insert into session.dgtt" ,
"values (?, ?, ?)"
call sqlUpdateExecute 5, 1, 'eins', '2012-04-01 06.07.08'
call sqlUpdateExecute 5, 2, 'zwei', '2012-02-29 15:44:33.22'
call out 'insert updC' m.sql.5.updateCount
call sqlUpdatePrepare 5,"insert into session.dgtt" ,
"select i1+?, 'zehn+'||strip(c2), t3+? days",
"from session.dgtt"
call sqlUpdateExecute 5, 10, 10
call out 'insert select updC' m.sql.5.updateCount
call sqlQueryPrepare cx, 'select d.*' ,
', case when mod(i1,2) = ? then 0+? else null end grad',
'from session.dgtt d'
call sqlQueryExecute cx, 1, 1
do qx=qx+1 while sqlFetch(cx, 'dest'qx'.fet')
dst = 'dest'qx'.fet'
call out dst':' m.dst.i1 m.dst.c2 m.dst.t3 m.dst.grad ,
'updC' m.sql.cx.updateCount
drop m.dst.i1 m.dst.c2 m.dst.t3 m.dst.grad
end
call sqlClose cx
call sqlQueryPrepare cx, "select * from final table (" ,
"update session.dgtt set c2 = ? || c2)"
call sqlQueryExecute cx, "u"
do qx=qx+1 while sqlFetch(cx, 'dest'qx'.fet')
dst = 'dest'qx'.fet'
call out dst':' m.dst.i1 m.dst.c2 m.dst.t3 ,
'updC' m.sql.cx.updateCount
drop m.dst.i1 m.dst.c2 m.dst.t3 m.dst.grad
end
call sqlDisconnect
call tstEnd t
return
endProcedure tstSqlUpdPre
tstsqlRxUpd: procedure expose m.
/*
$=/tstsqlRxUpd/
### start tst tstsqlRxUpd #########################################
insert updC 1
insert select updC 2
dest4.fet: 1 eins 2012-04-01-06.07.08.000000 1 updC 0
dest5.fet: 2 zwei 2012-02-29-15.44.33.220000 --- updC 0
dest6.fet: 11 zehn+eins 2012-04-11-06.07.08.000000 1 updC 0
dest7.fet: 12 zehn+zwei 2012-03-10-15.44.33.220000 --- updC 0
SQLCODE = 000, SUCCESSFUL EXECUTION
warnings 4=W no where
sql = select * from final table (update session.dgtt set c2 = 'u' +
|| c2)
stmt = prepare s9 into :M.SQL.9.D from :src
with into :M.SQL.9.D = M.SQL.9.D
dest9.fet: 1 ueins 2012-04-01-06.07.08.000000 updC 4
dest10.fet: 2 uzwei 2012-02-29-15.44.33.220000 updC 4
dest11.fet: 11 uzehn+eins 2012-04-11-06.07.08.000000 updC 4
dest12.fet: 12 uzehn+zwei 2012-03-10-15.44.33.220000 updC 4
$/tstsqlRxUpd/ */
call pipeIni
call tst t, "tstsqlRxUpd"
cx = 9
qx = 3
call sqlConnect , 'e'
call sqlUpdate,"declare global temporary table session.dgtt",
"(i1 int, c2 varchar(20), t3 timestamp)"
call sqlUpdate,"insert into session.dgtt" ,
"values(1, 'eins', '2012-04-01 06.07.08')"
call sqlUpdate,"insert into session.dgtt" ,
"values(2, 'zwei', '2012-02-29 15:44:33.22')"
call out 'insert updC' m.sql..updateCount
call sqlUpdate,"insert into session.dgtt" ,
"select i1+10, 'zehn+'||strip(c2), t3+10 days",
"from session.dgtt"
call out 'insert select updC' m.sql..updateCount
call sqlQuery cx, 'select d.*' ,
', case when mod(i1,2) = 1 then 1 else null end grad' ,
'from session.dgtt d'
do qx=qx+1 while sqlFetch(cx, 'dest'qx'.fet')
dst = 'dest'qx'.fet'
call out dst':' m.dst.i1 m.dst.c2 m.dst.t3 m.dst.grad ,
'updC' m.sql.cx.updateCount
drop m.dst.i1 m.dst.c2 m.dst.t3 m.dst.grad
end
call sqlClose cx
call sqlQuery cx, "select * from final table",
"(update session.dgtt set c2 = 'u' || c2)"
do qx=qx+1 while sqlFetch(cx, 'dest'qx'.fet')
dst = 'dest'qx'.fet'
call out dst':' m.dst.i1 m.dst.c2 m.dst.t3 ,
'updC' m.sql.cx.updateCount
drop m.dst.i1 m.dst.c2 m.dst.t3 m.dst.grad
end
call sqlClose cx
call sqlDisconnect
call tstEnd t
return
endProcedure tstsqlRxUpd
tstSqlE: procedure expose m.
/*
$=/tstSqlE/
### start tst tstSqlE #############################################
*** err: SQLCODE = -713: THE REPLACEMENT VALUE FOR CURRENT SCHEMA I+
S
. e 1: INVALID
. e 2: sql = set current schema = 'sysibm'
. e 3: stmt = execute immediate :src
-713 set schema ''
0 set schema
0 select
fetch=1 SYSIBM
$/tstSqlE/
*/
call sqlConnect , 'e'
call tst t, "tstSqlE"
call tstOut t, sqlExecute(3, "set current schema = 'sysibm'") ,
"set schema ''"
call tstOut t, sqlExecute(3, " set current schema = sysibm ") ,
"set schema"
call tstOut t, sqlExecute(3, " select current schema c" ,
"from sysibm.sysDummy1") 'select'
call tstOut t, 'fetch='sqlFetch(3, aa) m.aa.c
call sqlClose 3
call sqlDisConnect
call tstEnd t
return
endProcedure tstSqlE
tstSqlO: procedure expose m.
/*
$=/tstSqlO/
### start tst tstSqlO #############################################
sqlCode 0: set current schema = A540769
*** err: SQLCODE = -204: A540769.SYSDUMMY IS AN UNDEFINED NAME
. e 1: sql = select * from sysdummy
. e 2: stmt = prepare s49 into :M.SQL.49.D from :src
. e 3: with into :M.SQL.49.D = M.SQL.49.D
sqlCode -204: select * from sysdummy
REQD=Y col=123 case=--- .sqlInd:-1 col5=anonym geburri=1956-04-01+
-06.00.00.000000
$/tstSqlO/
*/
call sqlConnect , 's'
call tst t, "tstSqlO"
call sqlStmts 'set current schema = A540769';
call sqlStmts 'select * from sysdummy';
r = sqlRdr( ,
"select d.*, 123, timestamp('01.04.1956','06:00:00')" ,
'"geburri walter",',
'case when 1=0 then 1 else null end caseNull,',
"'anonym'" ,
'from sysibm.sysdummy1 d')
call jOpen r, '<'
do while jRead(r)
o = m.r
call out 'REQD='m.o.IBMREQD 'col='m.o.col2,
'case='m.o.CASENULL '.sqlInd:'m.o.caseNull.sqlInd,
'col5='m.o.col5,
'geburri='m.o.GEBURRI
end
call jClose r
call sqlDisConnect
call tstEnd t
return
endProcedure tstSqlO
tstSqlUpdComLoop: procedure expose m.
/*
$=/tstSqlUpdComLoop/
### start tst tstSqlUpdComLoop ####################################
sqlCode 0: declare global temporary table session.dgtt (i1 int) on +
commit ....
sqlCode 0, 123 rows inserted: insert into session.dgtt select row_n+
umber()....
CNT
123
1 rows fetched: select count(*) cnt from session.dgtt
123 rows deleted, 10 commits: delete from session.dgtt d where i1 i+
n (sele....
C
0
1 rows fetched: select count(*) cnt from session.dgtt
$/tstSqlUpdComLoop/ */
call pipeIni
call tst t, "tstSqlUpdComLoop"
call sqlConnect , 's'
call sqlsOut "declare global temporary table session.dgtt",
"(i1 int) on commit preserve rows"
call sqlsOut "insert into session.dgtt",
"select row_number() over() from sysibm.sysTables",
"fetch first 123 rows only"
call sqlsOut "select count(*) cnt from session.dgtt"
call out sqlUpdComLoop("delete from session.dgtt d where i1 in",
"(select i1 from session.dgtt fetch first 13 rows only)")
call sqlsOut "select count(*) cnt from session.dgtt"
call sqlDisConnect
call tstEnd t
return
endProcedure tstSqlUpdComLoop
tstSqlO1: procedure expose m.
/*
$=/tstSqlO1/
### start tst tstSqlO1 ############################################
tstR: @tstWriteoV2 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLEPART
tstR: @tstWriteoV3 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLEPART_HIST
tstR: @tstWriteoV4 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLES
tstR: @tstWriteoV5 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLESPACE
--- writeAll
tstR: @tstWriteoV6 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLEPART
tstR: @tstWriteoV7 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLEPART_HIST
tstR: @tstWriteoV8 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLES
tstR: @tstWriteoV9 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLESPACE
$/tstSqlO1/
*/
call pipeIni
call tst t, "tstSqlO1"
call sqlConnect , 'r'
qr = sqlRdr("select strip(creator) cr, strip(name) tb",
"from sysibm.sysTables",
"where creator='SYSIBM' and name like 'SYSTABL%'",
"order by 2 fetch first 4 rows only")
call jOpen qr, m.j.cRead
call mAdd t.trans, className(m.qr.type) '<tstSqlO1Type>'
do while jRead(qr)
call out m.qr
end
call jClose qr
call out '--- writeAll'
call pipeWriteAll qr
call sqlDisConnect
call tstEnd t
return 0
endProcedure tstSqlO1
tstSqlO2: procedure expose m.
/*
$=/tstSqlO2/
### start tst tstSqlO2 ############################################
CR TB RR
SYSIBM SYSTABLEPART 1
SYSIBM SYSTABLEPART_HIST 4
SYSIBM SYSTABLES 9
SYSIBM SYSTABLESPACE 16
$/tstSqlO2/
*/
call pipeIni
call tst t, "tstSqlO2"
call sqlConnect , 'r'
call pipe '+N'
call out "select strip(creator) cr, strip(name) tb,"
call out "(row_number()over())*(row_number()over()) rr"
call out "from sysibm.sysTables"
call out "where creator='SYSIBM' and name like 'SYSTABL%'"
call out "order by 2 fetch first 4 rows only"
call pipe 'N|'
call sqlSel
call pipe 'P|'
call fTabAuto fTabReset(abc, 1)
call pipe '-'
call sqlDisConnect
call tstEnd t
return 0
endProcedure tstSqlO2
tstSqlS1: procedure expose m.
/*
$=/tstSqlS1/
### start tst tstSqlS1 ############################################
select c, a from sysibm.sysDummy1
tstR: @tstWriteoV2 isA :<cla sql c a>
tstR: .C = 1
tstR: .A = a
select ... where 1=0
tstR: @ obj null
$/tstSqlS1/
*/
call tst t, "tstSqlS1"
call sqlConnect , 'r'
s1 = jSingle( ,
sqlRdr("select count(*) c, 'a' a from sysibm.sysdummy1"))
call mAdd t.trans, className(objClass(s1)) '<cla sql c a>'
call out 'select c, a from sysibm.sysDummy1'
call tstWrite t, s1
call out 'select ... where 1=0'
call tstWrite t, jSingle( ,
sqlRdr("select*from sysibm.sysdummy1 where 1=0"), '')
call sqlDisConnect
call tstEnd t
return
endProcedure tstSqlS1
tstSqlWsh: procedure expose m.
/*
$=/tstSqlWsh/
### start tst tstSqlWsh ###########################################
tstR: @tstWriteoV14 isA :Sql*15
tstR: .COL1 = <csmServer>
1 rows fetched: select current server from sysibm.sysDummy1
tstR: @tstWriteoV16 isA :Sql*17
tstR: .ZWEI = second sel
tstR: .DREI = 3333
tstR: .VIER = 4444
1 rows fetched: select 'second sel' zwei, 3333 drei, 4444 vier from+
. sysibm....
fatal error in wsM: SQLCODE = -104: ILLEGAL SYMBOL "XYZ". SOME SYM+
BOLS THAT
. MIGHT BE LEGAL ARE: <ERR_STMT> <WNG_STMT> GET SQL SAVEPOINT HO+
LD
. FREE ASSOCIATE
src xyz
. > <<<pos 1 of 3<<<
sql = xyz
sqlCode 0: rollback
from <csmRZ> <csmSys*> <csmDB>
$/tstSqlWsh/
*/
call pipeIni
call sqlconClass_w
call tst t, "tstSqlWsh"
call tstTransCsm t
b = jBuf('select current server from' , 'sysibm.sysDummy1',
, ';;;', "select 'second sel' zwei, 3333 drei, 4444 vier" ,
, "from sysibm.sysDummy1",,";;xyz")
r = scanSqlStmtRdr(b)
call sqlWshOut r, m.tst_csmRzDb, 0, 'o'
call tstEnd t
return
endProcedure tstSqlWsh
tstSqlWs2: procedure expose m.
/*
$=/tstSqlWs2/
### start tst tstSqlWs2 ###########################################
tstR: @tstWriteoV14 isA :Sql*15
tstR: .COL1 = <csmServer> .
tstR: .COLNO = 1
tstR: .NAME = NAME
tstR: @tstWriteoV16 isA :Sql*15
tstR: .COL1 = <csmServer> .
tstR: .COLNO = 2
tstR: .NAME = CREATOR
tstR: @tstWriteoV17 isA :Sql*15
tstR: .COL1 = <csmServer> .
tstR: .COLNO = 3
tstR: .NAME = TYPE
tstR: @tstWriteoV18 isA :Sql*15
tstR: .COL1 = <csmServer> .
tstR: .COLNO = 4
tstR: .NAME = DBNAME
$/tstSqlWs2/
*/
call pipeIni
call sqlconClass_w
call tst t, "tstSqlWs2"
call tstTransCsm t
sql = "select current server, colNo, name" ,
"from sysibm.sysColumns" ,
"where tbCreator = 'SYSIBM' and tbName = 'SYSTABLES'",
"order by colNo fetch first 4 rows only"
w = oNew(m.class_SqlWshRdr, m.tst_csmRzDb, sql)
call pipeWriteNow w
call tstEnd t
return
endProcedure tstSqlWs2
tstSqlStmt: procedure expose m.
/*
$=/tstSqlStmt/
### start tst tstSqlStmt ##########################################
*** err: SQLCODE = -713: THE REPLACEMENT VALUE FOR CURRENT SCHEMA I+
S
. e 1: INVALID
. e 2: sql = set current schema = 'sysibm'
. e 3: stmt = execute immediate :src
sqlCode -713: set current schema = 'sysibm'
sqlCode 0: set current schema = sysibm
tstR: @tstWriteoV2 isA :<sql?sc>
tstR: .C = SYSIBM
1 rows fetched: select current schema c from sysDummy1
tstR: @tstWriteoV3 isA :<sql?sc>
tstR: .C = SYSIBM
1 rows fetched: (select current schema c from sysDummy1)
$/tstSqlStmt/
*/
call sqlConnect , 's'
call tst t, "tstSqlStmt"
cn = className(classNew('n* Sql u f%v C'))
call mAdd t.trans, cn '<sql?sc>'
call sqlStmts "set current schema = 'sysibm'"
call sqlsOut " set current schema = sysibm "
call sqlsOut " select current schema c from sysDummy1", , 'o'
call sqlsOut " (select current schema c from sysDummy1)", , 'o'
call sqlDisConnect
call tstEnd t
return
endProcedure tstSqlStmt
tstSqlStmts: procedure expose m.
/*
$=/tstSqlStmts/
### start tst tstSqlStmts #########################################
*** err: SQLCODE = -104: ILLEGAL SYMBOL "BLABLA". SOME SYMBOLS THAT
. e 1: MIGHT BE LEGAL ARE: <ERR_STMT> <WNG_STMT> GET SQL SAV+
EPOINT HOLD
. e 2: FREE ASSOCIATE
. e 3: src blabla
. e 4: > <<<pos 1 of 6<<<
. e 5: sql = blabla
sqlCode -104: blabla
sqlCode 0: set current schema= sysIbm
c
1
1 rows fetched: select count(*) "c" from sysDummy1 with ur
c
1
1 rows fetched: select count(*) "c" from sysDummy1 with ur
#jIn 1# set current -- sdf
#jIn 2# schema = s100447;
#jIn eof 3#
sqlCode 0: set current schema = s100447
$/tstSqlStmts/ */
call sqlConnect , 's'
call tst t, "tstSqlStmts"
call sqlStmts "blabla ;;set current schema= sysIbm "
b = jBuf('select count(*) "c" from sysDummy1 --com' ,
,'with /* comm */ ur;')
call sqlStmts b
call sqlStmts b
call mAdd mCut(t'.IN', 0), 'set current -- sdf','schema = s100447;'
call sqlStmts
call sqlDisConnect
call tstEnd t
return
endProcedure tstSqlStmts
tstDb2Ut: procedure expose m.
/*
$=/tstDb2Ut/
### start tst tstDb2Ut ############################################
. TEMPLATE IDSN DSN(DSN.INPUT.UNL)
#jIn 1# template old ,
. template old ,
#jIn 2# LOAD DATA INDDN oldDD .
LOAD DATA LOG NO
. INDDN IDSN RESUME NO REPLACE COPYDDN(TCOPYD)
. DISCARDDN TDISC
. STATISTICS INDEX(ALL) UPDATE ALL
. DISCARDS 1
. ERRDDN TERRD
. MAPDDN TMAPD .
. WORKDDN (TSYUTD,TSOUTD) .
. SORTDEVT DISK .
#jIn 3# ( cols )
( cols )
$/tstDb2Ut/
*/
call pipeIni
call tst t, 'tstDb2Ut'
call mAdd mCut(t'.IN', 0), ' template old ,' ,
, 'LOAD DATA INDDN oldDD ' ,
, '( cols )'
call db2UtilPunch 'rep iDsn=DSN.INPUT.UNL'
call tstEnd t
return
endProcedure tstDb2Ut
/*--- manualTest for csi --------------------------------------------*/
tstSqlDisDb: procedure expose m.
call sqlDsn di, 'DP4G', '-dis db(*) sp(*)' ,
'restrict advisory limit(*)', 12
m.oo.0 = 0
call sqlDisDb oo, di
say 'di.0' m.di.0 '==> oo.0' m.oo.0
trace ?r
ix = sqlDisDbIndex(oo, QZ01A1P,A006A)
say 'DB2PDB6.RR2HHAGE ==>' ix m.oo.ix.sta
ix = sqlDisDbIndex(oo, QZ01A1P,A006J, 3)
say 'DB2PDB6.RR2HHAGE.3 ==>' ix m.oo.ix.sta
ix = sqlDisDbIndex(oo, DB2PDB6,RR2HHAGE,22)
say 'DB2PDB6.RR2HHAGE.22 ==>' ix m.oo.ix.sta
return
endProcedure tstSqlDisDb
/****** tst wsh main and hooks ***************************************/
tstMain: procedure expose main
/*
$=/tstMain/
### start tst tstMain #############################################
DREI
. ABC
D ABC
3 abc
1 rows fetched: select 1+2 drei, 'abc' abc from sysibm.sysDummy1
$/tstMain/
*/
call pipeIni
i = jBuf("select 1+2 drei, 'abc' abc" ,
"from sysibm.sysDummy1")
call tst t, 'tstMain'
w = tstMain1
m.w.exitCC = 0
call wshRun w, 'sqlsOut */ a', i
call tstEnd t
return
endProcedure tstMain
tstHookSqlRdr: procedure expose m.
/*
$=/tstHookSqlRdr/
### start tst tstHookSqlRdr #######################################
tstR: @tstWriteoV1 isA :Sql*2
tstR: .F5 = 5
tstR: .F2 = zwei
fatal error in wsM: SQLCODE = -104: ILLEGAL SYMBOL "?". SOME SYMBO+
LS THAT MIGHT
. BE LEGAL ARE: AT MICROSECONDS MICROSECOND SECONDS SECOND MINUT+
ES
. MINUTE HOURS
src select 2?3 f5, 'zwei' f2 from sysibm.sysDummy1
. > <<<pos 9 of 46<<<
sql = select 2?3 f5, 'zwei' f2 from sysibm.sysDummy1
stmt = prepare s10 into :M.SQL.10.D from :src
with into :M.SQL.10.D = M.SQL.10.D
sqlCode 0: rollback
from RZ4 S42 DP4G
fatal error in wsM: SQLCODE = -924: DB2 CONNECTION INTERNAL ERROR, +
00000002,
. 0000000C, 00F30006
sql = connect NODB
from RZ4 S42 NODB
$/tstHookSqlRdr/
*/
call pipeIni
call tst t, 'tstHookSqlRdr'
w = tst_wsh
m.w.outLen = 99
m.w.in = jBuf("select 2+3 f5, 'zwei' f2 from sysibm.sysDummy1")
call wshHook_sqlRdr w
m.w.in = jBuf("select 2?3 f5, 'zwei' f2 from sysibm.sysDummy1")
call wshHook_sqlRdr w
call wshHook_sqlRdr w, 'noDB'
call tstEnd t
return
endProcedure tstHookSqlRdr
/****** tstComp *******************************************************
test the wsh compiler
**********************************************************************/
tstComp: procedure expose m.
call compIni
call tstCompDataConst
call tstCompDataVars
call tstCompShell
call tstCompPrimary
call tstCompExpr
call tstCompFile
call tstCompStmt
call tstCompDir
call tstCompObj
call tstCompORun
call tstCompORu2
call tstCompORuRe
call tstCompDataIO
call tstCompPipe
call tstCompPip2
call tstCompRedir
call tstCompComp
call tstCompColon
call tstCompWithNew
call tstCompSyntax
if m.err_os == 'TSO' then
call tstCompSql
call tstTotal
return
endProcedure tstComp
tstComp1: procedure expose m.
parse arg ty nm cnt
c1 = 0
if cnt = 0 | cnt = '+' then do
c1 = cnt
cnt = ''
end
call jIni
src = jBuf()
call jOpen src, m.j.cWri
do sx=2 to arg()
call jWrite src, arg(sx)
end
call tstComp2 nm, ty, jClose(src), , c1, cnt
return
endProcedure tstComp1
tstComp2: procedure expose m.
parse arg nm, spec, src, compSt
call compIni
call tst t, nm, compSt
if src == '' then do
src = jBuf()
call tst4dp src'.BUF', mapInline(nm'Src')
end
m.t.moreOutOk = abbrev(strip(arg(5)), '+')
oldErr = m.err.count
call out 'compile' spec',' (m.src.buf.0) 'lines:' m.src.buf.1
r = wshHookComp(tstWWWW, spec, src)
noSyn = m.err.count = oldErr
coErr = m.t.err
if noSyn then
say "compiled" r ":" objMet(r, 'oRun')
else
say "*** syntaxed"
cnt = 0
do ax = 5 to max(arg(), 5) while m.t.err = coErr & noSyn
a1 = strip(arg(ax))
if a1 == '' & arg() >= 5 then
iterate
if abbrev(a1, '+') then do
m.t.moreOutOk = 1
a1 = strip(substr(a1, 2))
end
if datatype(a1, 'n') then
cnt = a1
else if a1 \== '' then
call err 'tstComp2 bad arg('ax')' arg(ax)
if cnt = 0 then do
call mCut 'T.IN', 0
call out "run without input"
end
else do
call mAdd mCut('T.IN', 0),
,"eins zwei drei", "zehn elf zwoelf?",
, "zwanzig 21 22 23 24 ... 29|"
do lx=4 to cnt
call mAdd 'T.IN', left(lx "line" lx, lx+9, '-')';'
end
call out "run with" cnt "inputs"
end
m.t.inIx = 0
call oRun r
end
call tstEnd t
return
endProcedure tstComp2
tstCompDataConst: procedure expose m.
/*
$=/tstCompDataConst/
### start tst tstCompDataConst ####################################
compile =, 8 lines: Lline one, $** asdf
run without input
. Lline one, .
line two..
line threecontinued on 4
line five fortsetzung
line six fortsetzung
$/tstCompDataConst/ */
call tstComp1 '= tstCompDataConst',
, ' Lline one, $** asdf',
, 'line two.',
, 'line three$*+ bla bla' ,
, 'continued on 4',
, 'line five $*( und so',
, 'weiter $abc $? $''$*)'' $"$*)" und weiter $*) fortsetzung',
, 'line six $*( und $*( $** $*( so',
, 'weiter $abc $? $*)'' $"$*)" und weiter $*) fortsetzung'
/*
$=/tstCompDataConstBefAftComm1/
### start tst tstCompDataConstBefAftComm1 #########################
compile =, 3 lines: $*(anfangs com.$*) $*(plus$*) $** x
run without input
the only line;
$/tstCompDataConstBefAftComm1/ */
call tstComp1 '= tstCompDataConstBefAftComm1',
, ' $*(anfangs com.$*) $*(plus$*) $** x',
, 'the only line;',
, ' $*(end kommentar$*) '
/*
$=/tstCompDataConstBefAftComm2/
### start tst tstCompDataConstBefAftComm2 #########################
compile =, 11 lines: $*(anfangs com.$*) $*(plus$*) $*+ x
run without input
the first non empty line;
tstR: @ obj null
befor an empty line with comments;
$/tstCompDataConstBefAftComm2/ */
call tstComp1 '= tstCompDataConstBefAftComm2',
, ' $*(anfangs com.$*) $*(plus$*) $*+ x',
, ' $*(forts Zeile com.$*) $*(plus$*) $** x',
, ' $*(comment 2. Zeile$*) $*(plus$*) $*+ x',
, ' $*(forts Zeile com.$*) $*(plus$*) $** x',
, 'the first non empty line;',
, ' ',
, 'befor an empty line with comments;',
, ' $*(comment 4. Zeile$*) $*(plus$*) $*+ x',
, ' $*(forts 4.Zeile com.$*) $*(plus$*) $** x',
, ' $*(end kommentar$*) $*+',
, ' $*(forts end com.$*) $*(plus$*) $** x'
return
endProcedure tstCompDataComm
tstCompDataVars: procedure expose m.
/*
$=/tstCompDataVars/
### start tst tstCompDataVars #####################################
compile =, 5 lines: Lline one, $** asdf
run without input
. Lline one, .
lline zwei output
lline 3 .
variable v1 = valueV1 ${v1}= valueV1;
. $-{""$v1} = valueV1;
$/tstCompDataVars/ */
call tstComp1 '= tstCompDataVars',
, ' Lline one, $** asdf',
, ' $$ lline zwei output',
, 'lline 3 $=v1= valueV1 ' ,
, 'variable v1 = $v1 $"${v1}=" ${ v1 }; ',
, ' $"$-{""""$v1} =" $-{$""$"v1"}; '
return
endProcedure tstCompDataVars
tstCompShell: procedure expose m.
/*
$=/tstCompShell3/
### start tst tstCompShell3 #######################################
compile @, 8 lines: call tstOut "T", "abc" $-¢2*3$! "efg"$-¢2*3$!"+
hij"
run without input
abc 6 efg6hij
insert into A540769x.tqt002 with n(n) as ( select 4 from sysibm.s
insert into A540769x.tqt002 with n(n) as ( select 4 from sysibm.s +
. union all .
abc 6 efg6hij
$/tstCompShell3/ */
call tstComp1 '@ tstCompShell3',
, 'call tstOut "T", "abc" $-¢2*3$! "efg"$-¢2*3$!"hij"',
, 'ix=3' ,
, 'call tstOut "T","insert into A540769x.tqt002" ,',
, '"with n(n) as ( select" $-¢ix+1$! "from sysibm.s"',
, 'call tstOut "T","insert into A540769x.tqt002" , ',
, '"with n(n) as ( select" $-¢ix+1$! "from sysibm.s" , ' ,
, '" union all "' ,
, '$$ abc $-¢2*3$! efg$-¢2*3$!hij',
/*
$=/tstCompShell/
### start tst tstCompShell ########################################
compile @, 12 lines: $$ Lline one, $** asdf
run without input
Lline one,
lline zwei output
v1 = valueV1 ${v1}= valueV1|
REXX OUT L5 CONTINUED L6 CONTINUED L7
L8 ONE
L9 TWO
valueV1
valueV1 valueV2
out valueV1 valueV2
SCHLUSS
$/tstCompShell/ */
call tstComp1 '@ tstCompShell',
, ' $$ Lline one, $** asdf',
, ' $$ lline zwei output',
, ' $=v1= valueV1 ' ,
, '$$ v1 = $v1 $"${v1}=" ${ v1 }| ' ,
, 'call out rexx out l5, ' ,
, ' continued l6 , ' ,
, ' continued l7 ' ,
, 'call out l8 one ' ,
, 'call out l9 two$=v2=valueV2 ',
, '$$- $v1 $$- $v1 $v2 ',
, 'call out "out " $v1 $v2 ',
, '$$- schluss '
/*
$=/tstCompShell2/
### start tst tstCompShell2 #######################################
compile @, 13 lines: $@do j=0 to 1 $@¢ $$ do j=$j
run without input
do j=0
after if 0 $@¢ $!
after if 0 $=@¢ $!
do j=1
if 1 then $@¢ a
a2
if 1 then $@=¢ b
b2
after if 1 $@¢ $!
after if 1 $=@¢ $!
end
$/tstCompShell2/ */
call tstComp1 '@ tstCompShell2',
, '$@do j=0 to 1 $@¢ $$ do j=$j' ,
, 'if $j then $@¢ ',
, '$$ if $j then $"$@¢" a $$a2' ,
, '$!',
, 'if $j then $@=¢ ',
, '$$ if $j then $"$@=¢" b $$b2' ,
, '$!',
, 'if $j then $@¢ $!' ,
, '$$ after if $j $"$@¢ $!"' ,
, 'if $j then $@=¢ $!' ,
, '$$ after if $j $"$=@¢ $!"' ,
, '$!',
, '$$ end'
return
endProcedure tstCompShell
tstCompPrimary: procedure expose m.
call compIni
/*
$=/tstCompPrimary/
### start tst tstCompPrimary ######################################
compile =, 16 lines: Strings $"$""$""""$""" $'$''$''''$'''
run without input
Strings $"$""$" $'$''$'
rexx $-¢ 3 * 5 $! = 15
rexx $-¢ 5 * 7 $! = 35
rexx $-// 7 * 11 $// = 77
rexx $-/abcEf/ 11 * 13 $/abcEf/ = 143
data line three line four bis hier
shell line five line six bis hier
var get v1 value Eins, v1 value Eins
var isDef v1 1, v2 0
#jIn eof 1#
var read >1 0 rr undefined
#jIn eof 2#
var read >2 0 rr undefined
no call abc$-¢4*5$! $-¢efg$-¢6*7$! abc20 EFG42
brackets $-¢$-¢1+9$!*$-¢7+3$!*$-/b/5+5$/b/$! 1000
run with 3 inputs
Strings $"$""$" $'$''$'
rexx $-¢ 3 * 5 $! = 15
rexx $-¢ 5 * 7 $! = 35
rexx $-// 7 * 11 $// = 77
rexx $-/abcEf/ 11 * 13 $/abcEf/ = 143
data line three line four bis hier
shell line five line six bis hier
var get v1 value Eins, v1 value Eins
var isDef v1 1, v2 0
#jIn 1# eins zwei drei
var read >1 1 rr eins zwei drei
#jIn 2# zehn elf zwoelf?
var read >2 1 rr zehn elf zwoelf?
no call abc$-¢4*5$! $-¢efg$-¢6*7$! abc20 EFG42
brackets $-¢$-¢1+9$!*$-¢7+3$!*$-/b/5+5$/b/$! 1000
$/tstCompPrimary/ */
call vRemove 'v2'
call tstComp1 '= tstCompPrimary 3',
, 'Strings $"$""$""""$"""' "$'$''$''''$'''",
, 'rexx $"$-¢ 3 * 5 $! =" $-¢ 3 * 5 $!' ,
, 'rexx $"$-¢ 5 * 7 $! =" $-¢ 5 * 7 $!' ,
, 'rexx $"$-// 7 * 11 $// =" $-// 7 * 11 $//' ,
, 'rexx $"$-/abcEf/ 11 * 13 $/abcEf/ ="',
'$-/abcEf/ 11 * 13 $/abcEf/' ,
, 'data $-=¢ line three',
, 'line four $! bis hier' ,
, 'shell $-@¢ $$ line five',
, '$$ line six $! bis hier' ,
, '$= v1 = value Eins $=rr=undefined $= eins = 1 ',
, 'var get v1 $v1, v1 ${ v1 } ',
, 'var isDef v1 ${? v${ eins } }, v2 ${?v2 } ',
, 'var read >1 ${> rr} rr $rr' ,
, 'var read >2 ${> rr} rr $rr',
, 'no call $"abc$-¢4*5$! $-¢efg$-¢6*7$!"',
'abc$-¢4*5$! $-¢efg$-¢6*7$!$!',
, 'brackets $"$-¢$-¢1+9$!*$-¢7+3$!*$-/b/5+5$/b/$!"',
'$-¢$-¢1+9$!*$-¢7+3$!*$-/b/5+5$/b/$!'
return
endProcedure tstCompPrimary
tstCompExpr: procedure expose m.
call compIni
/*
$=/tstCompExprStr/
### start tst tstCompExprStr ######################################
compile -, 3 lines: $=vv=vvStr
run without input
vv=vvStr
o2String($.-vv)=vvStr
$/tstCompExprStr/ */
call tstComp1 '- tstCompExprStr',
, '$=vv=vvStr' ,
, '"vv="$vv' ,
, '$"o2String($.-vv)="o2String($.-vv)'
/*
$=/tstCompExprObj/
### start tst tstCompExprObj ######################################
compile ., 5 lines: $=vv=vvStr
run without input
vv=
vvStr
s2o($.vv)=
vvStr
$/tstCompExprObj/ */
call tstComp1 '. tstCompExprObj',
, '$=vv=vvStr' ,
, '"!vv="', '$.-vv',
, '$."s2o($.vv)="', 's2o($-vv)'
/*
$=/tstCompExprDat/
### start tst tstCompExprDat ######################################
compile =, 4 lines: $=vv=vvDat
run without input
vv=vvDat
$.-vv= !vvDat
$.-¢"abc"$!=!abc
$/tstCompExprDat/ */
call tstComp1 '= tstCompExprDat',
, '$=vv=vvDat' ,
, 'vv=$vv',
, '$"$.-vv=" $.-vv',
, '$"$.-¢""abc""$!="$.-¢"abc"$!'
/*
$=/tstCompExprRun/
### start tst tstCompExprRun ######################################
compile @, 3 lines: $=vv=vvRun
run without input
vv=vvRun
o2string($.-vv)=vvRun
$/tstCompExprRun/ */
call tstComp1 '@ tstCompExprRun',
, '$=vv=vvRun' ,
, 'call out "vv="$vv',
, 'call out $"o2string($.-vv)="o2string($.-vv)'
/*
$=/tstCompExprCon/
### start tst tstCompExprCon ######################################
compile #, 2 lines: $$ in # drinnen
run without input
$$ in # drinnen
call out "vv="$vv
$/tstCompExprCon/
$=/tstCompExprCo2/
### start tst tstCompExprCo2 ######################################
compile #, 3 lines: $$ in # drinnen
run without input
$$ in # drinnen
call out "vv="$vv
nacgh $#@
$/tstCompExprCo2/
*/
call tstComp1 '# tstCompExprCon',
, '$$ in # drinnen' ,
, 'call out "vv="$vv'
call tstComp1 '# tstCompExprCo2',
, '$$ in # drinnen' ,
, 'call out "vv="$vv',
, '$#@ $$ nacgh $"$#@"'
return
endProcedure tstCompExpr
tstCompStmt: procedure expose m.
/*
$=/tstCompStmt1/
### start tst tstCompStmt1 ########################################
compile @, 8 lines: $= v1 = value eins $= v2 =- 3*5*7 .
run without input
data v1 value eins v2 105
eins
zwei
drei
vier
fuenf
elf
. zwoelf dreiZ .
. vierZ .
fuenfZ
lang v1 value eins v2 945
oRun ouput 1
$/tstCompStmt1/ */
call pipeIni
call compIni
call vPut 'oRun', oRunner('call out "oRun ouput" (1*1)')
call vRemove 'v2'
call tstComp1 '@ tstCompStmt1',
, '$= v1 = value eins $= v2 =- 3*5*7 ',
, '$$ data v1 $v1 v2 ${ v2 }',
, '$$eins $@¢$$ zwei $$ drei ',
, ' $@¢ $! $@// $// $@/q r s / $/q r s /',
' $@/eins/ $@¢ $$vier $! $/eins/ $! $$fuenf',
, '$$elf $@=¢$@=¢ zwoelf dreiZ $! ',
, ' $@=¢ $! $@=¢ $@=¢ vierZ $! $! $! $$fuenfZ',
, '$$- "lang v1" $v1 "v2" ${v2}*9',
, '$@oRun'
/*
$=/tstCompStmt2/
### start tst tstCompStmt2 ########################################
compile @, 1 lines: $@for qq $$ loop qq $qq
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
loop qq eins zwei drei
#jIn 2# zehn elf zwoelf?
loop qq zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
loop qq zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
$/tstCompStmt2/ */
call tstComp1 '@ tstCompStmt2 3',
, '$@for qq $$ loop qq $qq'
/*
$=/tstCompStmt3/
### start tst tstCompStmt3 ########################################
compile @, 9 lines: $$ 1 begin run 1
2 ct zwei
ct 4 mit assign .
run without input
1 begin run 1
3 run 3 ctV = ct 4 assign ctV|
run 5 procCall $@prCa
out in proc at 8
run 6 vor call $@prCa
out in proc at 8
9 run end
run with 3 inputs
1 begin run 1
3 run 3 ctV = ct 4 assign ctV|
run 5 procCall $@prCa
out in proc at 8
run 6 vor call $@prCa
out in proc at 8
9 run end
$/tstCompStmt3/ */
call tstComp1 '@ tstCompStmt3 3',
, '$$ 1 begin run 1',
, '$@ct $$ 2 ct zwei',
, '$$ 3 run 3 ctV = $ctV|',
, '$@ct $@=¢ct 4 mit assign $=ctV = ct 4 assign ctV $!',
, '$$ run 5 procCall $"$@prCa" $@prCa',
, '$$ run 6 vor call $"$@prCa"',
, '$@prCa',
, '$@proc prCa $$out in proc at 8',
, '$$ 9 run end'
/*
$=/tstCompStmt4/
### start tst tstCompStmt4 ########################################
compile @, 4 lines: $=eins=vorher
run without input
eins vorher
eins aus named block eins .
$/tstCompStmt4/ */
call tstComp1 '@ tstCompStmt4 0',
, '$=eins=vorher' ,
, '$$ eins $eins' ,
, '$=/eins/aus named block eins $/eins/' ,
, '$$ eins $eins'
/*
$=/tstCompStmtDo/
### start tst tstCompStmtDo #######################################
compile @, 2 lines: ti=0$@do y=3 to 4 $@do 2 $@¢
run without input
y=3 ti1 z=7
y=3 ti1 z=8
y=3 ti2 z=7
y=3 ti2 z=8
y=4 ti3 z=7
y=4 ti3 z=8
y=4 ti4 z=7
y=4 ti4 z=8
$/tstCompStmtDo/ */
call tstComp1 '@ tstCompStmtDo', 'ti=0$@do y=3 to 4 $@do 2 $@¢',
, 'ti = ti + 1',
'$@do $*(sdf$*) z $*(sdf$*) =7 to 8 $$ y=$y ti$-¢ti$! z=$z $!'
/*
$=/tstCompStmtDo2/
### start tst tstCompStmtDo2 ######################################
compile @, 7 lines: $$ $-=/sqlSel/
run without input
select 1 abc select 2 abc after table .
$/tstCompStmtDo2/ */
call tstComp1 '@ tstCompStmtDo2',
, '$$ $-=/sqlSel/',
, '$=ty = abc ',
, '$@do tx=1 to 2 $@=/table/',
, 'select $tx $ty',
, '$/table/',
, '$=ty = abc',
, 'after table',
'$/sqlSel/'
/*
$=/tstCompStmtWith/
### start tst tstCompStmtWith #####################################
compile @, 3 lines: $@with $.vA $$ fEins=$FEINS fZwei=$FZWEI va&fEi+
ns=${vA&FEINS}
run without input
fEins=1Eins fZwei=1Zwei va&fEins=1Eins
fEins=1Eins fZwei=1Zwei va&fEins=1Eins
fEins=2Eins fZwei=2Zwei va&fEins=1Eins
fEins=1Eins fZwei=1Zwei va&fEins=1Eins
$/tstCompStmtWith/
*/
cl = classNew('n? tstStmtWith u f FEINS v, f FZWEI v')
v1 = onew(cl)
m.v1.feins = '1Eins'
m.v1.fzwei = '1Zwei'
v2 = oNew(cl)
m.v2.feins ='2Eins'
m.v2.fzwei ='2Zwei'
call vPut 'vA', v1
call vPut 'vB', v2
stmt = '$$ fEins=$FEINS fZwei=$FZWEI va&fEins=${vA&FEINS}'
call tstComp1 '@ tstCompStmtWith',
, '$@with $.vA' stmt ,
, '$@with $vA $@¢' stmt ,
, '$@with $vB ' stmt stmt '$!'
/*
$=/tstCompStmtArg/
### start tst tstCompStmtArg ######################################
compile :, 11 lines: v2 = var2
run without input
a1=eins a2=zwei, a3=elf b1= b2=
after op= v2=var2 var2=zwei,
a1=EINS a2=ZWEI a3= b1=ELF b2=
after op=- v2=var2 var2=ZWEI
a1=EINS a2=ZWEI a3= b1=ELF b2=
after op=. v2=var2 var2=ZWEI
$/tstCompStmtArg/
*/
call tstComp1 ': tstCompStmtArg',
, 'v2 = var2',
, '@% outArg eins zwei, elf',
, '$$ after op= v2=$v2 var2=$var2',
, '@% outArg - eins zwei, elf',
, '$$ after op=- v2=$v2 var2=$var2',
, '@% outArg . eins zwei, elf',
, '$$ after op=. v2=$v2 var2=$var2',
, 'proc $@:/outArg/' ,
, 'arg a1 {$v2} a3, b1 b2',
, '$$ a1=$a1 a2=${$v2} a3=$a3 b1=$b1 b2=$b2' ,
, '$/outArg/'
cl = classNew('n? tstStmtWith u f FEINS v, f FZWEI v')
return
endProcedure tstCompStmt
tstCompProc: procedure expose m.
/*
$=/tstCompProc1/
### start tst tstCompProc1 ########################################
compile =, 11 lines: $$ vor1
run without input
vor1
called p1 eins
vor2
tstR: @ obj null
vor3
. called p3 drei
vor4
. called p2 .
vor9 endof
$/tstCompProc1/ */
call pipeIni
call compIni
call tstComp1 '= tstCompProc1',
, "$$ vor1",
, "$@% p1 eins $$vor2 $@% p2 zwei $$vor3 $@% p3 drei",
, "$$ vor4 $proc p1 $$- 'called p1' arg(2)",
, "$proc p2", " ", "$** a", "$*(b$*) called p2 $-¢arg(2)$!",
, "$proc p3 ", "$** a", " $*(b$*) called p3 $-¢arg(2)$!",
, "$$ vor9 endof"
return
endProcedure tstCompProc
tstCompSyntax: procedure expose m.
call pipeIni
call tstCompSynPrimary
call tstCompSynAss
call tstCompSynRun
return
endProcedure tstCompSyntax
tstCompSynPrimary: procedure expose m.
/*
$=/tstCompSynPri1/
### start tst tstCompSynPri1 ######################################
compile @, 1 lines: a $ =
*** err: scanErr wsh kindExe'@' expected: compile stopped before en+
d of input
. e 1: last token scanPosition $ =
. e 2: pos 3 in line 1: a $ =
$/tstCompSynPri1/ */
call tstComp1 '@ tstCompSynPri1 +', 'a $ ='
/*
$=/tstCompSynPri2/
### start tst tstCompSynPri2 ######################################
compile @, 1 lines: a $. {
*** err: scanErr primary block or expression expected expected
. e 1: last token scanPosition . {
. e 2: pos 4 in line 1: a $. {
*** err: scanErr primary block or expression expected expected
. e 1: last token scanPosition . {
. e 2: pos 4 in line 1: a $. {
*** err: scanErr wsh kindExe'@' expected: compile stopped before en+
d of input
. e 1: last token scanPosition $. {
. e 2: pos 3 in line 1: a $. {
$/tstCompSynPri2/ */
call tstComp1 '@ tstCompSynPri2 +', 'a $. {'
/*
$=/tstCompSynPri3/
### start tst tstCompSynPri3 ######################################
compile @, 1 lines: b $- ¢ .
*** err: scanErr primary block or expression expected expected
. e 1: last token scanPosition - ¢
. e 2: pos 4 in line 1: b $- ¢
*** err: scanErr primary block or expression expected expected
. e 1: last token scanPosition - ¢
. e 2: pos 4 in line 1: b $- ¢
*** err: scanErr wsh kindExe'@' expected: compile stopped before en+
d of input
. e 1: last token scanPosition $- ¢
. e 2: pos 3 in line 1: b $- ¢
$/tstCompSynPri3/ */
call tstComp1 '@ tstCompSynPri3 +', 'b $- ¢ '
/*
$=/tstCompSynPri4/
### start tst tstCompSynPri4 ######################################
compile @, 1 lines: a ${ $*( sdf$*) } =
*** err: scanErr var name expected
. e 1: last token scanPosition } =
. e 2: pos 17 in line 1: a ${ $*( sdf$*) } =
$/tstCompSynPri4/ */
call tstComp1 '@ tstCompSynPri4 +', 'a ${ $*( sdf$*) } ='
/*
$=/tstCompSynFile/
### start tst tstCompSynFile ######################################
compile @, 1 lines: $@.<$*( co1 $*) $$abc
*** err: scanErr primary, block or expression expected
. e 1: last token scanPosition .<$*( co1 $*) $$abc
. e 2: pos 3 in line 1: $@.<$*( co1 $*) $$abc
*** err: scanErr wsh kindExe'@' expected: compile stopped before en+
d of input
. e 1: last token scanPosition $@.<$*( co1 $*) $$abc
. e 2: pos 1 in line 1: $@.<$*( co1 $*) $$abc
$/tstCompSynFile/ */
call tstComp1 '@ tstCompSynFile +', '$@.<$*( co1 $*) $$abc'
return
endProcedure tstCompSynPrimary
tstCompSynAss: procedure expose m.
/*
$=/tstCompSynAss1/
### start tst tstCompSynAss1 ######################################
compile @, 1 lines: $=
*** err: scanErr block or expression in assignment after $= expecte+
d
. e 1: last token scanPosition .
. e 2: pos 3 in line 1: $=
$/tstCompSynAss1/ */
call tstComp1 '@ tstCompSynAss1 +', '$='
/*
$=/tstCompSynAss2/
### start tst tstCompSynAss2 ######################################
compile @, 2 lines: $= .
*** err: scanErr block or expression in assignment after $= expecte+
d
. e 1: last token scanPosition .
. e 2: pos 3 in line 1: $=
$/tstCompSynAss2/ */
call tstComp1 '@ tstCompSynAss2 +', '$= ', 'eins'
/*
$=/tstCompSynAss3/
### start tst tstCompSynAss3 ######################################
compile @, 2 lines: $= $$
*** err: scanErr block or expression in assignment after $= expecte+
d
. e 1: last token scanPosition $$
. e 2: pos 6 in line 1: $= $$
$/tstCompSynAss3/ */
call tstComp1 '@ tstCompSynAss3 +', '$= $$', 'eins'
/*
$=/tstCompSynAss4/
### start tst tstCompSynAss4 ######################################
compile @, 1 lines: $= eins
*** err: scanErr wsh kindExe'@' expected: compile stopped before en+
d of input
. e 1: last token scanPosition $= eins
. e 2: pos 1 in line 1: $= eins
$/tstCompSynAss4/ */
call tstComp1 '@ tstCompSynAss4 +', '$= eins'
/*
$=/tstCompSynAss5/
### start tst tstCompSynAss5 ######################################
compile @, 1 lines: $= abc eins $$ = x
*** err: scanErr wsh kindExe'@' expected: compile stopped before en+
d of input
. e 1: last token scanPosition $= abc eins $$ = x
. e 2: pos 1 in line 1: $= abc eins $$ = x
$/tstCompSynAss5/
$=/tstCompSynAss5old/
### start tst tstCompSynAss5 ######################################
compile @, 1 lines: $= abc eins $$ = x
*** err: scanErr = expected in assignment after $= var
. e 1: last token scanPosition eins $$ = x
. e 2: pos 9 in line 1: $= abc eins $$ = x
$/tstCompSynAss5old/ */
call tstComp1 '@ tstCompSynAss5 +', '$= abc eins $$ = x'
/*
$=/tstCompSynAss6/
### start tst tstCompSynAss6 ######################################
compile @, 1 lines: $= abc =
*** err: scanErr block or expression in assignment after $= expecte+
d
. e 1: last token scanPosition .
. e 2: pos 10 in line 1: $= abc =
$/tstCompSynAss6/ */
call tstComp1 '@ tstCompSynAss6 +', '$= abc ='
/*
$=/tstCompSynAss7/
### start tst tstCompSynAss7 ######################################
compile @, 1 lines: $= abc =..
*** err: scanErr block or expression in assignment after $= expecte+
d
. e 1: last token scanPosition .
. e 2: pos 11 in line 1: $= abc =..
$/tstCompSynAss7/ */
call tstComp1 '@ tstCompSynAss7 +', '$= abc =.'
return
endProcedure tstCompSynAss
tstCompSynRun: procedure expose m.
/*
$=/tstCompSynRun1/
### start tst tstCompSynRun1 ######################################
compile @, 1 lines: $@
*** err: scanErr primary, block or expression expected
. e 1: last token scanPosition .
. e 2: pos 3 in line 1: $@
*** err: scanErr wsh kindExe'@' expected: compile stopped before en+
d of input
. e 1: last token scanPosition $@
. e 2: pos 1 in line 1: $@
$/tstCompSynRun1/ */
call tstComp1 '@ tstCompSynRun1 +', '$@'
/*
$=/tstCompSynRun2/
### start tst tstCompSynRun2 ######################################
compile @, 1 lines: $@=
*** err: scanErr primary, block or expression expected
. e 1: last token scanPosition =
. e 2: pos 3 in line 1: $@=
*** err: scanErr wsh kindExe'@' expected: compile stopped before en+
d of input
. e 1: last token scanPosition $@=
. e 2: pos 1 in line 1: $@=
$/tstCompSynRun2/ */
call tstComp1 '@ tstCompSynRun2 +', '$@='
/*
$=/tstCompSynRun3/
### start tst tstCompSynRun3 ######################################
compile @, 1 lines: $@: und
*** err: scanErr bad kind : in compExpr
. e 1: last token scanPosition und
. e 2: pos 5 in line 1: $@: und
fatal error in wsM: compAst2rx bad ops=!) kind=M.0.KIND ast=0
*** err: bad ast 0
*** err: compAst2rx bad ops=!) kind=M.0.KIND ast=0
$/tstCompSynRun3/ */
call tstComp1 '@ tstCompSynRun3 +', '$@: und'
/*
$=/tstCompSynFor4/
### start tst tstCompSynFor4 ######################################
compile @, 1 lines: $@for
*** err: scanErr var? statement after for expected
. e 1: last token scanPosition .
. e 2: atEnd after line 1: $@for
$/tstCompSynFor4/ */
call tstComp1 '@ tstCompSynFor4 +', '$@for'
/*
$=/tstCompSynFor5/
### start tst tstCompSynFor5 ######################################
compile @, 2 lines: $@for
*** err: scanErr var? statement after for expected
. e 1: last token scanPosition .
. e 2: pos 6 in line 1: $@for
$/tstCompSynFor5/
call tstComp1 '@ tstCompSynFor5 +', '$@for', a
$=/tstCompSynFor6/
### start tst tstCompSynFor6 ######################################
compile @, 2 lines: a
*** err: scanErr variable or named block after for
. e 1: last token scanPosition .
. e 2: pos 15 in line 2: b $@for $$q
$/tstCompSynFor6/
call tstComp1 '@ tstCompSynFor6 +', 'a', ' b $@for $$q'
*/
/*
$=/tstCompSynFor7/
### start tst tstCompSynFor7 ######################################
compile @, 3 lines: a
*** err: scanErr var? statement after for expected
. e 1: last token scanPosition .
. e 2: pos 11 in line 2: b $@for a
$/tstCompSynFor7/
call tstComp1 '@ tstCompSynFor7 +', 'a', ' b $@for a', ' $$q'
$=/tstCompSynCt8/
### start tst tstCompSynCt8 #######################################
compile @, 3 lines: a
*** err: scanErr ct statement expected
. e 1: last token scanPosition .
. e 2: atEnd after line 3: .
$/tstCompSynCt8/ */
call tstComp1 '@ tstCompSynCt8 +', 'a', ' b $@ct', ' '
/*
$=/tstCompSynProc9/
### start tst tstCompSynProc9 #####################################
compile @, 3 lines: a
*** err: scanErr proc statement expected
. e 1: last token scanPosition .
. e 2: atEnd after line 3: $**x
$/tstCompSynProc9/ */
call tstComp1 '@ tstCompSynProc9 +', 'a', ' b $@proc ' , '$**x'
/*
$=/tstCompSynProcA/
### start tst tstCompSynProcA #####################################
compile @, 2 lines: $@proc p1
*** err: scanErr proc statement expected
. e 1: last token scanPosition .
. e 2: pos 10 in line 1: $@proc p1
$/tstCompSynProcA/
call tstComp1 '@ tstCompSynProcA +', '$@proc p1', '$$'
$=/tstCompSynCallB/
### start tst tstCompSynCallB #####################################
compile @, 1 lines: $@% ¢roc p1$!
*** err: scanErr primary, block or expression expected
. e 1: last token scanPosition % ¢roc p1$!
. e 2: pos 3 in line 1: $@% ¢roc p1$!
*** err: scanErr wsh kindExe'@' expected: compile stopped before en+
d of input
. e 1: last token scanPosition $@% ¢roc p1$!
. e 2: pos 1 in line 1: $@% ¢roc p1$!
$/tstCompSynCallB/ */
call tstComp1 '@ tstCompSynCallB +', '$@% ¢roc p1$!'
/*
$=/tstCompSynCallC/
### start tst tstCompSynCallC #####################################
compile @, 1 lines: $@%¢call roc p1 !
*** err: scanErr ending $! expected after ¢
. e 1: last token scanPosition .
. e 2: atEnd after line 1: $@%¢call roc p1 !
$/tstCompSynCallC/ */
call tstComp1 '@ tstCompSynCallC +', '$@%¢call roc p1 !'
/*
$=/tstCompSynCallD/
### start tst tstCompSynCallD #####################################
compile @, 2 lines: $@^¢call( $** roc
*** err: scanErr ending $! expected after ¢
. e 1: last token scanPosition )
. e 2: pos 13 in line 2: $*( p1 $*) )
$/tstCompSynCallD/ */
call tstComp1 '@ tstCompSynCallD +',
,'$@^¢call( $** roc' , ' $*( p1 $*) )'
return
endProcedure tstCompSynRun
tstCompObj: procedure expose m.
call tstReset t
call classIni
cl = classNew('n? tstCompCla u v, f FEINS v, f FZWEI v')
do rx=1 to 10
o = oNew(cl)
m.tstComp.rx = o
m.o = 'o'rx
if rx // 2 = 0 then do
m.o.fEins = 'o'rx'.1'
m.o.fZwei = 'o'rx'.fZwei'rx
end
else do
m.o.fEins = 'o'rx'.fEins'
m.o.fZwei = 'o'rx'.2'
end
call mAdd 'T.TRANS', m.tstComp.rx '<o'rx'>'
end
/*
$=/tstCompObjRef/
### start tst tstCompObjRef #######################################
compile @, 13 lines: o1=m.tstComp.1
run without input
out .$"string" o1
string
out . o1
tstR: @<o1> isA :tstCompCla = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
out .{ o2 }
tstR: @<o2> isA :tstCompCla = o2
tstR: .FEINS = o2.1
tstR: .FZWEI = o2.fZwei2
out .¢ o3 $!
tstR: @<o3> isA :tstCompCla = o3
tstR: .FEINS = o3.fEins
tstR: .FZWEI = o3.2
out .¢ o4 $!
tstR: @<o4> isA :tstCompCla = o4
tstR: .FEINS = o4.1
tstR: .FZWEI = o4.fZwei4
out ./-/ o5 $/-/
tstR: @<o5> isA :tstCompCla = o5
tstR: .FEINS = o5.fEins
tstR: .FZWEI = o5.2
$/tstCompObjRef/ */
m.ttt=1
call tstComp1 '@ tstCompObjRef' ,
, 'o1=m.tstComp.1',
, 'o2 = m.tstComp.2' ,
, '$$ out $".$""string""" o1 $$."string"',
, '$$ out . o1 $$. o1',
, '$$ out .{ o2 } $$.¢ o2 $!',
, '$$ out .¢ o3 $"$!" $$.¢ ', ' m.tstComp.3 ', ' $!',
, '$$ out .¢ o4 $"$!" $$.¢ ', ' m.tstComp.4 ', ' $!',
, '$$ out ./-/ o5 $"$/-/" $$./-/ m.tstComp.5 ', ' $/-/'
/*
$=/tstCompObjRefPri/
### start tst tstCompObjRefPri ####################################
compile @, 9 lines: $$ out .$"$.{o1}" $$.¢ m.tstComp.1 $!
run without input
out .$.{o1}
tstR: @<o1> isA :tstCompCla = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
out .$.-{o2}
<o2>
out .$.={o3}
. m.tstComp.3 .
out .$.@{out o4}
tstWriteO kindOf ORun oRun begin <<<
tstR: @<o4> isA :tstCompCla = o4
tstR: .FEINS = o4.1
tstR: .FZWEI = o4.fZwei4
tstWriteO kindOf ORun oRun end >>>
out .$.@¢$$abc $$efg$!
tstWriteO kindOf ORun oRun begin <<<
abc
efg
tstWriteO kindOf ORun oRun end >>>
out .$.@¢o5$!
tstWriteO kindOf ORun oRun begin <<<
tstR: @<o5> isA :tstCompCla = o5
tstR: .FEINS = o5.fEins
tstR: .FZWEI = o5.2
abc
tstWriteO kindOf ORun oRun end >>>
$/tstCompObjRefPri/ */
call tstComp1 '@ tstCompObjRefPri' ,
, '$$ out .$"$.{o1}" $$.¢ m.tstComp.1 $!',
, '$$ out .$"$.-{o2}" $$.-¢ m.tstComp.2 $!',
, '$$ out .$"$.={o3}" $$.=¢ m.tstComp.3 $!',
, '$$ out .$"$.@{out o4}" $$.@@¢ call out m.tstComp.4 $!',
, '$$ out .$"$.@¢$$abc $$efg$!" $$. $.@@¢ $$abc ', ' ',' $$efg $!',
, '$$ out .$"$.@¢o5$!" $$. $.@@¢ $$. m.tstComp.5', '$$abc $!'
/*
$=/tstCompObjRefFile/
### start tst tstCompObjRefFile ###################################
compile @, 7 lines: $$ out .$".<.¢o1!" $$.<.¢ m.tstComp.1 $!
run without input
out ..<.¢o1!
tstWriteO kindOf JRW jWriteNow begin <<<
tstR: @<o1> isA :tstCompCla = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
tstWriteO kindOf JRW jWriteNow end >>>
out .<$.-{o2}
tstWriteO kindOf JRW jWriteNow begin <<<
tstR: @<o2> isA :tstCompCla = o2
tstR: .FEINS = o2.1
tstR: .FZWEI = o2.fZwei2
tstWriteO kindOf JRW jWriteNow end >>>
out .$.<{o3}
tstWriteO kindOf JRW jWriteNow begin <<<
. m.tstComp.3 .
tstWriteO kindOf JRW jWriteNow end >>>
out .$.<@{out o4}
tstWriteO kindOf JRW jWriteNow begin <<<
tstR: @<o4> isA :tstCompCla = o4
tstR: .FEINS = o4.1
tstR: .FZWEI = o4.fZwei4
tstWriteO kindOf JRW jWriteNow end >>>
out .$<@¢$$abc $$efg$!
tstWriteO kindOf JRW jWriteNow begin <<<
abc
efg
tstWriteO kindOf JRW jWriteNow end >>>
$/tstCompObjRefFile/ */
call tstComp1 '@ tstCompObjRefFile' ,
, '$$ out .$".<.¢o1!" $$.<.¢ m.tstComp.1 $!',
, '$$ out .$"<$.-{o2}" $$<.¢ m.tstComp.2 $!',
, '$$ out .$"$.<{o3}" $$<=¢ m.tstComp.3 $!',
, '$$ out .$"$.<@{out o4}" $$<@¢ call out m.tstComp.4 $!',
, '$$ out .$"$<@¢$$abc $$efg$!" $$<@¢ $$abc ', ' ', ' $$efg $!'
/*
$=/tstCompObjFor/
### start tst tstCompObjFor #######################################
compile @, 2 lines: $@do rx=1 to 3 $$. m.tstComp.rx
run without input
FEINS=o1.fEins FZWEI=o1.2
FEINS=o2.1 FZWEI=o2.fZwei2
FEINS=o3.fEins FZWEI=o3.2
$/tstCompObjFor/
*/
call tstComp1 '@ tstCompObjFor' ,
, '$@do rx=1 to 3 $$. m.tstComp.rx' ,
, '$| $@forWith witx $$ FEINS=$FEINS FZWEI=$FZWEI'
/*
$=/tstCompObjRun/
### start tst tstCompObjRun #######################################
compile @, 4 lines: $$ out .$"$@¢o1!" $$@¢ $$. m.tstComp.1 $!
run without input
out .$@¢o1!
tstWriteO kindOf ORun oRun begin <<<
tstR: @<o1> isA :tstCompCla = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
tstWriteO kindOf ORun oRun end >>>
out .$<@¢$$abc $$efg$!
tstWriteO kindOf JRW jWriteNow begin <<<
abc
efg
tstWriteO kindOf JRW jWriteNow end >>>
$/tstCompObjRun/ */
call tstComp1 '@ tstCompObjRun' ,
, '$$ out .$"$@¢o1!" $$@¢ $$. m.tstComp.1 $!',
, '$$ out .$"$<@¢$$abc $$efg$!" $$<@¢ $$abc ', ' ', ' $$efg $!'
m.t.trans.0 = 0
/*
$=/tstCompObj/
### start tst tstCompObj ##########################################
compile @, 6 lines: o1=m.tstComp.1
run without input
out . o1
tstR: @tstWriteoV1 isA :tstCompCla = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
out .{ o2 }
tstR: @tstWriteoV2 isA :tstCompCla = o2
tstR: .FEINS = o2.1
tstR: .FZWEI = o2.fZwei2
out .¢ o1, o2!
tstR: @tstWriteoV1 isA :tstCompCla = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
tstR: @tstWriteoV2 isA :tstCompCla = o2
tstR: .FEINS = o2.1
tstR: .FZWEI = o2.fZwei2
$/tstCompObj/ */
call tstComp1 '@ tstCompObj' ,
, 'o1=m.tstComp.1',
, 'o2 = m.tstComp.2' ,
, '$$ out . o1 $$. o1',
, '$$ out .{ o2 } $$.¢ o2 $!',
, '$$ out .¢ o1, o2!$; $@.¢ m.tstComp.1 ', ' m.tstComp.2 $!'
return
m.t.trans.0 = 0
endProcedure tstCompObj
tstCompORun: procedure expose m.
/*
$=/tstCompORun/
### start tst tstCompORun #########################################
compile @, 6 lines: $@oRun
run without input
oRun arg=1, v2=, v3=, v4=
oRun arg=1, v2=, v3=, v4=
oRun arg=2, v2=-{1 arg only} oder?, v3=, v4=
oRun arg=2, v2=!.{1 obj only} oder?, v3=, v4=
oRun arg=3, v2={2 args}, v3=und zwei?, v4=
oRun arg=4, v2={3 args}, v3=zwei, v4=und drei?
$/tstCompORun/ */
call compIni
call vPut 'oRun', oRunner('parse arg , v2, v3, v4;',
'call tstOut t, "oRun arg="arg()", v2="v2", v3="v3", v4="v4' )
call tstComp1 '@ tstCompORun',
, '$@oRun', '$@%¢oRun$!' ,
, ' $@%¢oRun $"-{1 arg only}" oder?$!' ,
, ' $@%¢oRun - $.".{1 obj only}" ''oder?''$! $=v2=zwei' ,
, ' $@%¢oRun - $"{2 args}", "und" $v2"?"$!' ,
, ' $@%¢oRun - $"{3 args}", $v2, "und drei?"$!'
return
endProcedure tstCompORun
tstCompORu2: procedure expose m.
/*
$=/tstCompORu2/
### start tst tstCompORu2 #########################################
compile @, 6 lines: $@oRun
run without input
oRun arg=1, v2=, v3=, v4=
oRun arg=1, v2=, v3=, v4=
oRun arg=2, v2=eins, zwei, drei, v3=, v4=
oRun arg=2, v2=eins, zwei, drei, v3=, v4=
oRun arg=4, v2=-eins, v3=zwei, v4=DREI
oRun arg=4, v2=-eins, v3=zwei, v4=DREI
$/tstCompORu2/ */
call compIni
call vPut 'oRun', oRunner('parse arg , v2, v3, v4;',
'call tstOut t, "oRun arg="arg()", v2="v2", v3="v3", v4="v4' )
call tstComp1 '@ tstCompORu2',
, '$@oRun', '$@%oRun',
, '$@% oRun eins, zwei, drei' ,
, '$@%¢ oRun eins, zwei, drei $!',
, '$@% oRun - "-eins", "zwei", drei' ,
, '$@%¢ oRun - "-eins", "zwei", drei $!'
return
endProcedure tstCompORu2
tstCompORuRe: procedure expose m.
/*
$=/tstCompORuRe/
### start tst tstCompORuRe ########################################
compile @, 9 lines: $$ primary $-^oRuRe eins, zwei
run without input
primary oRuRe(arg=1, v2=, v3=) eins, zwei
oRuRe(arg=2, v2=expr, zwei, v3=)
oRuRe(arg=3, v2=-expr, v3=zwei)
oRuRe(arg=2, v2=block, zwei, v3=)
oRuRe(arg=3, v2=-block, v3=zwei)
$/tstCompORuRe/ */
call compIni
call vPut 'oRuRe', oRunner('parse arg , v2, v3;',
'return "oRuRe(arg="arg()", v2="v2", v3="v3")"' )
call tstComp1 '@ tstCompORuRe',
, '$$ primary $-^oRuRe eins, zwei' ,
, '$$-^ oRuRe expr, zwei',
, '$$-^ oRuRe - "-expr", "zwei"',
, '$$-^¢oRuRe block, zwei$!' ,
, '$$-^¢',, 'oRuRe - "-block", "zwei"' , , '$!'
return
endProcedure tstCompORuRe
tstCompDataIO: procedure expose m.
/*
$=/tstCompDataHereData/
### start tst tstCompDataHereData #################################
compile =, 13 lines: herdata $@#/stop/ .
run without input
. herdata .
heredata 1 $x
heredata 2 $y
nach heredata
. herdata ¢ .
heredata 1 xValue
heredata 2 yValueY
nach heredata ¢
. herdata { .
HEREDATA 1 xValue
heredata 2 yValueY
nach heredata {
$/tstCompDataHereData/ */
call tstComp1 '= tstCompDataHereData',
, ' herdata $@#/stop/ ',
, 'heredata 1 $x',
, 'heredata 2 $y',
, '$/stop/ $$ nach heredata',
, ' herdata ¢ $@=/stop/ ',
, '$=x=xValue$=y=yValueY',
, 'heredata 1 $x',
, 'heredata 2 $y',
, '$/stop/ $$ nach heredata ¢',
, ' herdata { $@/st/',
, '; call out heredata 1 $x',
, '$$heredata 2 $y',
, '$/st/ $$ nach heredata {'
/*
$=/tstCompDataIO/
### start tst tstCompDataIO #######################################
compile =, 5 lines: input 1 $@.<-=¢$dsn $*+.
run without input
. input 1 .
readInp line 1 .
readInp line 2 .
. nach dsn input und nochmals mit &
readInp line 1 .
readInp line 2 .
. und schluiss..
$/tstCompDataIO/ */
dsn = word(tstPdsMbr(tstFilename('lib37', 'r'), 'readInp'), 1)
dsnFB = strip(dsn tstFB('::F37', 0))
b = jBuf(tstFB('readInp line 1', 37),
,tstFB('readInp line 2', 37))
extFd = tstFB('&dsn('dsn') dd(xyz)', 0)
extFd = tstFB(dsn 'dd(xyz) ::f', 0)
if extFd = '' then
extFd = dsn
call jCat file(dsnFB), b
call vPut 'dsn', dsn
say 'dsn' dsn 'extFD' extFD'?'
call tstComp1 '= tstCompDataIO',
, ' input 1 $@.<-=¢$dsn $*+',
, tstFB('::f', 0) '$!',
, ' nach dsn input und nochmals mit & ' ,
, ' $@.<'extFD,
, ' und schluiss.'
return
endProcedure tstCompDataIO
tstObjVF: procedure expose m.
parse arg v, f
obj = oNew(classNew('n? TstClassVF u v, f FLD1 v'))
m.obj = if(f=='','val='v, v)
m.obj.fld1 = if(f=='','FLD1='v, f)
return obj
endProcedure tstObjVF
tstCompFile: procedure expose m.
/*
$=/tstCompFileBloSrc/
$=vv=value-of-vv
###file from empty # block
$@<#¢
$!
###file from 1 line # block
$@<#¢
the only $ix+1/0 line $vv
$!
###file from 2 line # block
$@<#¢
first line /0 $*+ no comment
second and last line $$ $wie
$!
===file from empty = block
$@<=¢ $*+ comment
$!
===file from 1 line = block
$@<=¢ the only line $!
===file from 2 line = block
$@<=¢ first line$** comment
second and last line $!
---file from empty - block
$@<-/s/
$/s/
---file from 1 line - block
$@<-/s/ the only "line" (1*1) $/s/
---file from 2 line = block
$@<-// first "line" (1+0)
second and "last line" (1+1) $//
...file from empty . block
$@<.¢
$!
...file from 1 line . block
$@<.¢ tstObjVF('v-Eins', '1-Eins') $!
...file from 2 line . block
$@<.¢ tstObjVF('v-Elf', '1-Elf')
tstObjVF('zwoelf') $!
...file from 3 line . block
$@<.¢ tstObjVF('einUndDreissig')
s2o('zweiUndDreissig' o2String($.-vv))
tstObjVF('dreiUndDreissig') $!
@@@file from empty @ block
$@<@¢
$!
$=noOutput=before
@@@file from nooutput @ block
$@<@¢ nop
$=noOutput = run in block $!
@@@nach noOutput=$noOutput
@@@file from 1 line @ block
$@<@¢ $$. tstObjVF('w-Eins', 'w1-Eins') $!
@@@file from 2 line @ block
$@<@¢ $$. tstObjVF('w-Elf', 'w1-Elf')
y='zwoelf' $$- y $!
@@@file from 3 line @ block
$@<@¢ $$. tstObjVF('w einUndDreissig') $$ +
zweiUndDreissig $$ 33 $vv$!
{{{ empty ¢ block
$@<¢ $!
{{{ empty ¢ block with comment
$@<¢ $*+ abc
$!
{{{ one line ¢ block
$@<¢ the only $"¢...$!" line $*+.
$vv $!
{{{ one line -¢ block
$@<-¢ the only $"-¢...$!" "line" $vv $!
{{{ empty #¢ block
$@<#¢
$!
{{{ one line #¢ block
$@<#¢ the only $"-¢...$!" "line" $vv $¢vv${x}$!
$!
$/tstCompFileBloSrc/ */
/*
$=/tstCompFileBlo/
### start tst tstCompFileBlo ######################################
compile =, 72 lines: $=vv=value-of-vv
run without input
###file from empty # block
###file from 1 line # block
the only $ix+1/0 line $vv
###file from 2 line # block
first line /0 $*+ no comment
second and last line $$ $wie
===file from empty = block
===file from 1 line = block
. the only line .
===file from 2 line = block
. first line
second and last line .
---file from empty - block
---file from 1 line - block
THE ONLY line 1
---file from 2 line = block
FIRST line 1
SECOND AND last line 2
...file from empty . block
...file from 1 line . block
tstR: @tstWriteoV1 isA :TstClassVF = v-Eins
tstR: .FLD1 = 1-Eins
...file from 2 line . block
tstR: @tstWriteoV2 isA :TstClassVF = v-Elf
tstR: .FLD1 = 1-Elf
tstR: @tstWriteoV3 isA :TstClassVF = val=zwoelf
tstR: .FLD1 = FLD1=zwoelf
...file from 3 line . block
tstR: @tstWriteoV4 isA :TstClassVF = val=einUndDreissig
tstR: .FLD1 = FLD1=einUndDreissig
zweiUndDreissig value-of-vv
tstR: @tstWriteoV5 isA :TstClassVF = val=dreiUndDreissig
tstR: .FLD1 = FLD1=dreiUndDreissig
@@@file from empty @ block
@@@file from nooutput @ block
@@@nach noOutput=run in block
@@@file from 1 line @ block
tstR: @tstWriteoV6 isA :TstClassVF = w-Eins
tstR: .FLD1 = w1-Eins
@@@file from 2 line @ block
tstR: @tstWriteoV7 isA :TstClassVF = w-Elf
tstR: .FLD1 = w1-Elf
zwoelf
@@@file from 3 line @ block
tstR: @tstWriteoV8 isA :TstClassVF = val=w einUndDreissig
tstR: .FLD1 = FLD1=w einUndDreissig
zweiUndDreissig
33 value-of-vv
{{{ empty ¢ block
{{{ empty ¢ block with comment
{{{ one line ¢ block
. the only ¢...$! line value-of-vv .
{{{ one line -¢ block
THE ONLY -¢...$! line value-of-vv
{{{ empty #¢ block
{{{ one line #¢ block
. the only $"-¢...$!" "line" $vv $¢vv${x}$!
$/tstCompFileBlo/ */
call tstComp2 'tstCompFileBlo', '='
m.t.trans.0 = 0
/*
$=/tstCompFileObjSrc/
$=vv=value-vv-1
$=fE=<¢ $!
$=f2=. $.<.¢s2o("f2 line 1" o2String($.-vv))
tstObjVF("f2 line2") $!
---empty file $"$@<$fE"
$@fE
---file with 2 lines $"$@<$f2"
$@.<.f2
$=vv=value-vv-2
---file with 2 lines $"$@<$f2"
$@.<.f2
$= dsn =- word(tstPdsMbr(tstFilename('libvb', 'r'), 'fileObj'),1) +
tstFB('::V', 0)
$@¢
fi=jOpen(file($dsn),'>')
call jWrite fi, 'line one on' $"$dsn"
call jWrite fi, 'line two on' $"$dsn"
call jClose fi
$!
---file on disk out
$@<-dsn
$/tstCompFileObjSrc/ */
/*
$=/tstCompFileObj/
### start tst tstCompFileObj ######################################
compile =, 20 lines: $=vv=value-vv-1
run without input
---empty file $@<$fE
---file with 2 lines $@<$f2
f2 line 1 value-vv-1
tstR: @tstWriteoV1 isA :TstClassVF = val=f2 line2
tstR: .FLD1 = FLD1=f2 line2
---file with 2 lines $@<$f2
f2 line 1 value-vv-1
tstR: @tstWriteoV1 isA :TstClassVF = val=f2 line2
tstR: .FLD1 = FLD1=f2 line2
---file on disk out
line one on $dsn
line two on $dsn
$/tstCompFileObj/ */
call tstComp2 'tstCompFileObj', '='
return
endProcedure tstCompFile
tstCompPipe: procedure expose m.
/*
$=/tstCompPipe1/
### start tst tstCompPipe1 ########################################
compile @, 1 lines: call pipePreSuf "(1 ", " 1)"
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
(1 eins zwei drei 1)
#jIn 2# zehn elf zwoelf?
(1 zehn elf zwoelf? 1)
#jIn 3# zwanzig 21 22 23 24 ... 29|
(1 zwanzig 21 22 23 24 ... 29| 1)
#jIn eof 4#
$/tstCompPipe1/ */
call tstComp1 '@ tstCompPipe1 3',
, ' call pipePreSuf "(1 ", " 1)"'
/*
$=/tstCompPipe2/
### start tst tstCompPipe2 ########################################
compile @, 2 lines: call pipePreSuf "(1 ", " 1)"
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
#jIn 2# zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
¢2 (1 eins zwei drei 1) 2!
¢2 (1 zehn elf zwoelf? 1) 2!
¢2 (1 zwanzig 21 22 23 24 ... 29| 1) 2!
$/tstCompPipe2/ */
call tstComp1 '@ tstCompPipe2 3',
, ' call pipePreSuf "(1 ", " 1)"' ,
, ' $| call pipePreSuf "¢2 ", " 2!"'
/*
$=/tstCompPipe3/
### start tst tstCompPipe3 ########################################
compile @, 3 lines: call pipePreSuf "(1 ", " 1)"
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
#jIn 2# zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
<3 ¢2 (1 eins zwei drei 1) 2! 3>
<3 ¢2 (1 zehn elf zwoelf? 1) 2! 3>
<3 ¢2 (1 zwanzig 21 22 23 24 ... 29| 1) 2! 3>
$/tstCompPipe3/ */
call tstComp1 '@ tstCompPipe3 3',
, ' call pipePreSuf "(1 ", " 1)"' ,
, ' $| call pipePreSuf "¢2 ", " 2!"',
, ' $| call pipePreSuf "<3 ", " 3>"'
/*
$=/tstCompPipe4/
### start tst tstCompPipe4 ########################################
compile @, 7 lines: call pipePreSuf "(1 ", " 1)"
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
#jIn 2# zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
<3 ¢222 ¢221 ¢21 ¢20 (1 eins zwei drei 1) 20! 21! 221! 222! 3>
<3 ¢222 ¢221 ¢21 ¢20 (1 zehn elf zwoelf? 1) 20! 21! 221! 222! 3>
<3 ¢222 ¢221 ¢21 ¢20 (1 zwanzig 21 22 23 24 ... 29| 1) 20! 21! 221!+
. 222! 3>
$/tstCompPipe4/ */
call tstComp1 '@ tstCompPipe4 3',
, ' call pipePreSuf "(1 ", " 1)"' ,
, ' $| $@¢ call pipePreSuf "¢20 ", " 20!"',
, ' $| call pipePreSuf "¢21 ", " 21!"',
, ' $| $@¢ call pipePreSuf "¢221 ", " 221!"',
, ' $| call pipePreSuf "¢222 ", " 222!"',
, '$! $! ',
, ' $| call pipePreSuf "<3 ", " 3>"'
return
endProcedure tstCompPipe
tstCompPip2: procedure expose m.
/*
$=/tstCompPip21/
### start tst tstCompPip21 ########################################
compile @, 3 lines: $<¢ zeile eins .
run without input
(1 zeile eins 1)
(1 zeile zwei 1)
run with 3 inputs
(1 zeile eins 1)
(1 zeile zwei 1)
$/tstCompPip21/ */
call tstComp1 '@ tstCompPip21 3',
, ' $<¢ zeile eins ' ,
, ' zeile zwei $!' ,
, ' call pipePreSuf "(1 ", " 1)"'
/*
$=/tstCompPip22/
### start tst tstCompPip22 ########################################
compile @, 3 lines: if ${>i1} then $@¢
run without input
#jIn eof 1#
nachher
run with 3 inputs
#jIn 1# eins zwei drei
<zeile 1: eins zwei drei>
<zwei>
nachher
$/tstCompPip22/ */
call tstComp1 '@ tstCompPip22 3',
, 'if ${>i1} then $@¢' ,
, ' $$ zeile 1: $i1 $$ zwei $| call pipePreSuf "<",">" $!',
, ' $$ nachher '
return
endProcedure tstCompPip2
tstCompRedir: procedure expose m.
/*
$=/tstCompRedir/
### start tst tstCompRedir ########################################
compile @, 6 lines: $=eins=<@¢ $@for vv $$ <$vv> $! .
run without input
#jIn eof 1#
output eins .
output piped zwei .
run with 3 inputs
#jIn 1# eins zwei drei
#jIn 2# zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
output eins <eins zwei drei> <zehn elf zwoelf?> +
<zwanzig 21 22 23 24 ... 29|>
output piped zwei ab<eins zwei drei>yz ab<zehn elf zwoelf?>yz a+
b<zwanzig 21 22 23 24 ... 29|>yz
$/tstCompRedir/ */
call pipeIni
call vRemove 'eins' /* alte Variable loswerden */
dsn = word(tstPdsMbr(tstFilename('libvb', 'r'), 'redir1'), 1)
call vPut 'dsn', dsn
say 'dsn' $dsn
call tstComp1 '@ tstCompRedir 3' ,
, ' $=eins=<@¢ $@for vv $$ <$vv> $! ',
, ' $$ output eins $-=¢$@.eins$! $; ',
, ' $@for ww $$b${ww}y ' ,
, ' $>-= $-¢ $dsn $! 'tstFB('::v', 0),
, '$| call pipePreSuf "a", "z" $<.eins' ,
, ' $; $$ output piped zwei $-=¢$@<$-dsn$!'
/*
$=/tstCompRedi2/
### start tst tstCompRedi2 ########################################
compile @, 12 lines: call mAdd t.trans, $var "dsnTestRedi"
run without input
>1<dsnTestRedi currTimeRedi
>2<$"dsnTestRedi" currTimeRedi
>3<$"dsnTestRedi" ::v currTimeRedi
>4<$-var" currTimeRedi
>5<$dsnTestRedi" currTimeRedi
$/tstCompRedi2/
*/
call vPut 'var', tstFileName('compRedi', 'r')
call vPut 'tst', translate(date()'+'time()'+testRedi2', '_', ' ')
call tstComp1 '@ tstCompRedi2 ' ,
, 'call mAdd t.trans, $var "dsnTestRedi"',
, 'call mAdd t.trans, $tst "currTimeRedi"',
, '$<> $>'vGet('var') '::v $$ $">1<'vGet('var')'" $tst',
, '$<> $<'vGet('var') ' $@ call pipeWriteAll' ,
, '$<> $>$"'vGet('var')' ::v" $$ $">2<$""'vGet('var')'""" $tst',
, '$<> $<$"'vGet('var') '" $@ call pipeWriteAll',
, '$<> $>$"'vGet('var')'" ::v $$ $">3<$""'vGet('var')'"" ::v" $tst',
, '$<> $<$"'vGet('var') '" $@ call pipeWriteAll',
, '$<> $>-var $$ $">4<$"-var" $tst',
, '$<> $<-var $@ call pipeWriteAll',
, '$<> $>$var ::v $$ $">5<$"$var" $tst',
, '$<> $<$var $@ call pipeWriteAll'
return
endProcedure tstCompRedir
tstCompComp: procedure expose m.
/*
$=/tstCompCompShell/
### start tst tstCompCompShell ####################################
compile @, 5 lines: $$compiling shell $; $= rrr =. $.^compile $<@#/+
aaa/
run without input
compiling shell
running einmal
RUN 1 COMPILED einmal
#jIn eof 1#
running zweimal
RUN 1 COMPILED zweimal
#jIn eof 2#
run with 3 inputs
compiling shell
running einmal
RUN 1 COMPILED einmal
#jIn 1# eins zwei drei
compRun eins zwei dreieinmal
#jIn 2# zehn elf zwoelf?
compRun zehn elf zwoelf?einmal
#jIn 3# zwanzig 21 22 23 24 ... 29|
compRun zwanzig 21 22 23 24 ... 29|einmal
#jIn eof 4#
running zweimal
RUN 1 COMPILED zweimal
#jIn eof 5#
$/tstCompCompShell/ */
call tstComp1 '@ tstCompCompShell 3',
, "$$compiling shell $; $= rrr =. $.^compile $<@#/aaa/",
, "call out run 1*1*1 compiled $cc;" ,
"$@for v $$ compRun $v$cc" ,
, "$/aaa/ $;",
, "$=cc=einmal $$ running $cc $@rrr",
, "$=cc=zweimal $$ running $cc $@rrr"
/*
$=/tstCompCompData/
### start tst tstCompCompData #####################################
compile @, 5 lines: $$compiling data $; $= rrr =. $.^¢compile = +
=$! $<@#/aaa/
run without input
compiling data
running einmal
call out run 1*1*1 compiled einmal
running zweimal
call out run 1*1*1 compiled zweimal
run with 3 inputs
compiling data
running einmal
call out run 1*1*1 compiled einmal
running zweimal
call out run 1*1*1 compiled zweimal
$/tstCompCompData/ */
call tstComp1 '@ tstCompCompData 3',
, "$$compiling data $; $= rrr =. $.^¢compile = =$! $<@#/aaa/",
, "call out run 1*1*1 compiled $cc",
, "$/aaa/ $;",
, "$=cc=einmal $$ running $cc $@rrr",
, "$=cc=zweimal $$ running $cc $@rrr"
return
endProcedure tstCompComp
tstCompDir: procedure expose m.
/*
$=/tstCompDirSrc/
'in src v1='$v1
$#@ call out 'src @ out v1='$v1
$#. $*(komm$*) s2o('src . v1=')
$.-v1
$#-
'src - v1='$v1
$#=
src = v1=$v1
$/tstCompDirSrc/
$=/tstCompDir/
### start tst tstCompDir ##########################################
compile @call out 'before v1='$v1 $=v1=eins $#. s2o('. v1='$-v1) $#+
@ call out '@ v1='$v1 $#= = v1=$v1 $#- '- v1='$v1 $#-, 8 lines: 'in+
. src v1='$v1
run without input
before v1=v1Before
.. v1=eins
@ v1=eins
= v1=eins .
- v1=eins
in src v1=eins
src @ out v1=eins
src . v1=
eins
src - v1=eins
src = v1=eins
$/tstCompDir/ */
call compIni
call vPut 'v1', 'v1Before'
call tstComp2 'tstCompDir', "@call out 'before v1='$v1 $=v1=eins" ,
"$#. s2o('. v1='$-v1) $#@ call out '@ v1='$v1" ,
"$#= = v1=$v1 $#- '- v1='$v1 $#-"
/*
$=/tstCompDirPiSrc/
zeile 1 v1=$v1
zweite Zeile vor $"$@$#-"
$#@ $@proc pi2 $@-¢
$'zeile drei nach $@$#- v1='v1
vierte und letzte Zeile $!
$/tstCompDirPiSrc/ */
/*
$=/tstCompDirPi/
### start tst tstCompDirPi ########################################
compile @call pipePreSuf '<','>' $=v1=eiPi $<.pi2 $#=, 5 lines: ze+
ile 1 v1=$v1
run without input
<zeile drei nach $@$#- v1=V1>
<VIERTE UND LETZTE ZEILE>
zeile 1 v1=eiPi
zweite Zeile vor $@$#-
$/tstCompDirPi/ */
call tstComp2 'tstCompDirPi',
, "@call pipePreSuf '<','>' $=v1=eiPi $<.pi2 $#="
return
endProcedure tstCompDir
tstCompColon: procedure expose m.
/*
$=/tstCompColon1/
### start tst tstCompColon1 #######################################
compile :, 12 lines: vA = valueVonA
run without input
vA = valueVonA
vA=valueVonA vB=valueVonB vC=valueVonC
vC=valueVonC vD=valueVonD vE=valueVonvE
vF=6
$/tstCompColon1/ */
call tstComp1 ': tstCompColon1',
, 'vA = valueVonA' ,
, ' $$ vA = $vA' ,
, ' * kommentar ' ,
, '=vB=- "valueVonB"' ,
, '=/vC/valueVonC$/vC/' ,
, ' $$ vA=$vA vB=$vB vC=$vC' ,
, '$=/vD/valueVonD' ,
, '$/vD/ vE=valueVonvE' ,
, ' * kommentar ' ,
, ' $$ vC=$vC vD=$vD vE=$vE',
, 'vF=- 2*3 $=vG=@@¢ $$ vF=$vF$!' ,
, '@vG'
/*
$=/tstCompColon2/
### start tst tstCompColon2 #######################################
compile :, 7 lines: ix=0
run without input
#jIn eof 1#
proc p1 arg(2) total 0 im argumentchen
run with 3 inputs
#jIn 1# eins zwei drei
#jIn 2# zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
<<for 1 -> eins zwei drei>>
<<for 2 -> zehn elf zwoelf?>>
<<for 3 -> zwanzig 21 22 23 24 ... 29|>>
proc p1 arg(2) total 3 im argumentchen
$/tstCompColon2/
*/
call tstComp1 ': tstCompColon2 3',
, 'ix=0' ,
, 'for v @:¢ix=- $ix+1',
, ' $$ for $ix -> $v' ,
, '! | @¢call pipePreSuf "<<",">>"',
, '$! @%¢p1 total $ix im argumentchen$!',
, 'proc @:/p1/$$- "proc p1 arg(2)" arg(2)' ,
, '/p1/'
/*
$=/tstCompColon3/
### start tst tstCompColon3 #######################################
compile :, 11 lines: tc3Eins=freeVar1
run without input
tc3Eins=freeVar1 o2&tc3Eins= o2&tc3Zwei=
tc3Eins=freeVar1 o2&tc3Eins=with3Eins o2&tc3Zwei=with3Zwei
tc3Eins=freeVar1 o2&tc3Eins=ass4Eins o2&tc3Zwei=with5Zwei
o3&tc3Eins=ass4Eins o3&tc3Zwei=with5 o3 Zwei
tc3Eins=freeVar1 o2&tc3Eins=ass4Eins o2&tc3Zwei=with5Zwei
$/tstCompColon3/
*/
call classNew 'n? TstCompColon3 u f tc3Eins v, f tc3Zwei v'
showO2 = 'tc3Eins=$tc3Eins' ,
'o2&tc3Eins=${o2&tc3Eins} o2&tc3Zwei=${o2&tc3Zwei}'
showO3 = 'o3&tc3Eins=${o3&tc3Eins} o3&tc3Zwei=${o3&tc3Zwei}'
call tstComp1 ': tstCompColon3',
, 'tc3Eins=freeVar1' ,
, 'o2 =. oNew("TstCompColon3")' ,
, '$$' showO2 ,
, 'with $o2 $@:¢tc3Eins = with3Eins',
, 'tc3Zwei = with3Zwei',
, '! $$' showO2 ,
, '{o2&tc3Eins} = ass4Eins',
, 'with $o2 $=tc3Zwei = with5Zwei',
, '$$' showO2 ,
, 'with o3 =. oCopy($o2) $=tc3Zwei = with5 o3 Zwei',
, '$$' showO3 '$$' showO2
return
endProcedure tstCompColon
tstCompWithNew: procedure expose m.
/*
$=/tstCompWithNew/
### start tst tstCompWithNew ######################################
compile :, 12 lines: withNew $@:¢
run without input
tstR: @tstWriteoV2 isA :<TstCT1Class>
tstR: .fEins = withNewValue fEins
tstR: .fZwei = withNewValue fZwei
tstR: .fDrei = withNewValuel drei
tstR: @tstWriteoV3 isA :<TstCT1Class>
tstR: .fEins = withNewValue fEinsB
tstR: .fZwei = withNewValue fZweiB
tstR: .fDrei = withNewValue fDreiB
tstR: @tstWriteoV5 isA :<TstCT2Class>
tstR: .fEins = withValue fEinsC
tstR: .fDrei = withValue fDreiC
$/tstCompWithNew/
*/
call wshIni
cl = classNew('n* CompTable u f fEins v, f fZwei v, f fDrei v')
c2 = classNew('n* CompTable u f fEins v, f fDrei v')
call tstComp1 ': tstCompWithNew',
, 'withNew $@:¢' ,
, 'fEins = withNewValue fEins' ,
, 'fZwei = withNewValue fZwei' ,
, '$@¢call mAdd t.trans, className("'cl'") "<TstCT1Class>"',
, '$@:¢ fDrei = withNewValuel drei $! $! ' ,
, '$! withNew $@:¢' ,
, 'fEins = withNewValue fEinsB' ,
, 'fZwei = withNewValue fZweiB',
, 'fDrei = withNewValue fDreiB',
, '$! withNew $@:¢ fEins = withValue fEinsC' ,
, '$@¢call mAdd t.trans, className("'c2'") "<TstCT2Class>"',
, '$@¢$=fDrei = withValue fDreiC$! $! $! '
/*
$=/tstCompWithNeRe/
### start tst tstCompWithNeRe #####################################
compile :, 11 lines: withNew $@:¢
run without input
tstR: @tstWriteoV2 isA :<TstClassR2>
tstR: .rA = value rA
tstR: .rB refTo @!value rB isA :w
tstR: @tstWriteoV4 isA :<TstClassR2>
tstR: .rA = val33 rA
tstR: .rB refTo @!VAL33 RB isA :w
tstR: @tstWriteoV5 isA :<TstClassR2>
tstR: .rA = val22 rA
tstR: .rB refTo @!VAL22 RB isA :w
tstR: @tstWriteoV6 isA :<TstCT1Class>
tstR: .fEins = withNewValue fEins
tstR: .fZwei = withNewValue fZwei
tstR: .fDrei = withNewValuel drei
vOth=value vOth fZwei=fZwei Wert vorher ?fDrei=0
$/tstCompWithNeRe/
*/
cR = classNew("n* CompTable u f rA v, f rB r")
call vRemove 'fDrei'
call vPut 'fZwei', 'fZwei Wert vorher'
call tstComp1 ': tstCompWithNeRe',
, 'withNew $@:¢' ,
, 'fEins = withNewValue fEins' ,
, '@:¢withNew $@:¢rA=value rA $=rB=. "!value rB" ' ,
, '$@ call mAdd t.trans, className("'cR'") "<TstClassR2>"$!$!',
, 'fZwei = withNewValue fZwei' ,
, '$@¢call mAdd t.trans, className("'cl'") "<TstCT1Class>"',
, '$@:¢withNew $@:¢ rA =val22 rA $=rB=. !val22 rB ' ,
, '{vOth} = value vOth',
, '$@:¢withNew @:¢rA =val33 rA $=rB=. !val33 rB $! $! $! $!' ,
, '$@:¢ fDrei = withNewValuel drei $! $! $!',
, '$<> $$ vOth=$vOth fZwei=$fZwei ?fDrei=${?fDrei}'
return
endProcedure tstCompWithNew
tstCompSql: procedure expose m.
/*
$=/tstCompSqlSrc/
$@=¢
select strip(creator) cr, strip(name) tb,
(row_number()over())*(row_number()over()) rr
from sysibm.sysTables
where creator='SYSIBM' and name like 'SYSTABL%'
order by 2 fetch first 4 rows only
$!
$| call sqlSel
$| call fTabAuto
$/tstCompSqlSrc/
$=/tstCompSql/
### start tst tstCompSql ##########################################
compile @, 9 lines: $@=¢
run without input
CR TB RR
SYSIBM SYSTABLEPART 1
SYSIBM SYSTABLEPART_HIST 4
SYSIBM SYSTABLES 9
SYSIBM SYSTABLESPACE 16
$/tstCompSql/
$=/tstCompSqlFTabSrc/
$$ select 'ahaaaax' ahaCol, 'buuuuh' buhhhh from sysibm.sysDummy1
$| call sql2tab , , sqlFTabOpts(fTabReset(tstCompS1, '1', '1', '-'))
$<>
$= s1 = select 'aOh' ahaOhne, 'buuVar' buhVar from sysibm.sysDummy1
call sqlQuery 7, $s1
t2 = sqlFTabOpts(fTabReset(tstCompS2, '2 1', '2 c', '-'))
ox = m.t2.0 + 1
call sqlFTabOthers t2, 7
call sqlFTab fTabSetTit(t2, ox, 2, '-----'), 7
$<>
$$ select 'aOh' aDrei, 'buuDre' buhDrei from sysibm.sysDummy1
$| call sql2Tab
$/tstCompSqlFTabSrc/
$=/tstCompSqlFTab/
### start tst tstCompSqlFTab ######################################
compile @, 12 lines: $$ select 'ahaaaax' ahaCol, 'buuuuh' buhhhh fr+
om sysibm.sysDummy1
run without input
AHACOL--BUHHHH---
ahaaaax buuuuh
AHACOL--BUHHHH---
-----
AHA-BUHVAR---
aOh buuVar
-----
AHAOHNE
. BUHVAR
ADREI
. BUHDREI
ADR-BUHDRE---
aOh buuDre
ADR-BUHDRE---
ADREI
. BUHDREI
$/tstCompSqlFTab/
*/
call sqlConnect , 's'
call tstComp2 'tstCompSql', '@'
call tstComp2 'tstCompSqlFTab', '@'
call sqlDisConnect
return
endProcedure tstCompSql
/* ?????rework tstTut ?????????????????*/
tstTut0: procedure expose m.
/*
$=/tstTut01Src/
$#=
$*+>.fSub() Kommentar
$*+>~tmp.jcl(t) Kommentar
$*+@=¢ Kommentar
$=subsys=DP4G
$=db=DA540769
$=ts=A977A
$*+@<~wk.jcl(jc) Kommentar
??* ?-¢sysvar(sysnode) date() time()?!ts=$ts 10*len=$-¢length($ts)*10$!
//P02 EXEC PGM=DSNUTILB,
// PARM='$subsys,A540769C.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=$subsys.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE $db.$ts* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
$@¢if right($ts, 2) == '7A' then $@=¢
FULL YES
$! else
$$ $'' FULL NO
$!
SHRLEVEL CHANGE
$*+! Kommentar
$#out original/src
$/tstTut01Src/
$=/tstTut01/
### start tst tstTut01 ############################################
compile , 28 lines: $#=
run without input
??* ?-¢sysvar(sysnode) date() time()?!ts=A977A 10*len=50
//P02 EXEC PGM=DSNUTILB,
// PARM='DP4G,A540769C.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DA540769.A977A* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
FULL YES
SHRLEVEL CHANGE
$/tstTut01/
$=/tstTut02Src/
$#@
$**>.fSub()
$**@¢
$=subsys=DP4G
$=db=DA540769
$=jx=0
$@do tx = 976 to 977 $@=¢
$=ts=A$tx
$=jx=- $jx+1
//A540769$jx JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//C$ts EXEC PGM=DSNUTILB,
// PARM='$subsys,A540769$jx.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=$subsys.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE $db.$ts* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$!
$**!
$#out original/src
$/tstTut02Src/
$=/tstTut02/
### start tst tstTut02 ############################################
compile , 28 lines: $#@
run without input
//A5407691 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA976 EXEC PGM=DSNUTILB,
// PARM='DP4G,A5407691.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DA540769.A976* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
//A5407692 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA977 EXEC PGM=DSNUTILB,
// PARM='DP4G,A5407692.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DA540769.A977* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$/tstTut02/
$=/tstTut03Src/
$#@
$=subsys=DP4G
$<>
$<#¢
db ts
DGDB9998 A976
DA540769 A977
$!
$@. csvColRdr()
$** $| call fTabAuto
$** $#end
$|
$=jx=0
$@forWith o $@=¢
$=jx=- $jx+1
//A540769$jx JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//C$ts EXEC PGM=DSNUTILB,
// PARM='$subsys,A540769$jx.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=$subsys.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE $db.$ts* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$!
$#out original/src
$/tstTut03Src/
$=/tstTut03/
### start tst tstTut03 ############################################
compile , 33 lines: $#@
run without input
//A5407691 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA976 EXEC PGM=DSNUTILB,
// PARM='DP4G,A5407691.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DGDB9998.A976* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
//A5407692 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA977 EXEC PGM=DSNUTILB,
// PARM='DP4G,A5407692.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DA540769.A977* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$/tstTut03/
$=/tstTut04Src/
$#@
$=subsys=DP4G
$=db=DA540769
call sqlConnect $subsys
$@=¢ select dbName db , tsName ts
from sysibm.sysTables
where creator = 'SYSIBM' and name like 'SYSINDEXPAR%'
order by name desc
$!
$| call sqlSel
$** $| call fTabAuto
$** $#end
$|
$=jx=0
$@forWith o $@=¢
$=jx=- $jx+1
//A540769$jx JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//C$TS EXEC PGM=DSNUTILB,
// PARM='$subsys,A540769$jx.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=$subsys.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE $DB.$TS* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$!
call sqlDisConnect
$#out original/src
$/tstTut04Src/
$=/tstTut04/
### start tst tstTut04 ############################################
compile , 35 lines: $#@
run without input
//A5407691 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CSYSHIST EXEC PGM=DSNUTILB,
// PARM='DP4G,A5407691.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DSNDB06 .SYSHIST * PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
//A5407692 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CSYSTSIPT EXEC PGM=DSNUTILB,
// PARM='DP4G,A5407692.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DSNDB06 .SYSTSIPT* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$/tstTut04/
$=/tstTut05Src/
$#:
subsys = DP4G
lst =<:¢withNew out :¢
db = DGDB9998
ts =<:¢table
ts
A976
A977
$!
db = DA540769
<|/ts/
ts
A976
A975
/ts/
!
$** $$. $lst
$** $@ct $@¢$=tool =. $.compile@ $<~.wk.rexx(wshtut06)$!
$** $@$tool
$@do sx=1 to ${lst.0} $@¢
$=db = ${lst.$sx.db}
$** $$. ${lst.$sx}
$@do tx=1 to ${lst.$sx.ts.0} $@=¢
$*+ $$. ${lst.$sx.ts.$tx}
$=ts= ${lst.$sx.ts.$tx.ts}
$@¢ say $-=¢subsys $subsys db $db ts $ts $! $!
$@copy()
$!
$!
$@ct $@¢
cl = classNew('n? DbTsList u s' ,
classNew('n? DbTs u f db v, f ts s' ,
classNew('n? Ts u f ts v')))
$=lst=. oNew(cl)
$!
$@proc copy $@=¢
$@ct $=jx=0
$=jx=- $jx+1
//A540769$jx JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//C$ts EXEC PGM=DSNUTILB,
// PARM='$subsys,A540769$jx.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=$subsys.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE $db.$ts* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$!
$#out original/src
$/tstTut05Src/
$=/tstTut05/
### start tst tstTut05 ############################################
compile , 56 lines: $#@
run without input
//A5407691 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA976 EXEC PGM=DSNUTILB,
// PARM='DP4G,A5407691.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DGDB9998.A976* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
//A5407692 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA977 EXEC PGM=DSNUTILB,
// PARM='DP4G,A5407692.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DGDB9998.A977* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
//A5407693 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA976 EXEC PGM=DSNUTILB,
// PARM='DP4G,A5407693.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DA540769.A976* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
//A5407694 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA975 EXEC PGM=DSNUTILB,
// PARM='DP4G,A5407694.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DA540769.A975* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$/tstTut05/
tstTut06 ==> platz für copy aus tut05
$=/tstTut07Src/
$**$>.fEdit()
call sqlConnect dp4g
$@:¢table
ts
VTCASHFLOW
VTCASHFLOWAMOUNT
VTINSTRFLATDATA
$!
$| $@=¢
select name, statstime, strip(dbName) || '.' || strip(tsName) dbts
from sysibm.sysTables
where creator = 'VDPS2' and name in
$=co=(
$@forWith t $@=¢
$co '$ts'
$=co=,
$!
)
$!
$| call sqlSel
$** $| call fTabAuto
$|
$=jx=0
$@forWith t $@=¢
$=jx=- $jx+1
//A540769$jx JOB (CP00,KE50),
// 'CATALOG',MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//STEP$jx EXEC PGM=DSNUTILB,TIME=1440,
// PARM=(DP4G,'A540769$jx.RUNSTA'),
// REGION=0M
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSOUT DD SYSOUT=*
//RNPRIN01 DD SYSOUT=*
//SYSIN DD *
LISTDEF LST#STA INCLUDE TABLESPACE $DBTS
OPTIONS EVENT (ITEMERROR, SKIP)
RUNSTATS TABLESPACE LIST LST#STA
SHRLEVEL CHANGE
INDEX(ALL KEYCARD)
REPORT YES UPDATE ALL
$!
call sqlDisconnect
$#out original/src
$/tstTut07Src/
$=/tstTut07/
$=/tstTut07/
### start tst tstTut07 ############################################
compile , 47 lines: $**$>.fEdit()
run without input
//A5407691 JOB (CP00,KE50),
// 'CATALOG',MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//STEP1 EXEC PGM=DSNUTILB,TIME=1440,
// PARM=(DP4G,'A5407691.RUNSTA'),
// REGION=0M
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSOUT DD SYSOUT=*
//RNPRIN01 DD SYSOUT=*
//SYSIN DD *
LISTDEF LST#STA INCLUDE TABLESPACE VV27A1T.VDPS329
OPTIONS EVENT (ITEMERROR, SKIP)
..
RUNSTATS TABLESPACE LIST LST#STA
SHRLEVEL CHANGE
INDEX(ALL KEYCARD)
REPORT YES UPDATE ALL
//A5407692 JOB (CP00,KE50),
// 'CATALOG',MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//STEP2 EXEC PGM=DSNUTILB,TIME=1440,
// PARM=(DP4G,'A5407692.RUNSTA'),
// REGION=0M
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSOUT DD SYSOUT=*
//RNPRIN01 DD SYSOUT=*
//SYSIN DD *
LISTDEF LST#STA INCLUDE TABLESPACE VV28A1T.VDPS390
OPTIONS EVENT (ITEMERROR, SKIP)
..
RUNSTATS TABLESPACE LIST LST#STA
SHRLEVEL CHANGE
INDEX(ALL KEYCARD)
REPORT YES UPDATE ALL
//A5407693 JOB (CP00,KE50),
// 'CATALOG',MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//STEP3 EXEC PGM=DSNUTILB,TIME=1440,
// PARM=(DP4G,'A5407693.RUNSTA'),
// REGION=0M
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSOUT DD SYSOUT=*
//RNPRIN01 DD SYSOUT=*
//SYSIN DD *
LISTDEF LST#STA INCLUDE TABLESPACE VV21A1T.VDPS004
OPTIONS EVENT (ITEMERROR, SKIP)
..
RUNSTATS TABLESPACE LIST LST#STA
SHRLEVEL CHANGE
INDEX(ALL KEYCARD)
REPORT YES UPDATE ALL
$/tstTut07/
$=/tstTut08Src/
$/tstTut08Src/
$=/tstTut08/
$/tstTut08/
*/
call sqlIni
call sqlDisconnect '*'
call tstComp2 'tstTut01'
call tstComp2 'tstTut02'
call tstComp2 'tstTut03'
if m.err_os == 'TSO' then do
call tstComp2 'tstTut04'
/* call tstComp2 'tstTut05' */
/* call tstComp2 'tstTut07' ???? anderes Beispiel ???? */
end
call tstTotal
return
endProcedure tstTut0
/****** tstBase *******************************************************
test the basic classes
**********************************************************************/
tstBase: procedure expose m.
call tstTstSay
call tstM
call tstUtc2d
call tstMap
call tstMapVia
call classIni
call tstClass
call tstClass2
call tstClass3
call tstClass4
call tstO
call tstOStr
call tstOEins
call tstO2Text
call tstF
call tstFWords
call tstFtst
call tstFCat
call jIni
call tstJSay
call tstJ
call tstJ2
call tstScanSqlStmt
call catIni
call tstCat
call pipeIni
CALL TstEnv
CALL TstEnvCat
call tstPipe
call tstPipeS
call tstEnvVars
call tstvWith
call tstTotal
call tstPipeLazy
call tstEnvClass
call tstDsn
call tstDsn2
if m.tst_csmRZ \== '' then
call tstDsnEx
call tstFile
call tstFileList
call tstMbrList
call tstFE
call tstFTab
call tstFmt
call tstFUnit
call tstfUnit2
call tstCsv
call tstCsv2
call tstCsvExt
call tstCsvInt
call tstCsvV2F
call tstTotal
call tstSb
call tstSb2
call tstScan
call ScanReadIni
call tstScanRead
call tstScanUtilInto
call tstScanWin
call tstScanSQL
call tstTotal
return
endProcedure tstBase
/*--- test the tst Module, check the output visually ---------------*/
tstTstSay: procedure expose m.
call tstIni
oldErr = m.tst.err
oldNames = m.tst.errNames
say '+++ tstTstSay start with' oldErr 'totErrs and',
m.tst.tests 'tests'
/*
$=/tstTstSayEins/
### start tst tstTstSayEins #######################################
test eins einzige testZeile
$/tstTstSayEins/
$=/tstTstSayZwei/
### start tst tstTstSayZwei #######################################
zwei 1. testZeile
zwei 2. und letzte testZeile
$/tstTstSayZwei/
$=/tstTstSayDrei/
### start tst tstTstSayDrei #######################################
drei 1. testZeile vor empty Zeile
..
drei 3. testZeile vor 10 space
. .
drei 5. testZeile ziemlich lang 66 +
. 77 5 10 15++++++++++++++++++++
.+++++++++++++++++++++++++++++++++++++++++++.
$/tstTstSayDrei/
*/
call tst x, 'tstTstSayEins'
call tstOut x, "test eins einzige testZeile"
call tstEnd x, 'err 0'
call tst x, 'tstTstSayZwei'
call tstOut x, "zwei 1. testZeile"
call tstOut x, "zwei 2. und letzte testZeile"
call tstEnd x, 'err 0'
call tst x, 'tstTstSayZwei'
call tstOut x, "zwei 1. testZeile " /* ein space zuviel */
call tstOut x, "zwei 2. und letzte testZeile"
call tstOut x, "zwei 3. zuviel"
call tstEnd x, 'err 3'
call tst y, 'tstTstSayDrei'
call tstOut y, 'drei 1. testZeile vor empty Zeile'
call tstOut y, ''
call tstOut y, 'drei 3. testZeile vor 10 space'
call tstOut y, left('', 10)
call tstOut y, 'drei 5. testZeile ziemlich lang',
left(66, 66) left('77 5 10 15', 77, '+')
call tstEnd y, 'err 0'
if m.y.err <> 0 then
call err '+++ tstTstSay errs' m.x.err 'expected' 0
if m.tst.err <> oldErr + 3 then
call err '+++ tstTstSay totErrs' m.tst.err 'expected' 3
say '+++ tstTstSay end Ok with' m.tst.err 'totErrs and' ,
m.tst.tests 'tests'
m.tst.err = oldErr
m.tst.errNames = oldNames
return
endProcedure tstTstSay
tstMark: procedure expose m.
parse arg m, msg
if symbol('m.m') == 'VAR' then
m.m = msg';' m.m
else
m.m = msg 'new'
return m
endProcedure tstMark
tstM: procedure expose m.
/*
$=/tstMa/
### start tst tstMa ###############################################
mNew() 1=newM1 2=newM2
mNew(tst...) 2=2 new 3=4; 3; 1 new 4=5 new
iter 4; 3; 1 new
iter 2 new
iter 5 new
$/tstMa/
*/
call tst t, 'tstMa'
m1 = mNew()
m2 = mNew()
m.m1 = 'newM1'
m.m2 = 'newM2'
call tstOut t, 'mNew() 1='m.m1 '2='m.m2
call mNewArea 'tst'm1
t1 = tstMark(mNew('tst'm1), '1')
t2 = tstMark(mNew('tst'm1), '2')
call mFree tstMark(t1, '3')
t3 = tstMark(mNew('tst'm1), '4')
t4 = tstMark(mNew('tst'm1), '5')
call tstOut t, 'mNew(tst...) 2='m.t2 '3='m.t3 '4='m.t4
i = mIterBegin('tst'm1)
do forever
i = mIter(i)
if i == '' then
leave
call tstOut t, 'iter' m.i
end
call tstEnd t
/*
$=/tstM/
### start tst tstM ################################################
symbol m.b LIT
symbol m.a LIT
mAdd a A.2
mAdd a A.3
m.a: 3: 1=eins 2=zwei 3=drei 4=M.A.4
m.c: 5: 1=c vorAddSt a 2=eins 3=zwei 4=drei 5=c nacAddSt a 6=M.C.6
$/tstM/ */
drop m.b m.a m.a.0 m.a.1 m.a.2
call tst t, 'tstM'
call tstOut t, 'symbol m.b' symbol('m.b')
m.b = 1
call tstOut t, 'symbol m.a' symbol('m.a')
call tstOut t, 'mAdd a' mAdd(mCut(a, 0), 'eins', 'zwei')
call tstOut t, 'mAdd a' mAdd(a, 'drei')
call tstOut t,'m.a:' m.a.0': 1='m.a.1 '2='m.a.2 '3='m.a.3 '4='m.a.4
call mAdd mCut(c, 0), 'c vorAddSt a'
call mAddSt c, a
call mAdd c, 'c nacAddSt a'
call tstOut t, 'm.c:' m.c.0': 1='m.c.1 '2='m.c.2 '3='m.c.3,
'4='m.c.4 '5='m.c.5 '6='m.c.6
call tstEnd t
return
endProcedure tstM
tstFCat: procedure expose m.
/*
$=/tstFCat/
### start tst tstFCat #############################################
fCat( ,0) =;
fCat(1 ,0) =;
fCat(112222 ,0) =;
fCat(3#a1%c2 ,0) =;
fCat(4#a1%c2@%c333 ,0) =;
fCat(5#a1%c2@%c3@%c4 ,0) =;
fCat( ,1) =eins;
fCat(1 ,1) =eins;
fCat(112222 ,1) =eins;
fCat(3#a1%c2 ,1) =1eins2;
fCat(4#a1%c2@%c333 ,1) =1eins2eins333;
fCat(5#a1%c2@%c3@%c4 ,1) =1eins2eins3eins4;
fCat( ,2) =einszwei;
fCat(1 ,2) =eins1zwei;
fCat(112222 ,2) =eins112222zwei;
fCat(3#a1%c2 ,2) =1eins231zwei2;
fCat(4#a1%c2@%c333 ,2) =1eins2eins33341zwei2zwei333;
fCat(5#a1%c2@%c3@%c4 ,2) =1eins2eins3eins451zwei2zwei3zwei4;
fCat( ,3) =einszweidrei;
fCat(1 ,3) =eins1zwei1drei;
fCat(112222 ,3) =eins112222zwei112222drei;
fCat(3#a1%c2 ,3) =1eins231zwei231drei2;
fCat(4#a1%c2@%c333 ,3) =1eins2eins33341zwei2zwei33341drei2dr+
ei333;
fCat(5#a1%c2@%c3@%c4 ,3) =1eins2eins3eins451zwei2zwei3zwei451d+
rei2drei3drei4;
$/tstFCat/ */
call pipeIni
call tst t, "tstFCat"
m.qq.1 = "eins"
m.qq.2 = "zwei"
m.qq.3 = "drei"
do qx = 0 to 3
m.qq.0 = qx
call tstFCat1 qx
call tstFCat1 qx, '1'
call tstFCat1 qx, '112222'
call tstFCat1 qx, '3#a1%c2'
call tstFCat1 qx, '4#a1%c2@%c333'
call tstFCat1 qx, '5#a1%c2@%c3@%c4'
end
call tstEnd t
return
endProcedure tstFCat
tstFCat1: procedure expose m.
parse arg m.qq.0, fmt
call out left("fCat("fmt, 26)","m.qq.0") ="fCat(fmt, qq)";"
return
endProcedure tstFCat1
tstMap: procedure expose m.
/*
$=/tstMap/
### start tst tstMap ##############################################
mapNew m keys m-keys 0
map m zwei --> 2
map m Zwei is not defined
map stem m-keys 4
map m eins --> 1
map m zwei --> 2
map m drei --> 3
map m vier --> 4
*** err: duplicate in mapAdd(m, eins, 1)
map m zwei is not defined
q 2 zw dr
map stem Q 2
map Q zw --> 2Q
map Q dr --> 3Q
map stem m 3
map m eins --> 1
map m zwei --> 2PUT
map m vier --> 4PUT
*** err: duplicate in mapAdd(m, zwei, 2ADDDUP)
tstMapLong eins keys 3
tstMapLong zweiMal keys 48
tstMapLong dreiMal keys 93
tstMapLong vier keys 138
tstMapLong <fuenf> keys 188
tstMap clear keys 0
inline1 3
inline1 1 == inline1 eins==
inline1 2 ====
inline1 3 == inline1 drei==
inline2 1 1 == inline2 eins==
inline3 ?
$/tstMap/ */
/*
$=/tstMapInline1/
inline1 eins
inline1 drei
$/tstMapInline1/ */
/*
$=/tstMapInline2/
inline2 eins
$/tstMapInline2/ */
call tst t, 'tstMap'
m = mapNew('K')
ky = mapKeys(m)
call mAdd t'.TRANS', m 'm', ky 'm-keys'
call tstOut t, 'mapNew' m 'keys' ky m.ky.0
call mapAdd m, 'eins', 1
call mapAdd m, 'zwei', 2
call mapAdd m, 'drei', 3
call mapAdd m, 'vier', 4
call tstMapShow m, 'zwei'
call tstMapShow m, 'Zwei'
call tstMapShowSt m, mapKeys(m)
call mapAdd m, 'eins', 1
call mapReset m, '='
call tstMapShow m, 'zwei'
call mapAdd m, 'eins', 1
call mapAdd m, 'zwei', 2
call mapPut m, 'zwei', 2Put
call mapPut m, 'vier', 4Put
call mapReset q, '='
call mapAdd q, 'zw', 2q
call mapAdd q, 'dr', 3q
call tstOut t, 'q' m.q.0 m.q.1 m.q.2
call tstMapShowSt q, mapKeys(q)
call tstMapShowSt m, mapKeys(m)
call mapAdd m, 'zwei', 2addDup
call tstMapLong m, 'eins' ,201, 2000, -2, 2
call tstMapLong m, 'zweiMal' ,201, 2000, -2, 2
call tstMapLong m, 'dreiMal' ,201, 2000, 2,-2
call tstMapLong m, 'vier ' ,2010, 201, -2, 2
call tstMapLong m, '<fuenf>' ,2010, 201, 2,-2
call mapClear m
keys = mapKeys(m)
call tstOut t, 'tstMap clear keys' m.keys.0
i = mapInline('tstMapInline1')
call tstOut t, 'inline1' m.i.0
do x=1 to m.i.0
call tstOut t, 'inline1' x '=='m.i.x'=='
end
i = mapInline('tstMapInline2')
call tstOut t, 'inline2' m.i.0 '1 =='m.i.1'=='
call tstOut t, 'inline3' mapInline('tstMapInline3', 'r')'?'
call tstEnd t
return
endProcedure tstMap
tstMapLong: procedure expose m.
parse arg m, w, f1, t1, f2, t2
if f1 < t1 then
b1 = 201
else
b1 = -201
if f2 < t2 then
b2 = 1
else
b2 = -1
lo = copies(w, 2100 % length(w))
keys = mapKeys(m)
keyCn = m.keys.0
call tstOut t, 'tstMapLong' w 'keys' keyCn
do x = f1 by b1 to t1
do y = x+f2 by b2 to x+t2
k = left(lo, y)
if mapHasKey(m, k) then
call err 'mapLong hasKey before' w y
call mapAdd m, k, w y
if \ mapHasKey(m, k) then
call err 'mapLong \ hasKey after' w y
if mapGet(m, k) \== w y then
call err 'mapLong \ get <> ' w y
keys = mapKeys(m)
if keyCn + 1 \= m.keys.0 then
call err 'mapLong keys .0 <> ' w y
keyCn = m.keys.0
if k \== m.keys.keyCn then
call err 'mapLong keys . ' keyCn '<>' w y
end
end
return
endProcedure tstMapLong
tstMapVia: procedure expose m.
/*
$=/tstMapVia/
### start tst tstMapVia ###########################################
map M K --> A
mapVia(m, K) A
*** err: missing m.A at 3 in mapVia(M, K|)
mapVia(m, K|) M.A
mapVia(m, K|) valAt m.a
mapVia(m, K|) valAt m.a
*** err: missing m.A.aB at 5 in mapVia(M, K|aB)
mapVia(m, K|aB) M.A.aB
mapVia(m, K|aB) valAt m.A.aB
*** err: missing m.valAt m.a at 4 in mapVia(M, K||)
mapVia(m, K||) M.valAt m.a
mapVia(m, K||) valAt m.valAt m.a
mapVia(m, K||F) valAt m.valAt m.a.F
$/tstMapVia/ */
call tst t, 'tstMapVia'
u = 'A.aB'
v = 'valAt m.a'
drop m.a m.u m.v m.v.f
call mapReset m, 'K'
call mapAdd m, k, a
call tstMapShow m, k
call tstOut t, 'mapVia(m, K) ' mapVia(m, 'K')
call tstOut t, 'mapVia(m, K|) ' mapVia(m, 'K|')
m.a = v
call tstOut t, 'mapVia(m, K|) ' mapVia(m, 'K|')
call tstOut t, 'mapVia(m, K|) ' mapVia(m, 'K|')
call tstOut t, 'mapVia(m, K|aB) ' mapVia(m, 'K|aB')
m.u = 'valAt m.'u
call tstOut t, 'mapVia(m, K|aB) ' mapVia(m, 'K|aB')
call tstOut t, 'mapVia(m, K||) ' mapVia(m, 'K||')
v = m.a
m.v = 'valAt m.'v
m.v.f = 'valAt m.'v'.F'
call tstOut t, 'mapVia(m, K||) ' mapVia(m, 'K||')
call tstOut t, 'mapVia(m, K||F) ' mapVia(m, 'K||F')
call tstEnd t
return
endProcedure tstMapVia
tstMapShow: procedure expose m.
parse arg a, key
if mapHasKey(a, key) then
call tstOut t, 'map' a key '-->' mapGet(a, key)
else
call tstOut t, 'map' a key 'is not defined'
return
endProcedure tstMapShow
tstMapShowSt: procedure expose m.
parse arg a, st
call tstOut t, 'map stem' st m.st.0
do wx=1 to m.st.0
call tstMapShow a, m.st.wx
end
return
endProcedure tstMapShow
tstClass2: procedure expose m.
/*
$=/tstClass2/
### start tst tstClass2 ###########################################
@CLASS.8 :class = u
. choice u union
. .NAME = class
. stem 8
. .1 refTo @CLASS.3 :class = u
. choice u union
. .NAME = v
. stem 2
. .1 refTo @CLASS.1 :class = m
. choice m union
. .NAME = asString
. .MET = return m.m
. stem 0
. .2 refTo @CLASS.2 :class = m
. choice m union
. .NAME = o2File
. .MET = return file(m.m)
. stem 0
. .2 refTo @CLASS.11 :class = c
. choice c union
. .NAME = u
. stem 1
. .1 refTo @CLASS.10 :class = u
. choice u union
. .NAME = .
. stem 1
. .1 refTo @CLASS.9 :class = f
. choice f union
. .NAME = NAME
. stem 1
. .1 refTo @CLASS.3 done :class @CLASS.3
. .3 refTo @CLASS.12 :class = c
. choice c union
. .NAME = f
. stem 1
. .1 refTo @CLASS.10 done :class @CLASS.10
. .4 refTo @CLASS.14 :class = c
. choice c union
. .NAME = s
. stem 1
. .1 refTo @CLASS.13 :class = u
. choice u union
. .NAME = .
. stem 0
. .5 refTo @CLASS.15 :class = c
. choice c union
. .NAME = c
. stem 1
. .1 refTo @CLASS.10 done :class @CLASS.10
. .6 refTo @CLASS.16 :class = c
. choice c union
. .NAME = r
. stem 1
. .1 refTo @CLASS.13 done :class @CLASS.13
. .7 refTo @CLASS.19 :class = c
. choice c union
. .NAME = m
. stem 1
. .1 refTo @CLASS.18 :class = u
. choice u union
. .NAME = .
. stem 2
. .1 refTo @CLASS.9 done :class @CLASS.9
. .2 refTo @CLASS.17 :class = f
. choice f union
. .NAME = MET
. stem 1
. .1 refTo @CLASS.3 done :class @CLASS.3
. .8 refTo @CLASS.21 :class = s
. choice s union
. stem 1
. .1 refTo @CLASS.20 :class = r
. choice r union
. stem 1
. .1 refTo @CLASS.8 done :class @CLASS.8
$/tstClass2/
*/
call classIni
call tst t, 'tstClass2'
call classOut m.class_C, m.class_C
call tstEnd t
return
endProcedure tstClass2
tstClass3: procedure expose m.
/*
$=/tstClass3/
### start tst tstClass3 ###########################################
met v#o2String return m.m
met w#o2String return substr(m, 2)
met w#o2String return substr(m, 2)
*** err: no method nonono in class w
met w#nonono 0
t1 4 fldD .FV, .FR
clear q1 FV= FR= FW= FO=
orig R1 FV=valFV FR=refFR FW=!valFW FO=obj.FO
copy <s1> FV=valFV FR=refFR FW=!valFW FO=obj.FO
t2 2 fldD .EINS.ZWEI, .
clear q2 EINS.ZWEI= val=
orig R2 EINS.ZWEI=valR2.eins.zwei val=valR2Self
copy <s2> EINS.ZWEI=valR2.eins.zwei val=valR2Self
t3 0 fldD M.<class tst...Tf33>.FLDD.1, M.<class tst...Tf33>.FLDD.2
clear q3 s1.0=0
orig R3 s1.0=1 s1.1=M.R3.S1.1 s1.1.f1=M.R3.S1.1.F1 s1.1.s2.0=2 s1.1+
..s2.1.f2=M.R3.S1.1.S2.1.F2 s1.1.s2.2.f2=M.R3.S1.1.S2.2.F2
copy <s3> s1.0=1 s1.1=M.R3.S1.1 s1.1.f1=M.R3.S1.1.F1 s1.1.s2.0=2 s1+
..1.s2.1.f2=M.R3.S1.1.S2.1.F2 s1.1.s2.2.f2=M.R3.S1.1.S2.2.F2
$/tstClass3/ */
call classIni
call tst t, 'tstClass3'
call mAdd t.trans, m.class_C '<class class>'
call tstOut t, 'met v#o2String' classMet(m.class_V, 'o2String')
call tstOut t, 'met w#o2String' classMet(m.class_W, 'o2String')
call tstOut t, 'met w#o2String' classMet(m.class_W, 'o2String')
call tstOut t, 'met w#nonono' classMet(m.class_W, 'nonono')
all = classNew('n? tstClassTf31 u f FV v, f FR r, f FW w,f FO o'),
classNew('n? tstClassTf32 u f EINS f ZWEI v, v') ,
classNew('n? tstClassTf33 u f S1' classNew('s u v, f F1 v,',
'f S2 s f F2 v'))
call mAdd t.trans, word(all, 3) '<class tst...Tf33>'
m.r1.fv = 'valFV'
m.r1.fr = 'refFR'
m.r1.fw = '!valFW'
m.r1.fo = 'obj.FO'
m.r2 = 'valR2Self'
m.r2.eins.zwei = 'valR2.eins.zwei'
m.r3.s1.0 = 1
m.r3.s1.1.s2.0 = 2
o.1 = "q 'FV='m.q.FV 'FR='m.q.fr 'FW='m.q.fw 'FO='m.q.fo"
o.2 = "q 'EINS.ZWEI='m.q.EINS.zwei 'val='m.q"
o.3 = "q 's1.0='m.q.s1.0"
p.1 = o.1
p.2 = o.2
p.3 = "q 's1.0='m.q.s1.0 's1.1='m.q.s1.1 's1.1.f1='m.q.s1.1.f1" ,
"'s1.1.s2.0='m.q.s1.1.s2.0 's1.1.s2.1.f2='m.q.s1.1.s2.1.f2",
"'s1.1.s2.2.f2='m.q.s1.1.s2.2.f2"
do tx=1 to words(all)
t1 = word(all, tx)
u1 = classFldD(t1)
q = 'q'tx
call tstOut t, 't'tx m.u1.0 'fldD' m.u1.1',' m.u1.2
call utInter("m='"q"';" classMet(t1, 'oClear'))
interpret "call tstOut t, 'clear'" o.tx
q = 'R'tx
interpret "call tstOut t, 'orig'" p.tx
q = utInter("m='"q"';t='';" classMet(t1, 'oCopy'))
call mAdd t.trans, q '<s'tx'>'
interpret "call tstOut t, 'copy'" p.tx
end
call tstEnd t
return
endProcedure tstClass3
tstClass: procedure expose m.
/*
$=/tstClass/
### start tst tstClass ############################################
Q u =className= tstClassTf12
Q.eins.zwei v ==> M.Q.eins.zwei
*** err: bad type v: classNew(v tstClassTf12)
R u =className= uststClassTf12
R u =className= uststClassTf12in
R u =className= tstClassTf12
R.eins.zwei v ==> M.R.eins.zwei
R s =stem.0= 2
R.1 r ==> M.R.1 :CLASS.7
R.1 u =className= tstClassTf12
R.1.eins.zwei v ==> M.R.1.eins.zwei
R.2 r ==> M.R.2 :CLASS.7
R.2 u =className= tstClassTf12
R.2.eins.zwei v ==> M.R.2.eins.zwei
S u =className= TstClass7
S s =stem.0= 2
S.1 u =className= TstClass7s
S.1.eins v ==> M.S.1.eins
S.1 m =met-metA--> say "metA"
S.1 m =met-metB--> say "metB"
S.2 u =className= TstClass7s
S.2.zwei v ==> M.S.2.zwei
S.2 m =met-metA--> say "metA"
S.2 m =met-metB--> say "metB"
class of mutate qq tstClassTf12
$/tstClass/ */
f = 'eins.zwei'
e = 'eins'
z = 'zwei'
drop m.q.f m.r.f m.r.0 m.r.1 m.r.1.f m.r.2 m.r.2.f
drop m.s.0 m.s.1 m.s.1.e m.s.2 m.s.2.z
call classIni
call tst t, 'tstClass'
t1 = classNew('n? tstClassTf12 u f eins f zwei v')
call tstClassOut t, t1, q
z = m.class.0
if class4name('tstClassB', '') == '' then
t2 = classNew('n tstClassB u n tstClassC u tstClassTf12,',
's u v tstClassTf12')
else /* the second time we would get a duplicate error */
call tstOut t, '*** err: bad type v: classNew(v tstClassTf12)'
t2 = classNew('n? uststClassTf12 u' ,
'n? uststClassTf12in u tstClassTf12',
, classNew('s u r, tstClassTf12'))
m.r.0 = 2
call tstClassOut t, t2, r
t3 = classNew('n? TstClass7 u s',
classNew('n? TstClass7s u c 1 f eins v, c 2 f zwei v',
,'m', 'metA say "metA"', 'metB say "metB"'))
m.s.0 = 2
m.s.1 = 1
m.s.2 = 2
call tstClassOut t, t3, s
call oMutatName qq, 'tstClassTf12'
tt = objClass(qq)
call tstOut t, 'class of mutate qq' className(tt)
call tstEnd t
return
endProcedure tstClass
tstClassOut: procedure expose m.
parse arg o, t, a
if wordPos(t, m.class_V m.class_W m.class_O) > 0 then
return tstOut(o, a m.t.name '==>' m.a)
if m.t == 'r' then
return tstOut(o, a m.t '==>' m.a ':'if(m.t.0==0,'',m.t.1))
if m.t == 'u' & m.t.name \== '' then
call tstOut o, a m.t '=className=' m.t.name
if m.t == 'f' then
return tstClassOut(o, m.t.1, a'.'m.t.name)
if m.t = 'u' then do
do ux=1 to m.t.0
call tstClassOut o, m.t.ux, a
end
return 0
end
if m.t = 's' then do
call tstOut o, a m.t '=stem.0=' m.a.0
do ux=1 to m.a.0
call tstClassOut o, m.t.1, a'.'ux
end
return 0
end
if m.t = 'c' then do
if m.t.name = m.a then
call tstClassOut o, m.t.1, a
return 0
end
if m.t = 'm' then
return tstOut(o, a m.t '=met-'m.t.name'-->' m.t.met)
call err 'bad class type' m.t
endProcedure tstClassOut
tstClass4: procedure expose m.
parse arg
/*
$=/tstClass4/
### start tst tstClass4 ###########################################
f 1 eins
f 2 zwei
f 3 drei
f 4 vier
f 5 acht
s 1 fuenf
s 2 sechs
s 3 sie
$/tstClass4/
*/
call classIni
call tst t, 'tstClass4'
x = classNew('n* TstClass4a u f eins v, f%v zwei drei, f vier v',
', f%s-v fuenf sechs sie, f acht v')
ff = classFlds(x)
do fx=1 to m.ff.0
call tstOut t, 'f' fx m.ff.fx
end
st = classMet(x, 'stms')
do sx=1 to m.st.0
call tstOut t, 's' sx m.st.sx
end
call tstEnd t
return
endProcedure tstClass4
tstO: procedure expose m.
/*
$=/tstO/
### start tst tstO ################################################
o1.class <class_S>
o1.class <class T..1>
o1#met1 metEins
o1#met2 metZwei
o1#new m = mNew('<class T..1>'); call oMutate m, '<class T..1>'; ca+
ll classClear '<class T..1>', m;
$/tstO/
*/
call classIni
call tst t, 'tstO'
call mAdd t.trans, m.class_s '<class_S>'
c1 = classNew('n? TstOCla1 u', 'm', 'met1 metEins', 'met2 metZwei')
call mAdd t.trans, c1 '<class T..1>'
o1 = 'tst_o1'
call tstOut t, 'o1.class' objClass(o1)
o1 = oMutate('o1', c1)
call tstOut t, 'o1.class' objClass(o1)
call tstOut t, 'o1#met1' objMet(o1, 'met1')
call tstOut t, 'o1#met2' objMet(o1, 'met2')
call tstOut t, 'o1#new' objMet(o1, 'new')
call tstEnd t
return
endProcedure tstO
tstOEins: procedure expose m.
/*
$=/tstOEins/
### start tst tstOEins ############################################
class method calls of TstOEins
. met Eins.eins M
flds of <obj e of TstOEins> FEINS, FZWEI
methodcalls of object e of TstOEins
. met Eins.eins <obj e of TstOEins>
. met Eins.zwei <obj e2 of TstOEins>
*** err: no method nein in class TstOEins
*** err: no method nein in class String
class method calls of TstOEins
. met Elf.zwei M
flds of <obj f of TstOElf> FEINS, FZWEI, FELF
methodcalls of object f of TstOElf
. met Eins.eins <obj f of TstOElf>
. met Elf.zwei <obj f of TstOElf>
. met Elf.drei <obj f of TstOElf>
oCopy c1 of class TstOEins, c2
C1 u =className= TstOEins
C1.FEINS v ==> M.C1.FEINS
C1.FZWEI v ==> M.C1.FZWEI
C1 m =met-eins--> call tstOut t, " met Eins.eins" m
C1 m =met-zwei--> call tstOut t, " met Eins.zwei" m
C2 u =className= TstOEins
C2.FEINS v ==> M.C1.FEINS
C2.FZWEI v ==> M.C1.FZWEI
C2 m =met-eins--> call tstOut t, " met Eins.eins" m
C2 m =met-zwei--> call tstOut t, " met Eins.zwei" m
oCopy c3 of class TstOElf, c4
C4 u =className= TstOElf
C4 u =className= TstOEins
C4.FEINS v ==> M.C3.FEINS
C4.FZWEI v ==> M.C3.FZWEI
C4 m =met-eins--> call tstOut t, " met Eins.eins" m
C4 m =met-zwei--> call tstOut t, " met Eins.zwei" m
C4.FELF r ==> M.C3.FELF :<class O>
C4 m =met-zwei--> call tstOut t, " met Elf.zwei" m
C4 m =met-drei--> call tstOut t, " met Elf.drei" m
tEinsDop <class TstOEins>
oRun 7*3 21
oRun 12*12 144
$/tstOEins/ */
call classIni
call tst t, 'tstOEins'
tEins = classNew('n? TstOEins u f FEINS v,f FZWEI v', 'm',
, 'eins call tstOut t, " met Eins.eins" m',
, 'zwei call tstOut t, " met Eins.zwei" m')
call mAdd t.trans, tEins '<class TstOEins>' ,
, m.class_o '<class O>'
call tstOut t, 'class method calls of TstOEins'
interpret classMet('TstOEins', 'eins')
e = oNew('TstOEins')
e2 = oNew('TstOEins')
call mAdd t.trans, e '<obj e of TstOEins>'
call mAdd t.trans, e2 '<obj e2 of TstOEins>'
call tstOut t, 'flds of' e mCat(oFlds(e), ', ')
call tstOut t, 'methodcalls of object e of TstOEins'
call tstOmet e, 'eins'
call tstOmet e2, 'zwei'
call tstOmet e, 'nein'
call tstOmet 'noObj', 'nein'
tElf = classNew('n? TstOElf u TstOEins, f FELF r', 'm',
, 'zwei call tstOut t, " met Elf.zwei" m',
, 'drei call tstOut t, " met Elf.drei" m')
call tstOut t, 'class method calls of TstOEins'
interpret classMet('TstOElf', 'zwei')
f = oNew('TstOElf')
call mAdd t.trans, f '<obj f of TstOElf>'
call tstOut t, 'flds of' f mCat(oFlds(f), ', ')
call tstOut t, 'methodcalls of object f of TstOElf'
call tstOmet f, 'eins'
call tstOmet f, 'zwei'
call tstOmet f, 'drei'
call oMutatName c1, 'TstOEins'
call tstOut t, 'oCopy c1 of class TstOEins, c2'
call tstClassOut t, tEins, c1
call oCopy c1, c2
call tstClassOut t, tEins, c2
call tstOut t, 'oCopy c3 of class TstOElf, c4'
call oMutatName c3, 'TstOElf'
call oCopy c3, c4
call tstClassOut t, tElf, c4
/* tEinsDop = classNew('n TstOEins u f FEINS v,f FZWEI v', 'm',
, 'eins call tstOut t, " met Eins.eins" m',
, 'zwei call tstOut t, " met Eins.zwei" m')
*/ tEinsDop = tEins
call tstOut t, 'tEinsDop' tEinsDop
e3 = oNew('TstOEins')
if e3 <<= e | e3 <<= e2 then
call err 'doppelt reinitialised objects'
rr = oRunner('return 7 * 3')
call tstOut t, 'oRun 7*3' oRun(rr)
r12 = oRunner('return 12 * 12')
call tstOut t, 'oRun 12*12' oRun(r12)
call tstEnd t
return
endProcedure tstOEins
tstOmet: procedure expose m.
parse arg m, met
interpret objMet(m, met)
return
endProcedure tstOmet
tstOStr: procedure expose m.
/*
$=/tstOStr/
### start tst tstOStr #############################################
. kindOfStri 1
. asString .
. asString - .
. o2String .
abc kindOfStri 1
abc asString abc
abc asString - abc
abc o2String abc
!defg kindOfStri 1
!defg asString defg
!defg asString - defg
!defg o2String defg
TST_STR kindOfStri 0
*** err: TST_STR is not a kind of string but has class TstStr
TST_STR asString 0
TST_STR asString - -
*** err: no method o2String in class TstStr
*** err: o2String did not return
TST_STR o2String 0
lllllll... kindOfStri 1
lllllll... asString llllllllll
lllllll... asString - llllllllll
lllllll... o2String llllllllll
$/tstOStr/
*/
call classIni
o = oMutate(tst_str, classNew('n? TstStr u'))
call mAdd mCut(tstStr, 0), '', 'abc', '!defg', o, left('',500,'l')
call tst t, 'tstOStr'
do ix=1 to m.tstStr.0
e = m.tstStr.ix
f = e
if length(e) > 10 then
f = left(e, 7)'...'
call tstOut t, f 'kindOfStri' oKindOfString(e)
call tstOut t, f 'asString ' strip(left(oAsString(e),10))
call tstOut t, f 'asString -' strip(left(oAsString(e,'-'),10))
call tstOut t, f 'o2String ' strip(left(o2String(e),10))
end
call tstEnd t
return
endProcedure tstOStr
tstO2Text: procedure expose m.
/*
$=/o2Text/
### start tst o2Text ##############################################
. > .
und _s abc > und so
und _s lang > und so und so und so und so und so und so und so und+
. so und so ....
!und _w abc > und so
o1 > tstO2T1=¢fEins=v_o1_fEins fZwei=v_o1_fZwei fDrei=v_o+
1_fDrei!
o1 lang > tstO2T1=¢fEins=v_o1_fEins fZwei=v_o1_fZweiv_o1_fZwei+
v_o1_fZwei...!
o2 > tstO2T2=¢f2f=v_o2_f2f =value_o2!
runner > <tstRunObj>=¢<tstRunCla>!
file > <tstFileObj>=¢File!
$/o2Text/
*/
call catIni
cl = classNew('n* TstO2Text1 u f fEins v, f fZwei v, f fDrei v')
o1 = oMutate('tstO2T1', cl)
o1 = oMutate('tstO2T1', cl)
call oMutate o1, cl
call mPut o1'.fEins', 'v_o1_fEins'
call mPut o1'.fZwei', 'v_o1_fZwei'
call mPut o1'.fDrei', 'v_o1_fDrei'
call tst t, 'o2Text'
c2 = classNew('n? TstO2Text2 u f f2f v, v')
o2 = oMutate('tstO2T2', c2)
call mPut o2'.f2f', 'v_o2_f2f'
call mPut o2 , 'value_o2'
maxL = 66
call tstOut t, ' >' o2Text(' ', maxL)
call tstOut t, 'und _s abc >' o2Text('und so ', maxL)
call tstOut t, 'und _s lang >' o2Text(copies('und so ',33), maxL)
call tstOut t, '!und _w abc >' o2Text('und so ', maxL)
call tstOut t, 'o1 >' o2Text(o1 , maxL)
call mPut o1'.fZwei', copies('v_o1_fZwei',33)
call tstOut t, 'o1 lang >' o2Text(o1 , maxL)
call tstOut t, 'o2 >' o2Text(o2 , maxL)
f = file('abc.efg')
r = oRunner('say o2Text test')
call mAdd t.trans, r '<tstRunObj>',
, className(objClass(r)) '<tstRunCla>' ,
, f '<tstFileObj>'
call tstOut t, 'runner >' o2Text(r , maxL)
call tstOut t, 'file >' o2Text(f , maxL)
call mAdd t.trans, r '<tstRunnerObj>',
, className(objClass(r)) '<tstRunnerCla>'
call tstEnd t
return
endProcedure tstO2Text
tstJSay: procedure expose m.
/*
$=/tstJSay/
### start tst tstJSay #############################################
*** err: bad option openArg in jOpen(<obj j of JRW>, openArg)
*** err: jWrite(<obj j of JRW>) but not open+
ed w
*** err: can only write JSay#jOpen(<obj s of JSay>, <)
*** err: jWrite(<obj s of JSay>) but not op+
ened w
*** err: JRWEof#open(<obj e of JRWEof>, >)
*** err: jRead(<obj e of JRWEof>) but not opened r
read e vor open 0 m.xx valueBefore
read e nach open 0 m.xx valueBefore
out eins
#jIn 1# tst in line 1 eins ,
out zwei in 1 vv=readAdrVV
#jIn 2# tst in line 2 zwei ; .
out drei in 1 vv=readAdrVV Schluss
$/tstJSay/ */
call jIni
call tst t, 'tstJSay'
jrw = oNew('JRW')
call mAdd t'.TRANS', jrw '<obj j of JRW>'
call jOpen jrw, 'openArg'
call jWrite jrw, 'writeArg'
s = oNew('JSay')
call mAdd t'.TRANS', s '<obj s of JSay>'
call jOpen s, m.j.cRead
s = oNew('JSay')
call mAdd t'.TRANS', s '<obj s of JSay>'
call jWrite s, 'write s vor open'
call jOpen s, '>'
call jWrite s, 'write s nach open'
e = oNew('JRWEof')
call mAdd t'.TRANS', e '<obj e of JRWEof>'
call jOpen e, '>'
e = oNew('JRWEof')
call mAdd t'.TRANS', e '<obj e of JRWEof>'
m.xx = 'valueBefore'
call tstOut t, 'read e vor open' jReadVar(e, xx) 'm.xx' m.xx
call jOpen e, m.j.cRead
call tstOut t, 'read e nach open' jReadVar(e, xx) 'm.xx' m.xx
call out 'out eins'
vv = 'readAdrVV'
m.vv = 'readAdrVVValueBefore'
call out 'out zwei in' in() 'vv='vv
m.vv = 'readAdrVVValueBefore'
call out 'out drei in' inVar(vv) 'vv='vv 'Schluss'
call tstEnd t
return
endProcedure tstJSay
tstJ: procedure expose m.
/*
$=/tstJ/
### start tst tstJ ################################################
out eins
#jIn 1# tst in line 1 eins ,
1 in() tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
2 in() tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
3 in() tst in line 3 drei .schluss..
#jIn eof 4#
in() 3 reads vv VV
line buf line one
line buf line two
line buf line three
line buf line four
*** err: jWrite(<buf b>) but not opened w
$/tstJ/ */
call jIni
call tst t, "tstJ"
b = jOpen(jBuf(), '>')
call mAdd t'.TRANS', b '<buf b>'
call out 'out eins'
do lx=1 by 1 while in()
call out lx 'in()' m.in
end
call out 'in()' (lx-1) 'reads vv' vv
call jOpen b, '>'
call jWrite b, 'buf line one'
call jClose b
call mAdd b'.BUF', 'buf line two', 'buf line three'
call jWrite b, 'buf line four'
call jClose b
call jOpen b, m.j.cRead
do while jRead(b)
call out 'line' m.b
end
call jWrite b, 'buf line five while reading'
call jClose b
call tstEnd t
return
endProcedure tstJ
tstJ2: procedure expose m.
/*
$=/tstJ2/
### start tst tstJ2 ###############################################
class1 <Tst?1 class> <Tst?1 name>
class2 <Tst?1 class> <Tst?1 name>
class3 <Tst?1 class> <Tst?1 name>
b read EINS feld eins, ZWEI feld zwei, DREI feld drei
b read EINS feld eins, ZWEI feld zwei 2, DREI feld drei
c read EINS feld eins, ZWEI feld zwei, DREI drei cat 1
tstR: @tstWriteoV3 isA :<Tst?1 name>
tstR: .EINS = feld eins
tstR: .ZWEI = feld zwei
tstR: .DREI = drei cat 1
c read EINS feld eins, ZWEI feld zwei 2, DREI drei cat 2
tstR: @tstWriteoV4 isA :<Tst?1 name>
tstR: .EINS = feld eins
tstR: .ZWEI = feld zwei 2
tstR: .DREI = drei cat 2
$/tstJ2/ */
call jIni
call tst t, "tstJ2"
ty = classNew('n* Tst u f EINS v, f ZWEI v, f DREI v')
call mAdd t'.TRANS', ty '<Tst?1 class>'
call mAdd t'.TRANS', m.ty.name '<Tst?1 name>'
call tstOut t, 'class1' ty m.ty.name
ty = classNew('n* Tst u f EINS v, f ZWEI v, f DREI v')
call tstOut t, 'class2' ty m.ty.name
ty = classNew('n* Tst u f EINS v, f ZWEI v, f DREI v')
call tstOut t, 'class3' ty m.ty.name
call oMutate qq, ty
m.qq.eins = 'feld eins'
m.qq.zwei = 'feld zwei'
m.qq.drei = 'feld drei'
b = jBuf()
call jOpen b, '>'
call jWrite b, oCopy(qq)
m.qq.zwei = 'feld zwei 2'
call jWrite b, qq
call jOpen jClose(b), m.j.cRead
c = jOpen(jBuf(), '>')
do xx=1 while jRead(b)
res = m.b
call out 'b read EINS' m.res.eins', ZWEI' m.res.zwei,
|| ', DREI' m.res.drei
m.res.drei = 'drei cat' xx
call jWrite c, res
end
call jOpen jClose(c), m.j.cRead
do while jRead(c)
ccc = m.c
call out 'c read EINS' m.ccc.eins', ZWEI' m.ccc.zwei,
|| ', DREI' m.ccc.drei
call out ccc
end
call tstEnd t
return
endProcedure tstJ2
tstCat: procedure expose m.
/*
$=/tstCat/
### start tst tstCat ##############################################
catRead 1 line 1
catRead 2 line 2
catRead 3 line 3
appRead 1 line 1
appRead 2 line 2
appRead 3 line 3
appRead 4 append 4
appRead 5 append 5
$/tstCat/ */
call catIni
call tst t, "tstCat"
i = cat(jBuf('line 1', 'line 2'), jBuf('line 3'))
call jOpen i, m.j.cRead
do lx=1 by 1 while jRead(i)
call tstOut t, 'catRead' lx m.i
end
call jOpen jClose(i), m.j.cApp
call jWrite i, 'append 4'
call jWrite i, 'append 5'
call jOpen jClose(i), m.j.cRead
do lx=1 by 1 while jRead(i)
call tstOut t, 'appRead' lx m.i
end
call tstEnd t
return
endProcedure tstCat
tstEnv: procedure expose m.
call pipeIni
/*
$=/tstEnv/
### start tst tstEnv ##############################################
before pipeBeLa
after pipeEnd
#jIn 1# tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
before writeNow 2 c --> std
before writeNow 1 b --> c
b line eins
b zwei |
nach writeNow 1 b --> c
add nach pop
after push c only
tst in line 1 eins ,
tst in line 2 zwei ; .
tst in line 3 drei .schluss..
nach writeNow 2 c --> std
*** err: jWrite(<jBuf c>) but not opened w
$/tstEnv/ */
call tst t, "tstEnv"
c = jBuf()
call mAdd t'.TRANS', c '<jBuf c>'
call out 'before pipeBeLa'
b = jBuf("b line eins", "b zwei |")
call pipe '+Ff', c, b
call out 'before writeNow 1 b --> c'
call pipeWriteNow
call out 'nach writeNow 1 b --> c'
call pipe '-'
call out 'after pipeEnd'
call mAdd c'.BUF', 'add nach pop'
call pipe '+A', c
call out 'after push c only'
call pipeWriteNow
call pipe '-'
call pipe '+f', , c
call out 'before writeNow 2 c --> std'
call pipeWriteNow
call out 'nach writeNow 2 c --> std'
call pipe '-'
call jWrite c
call tstEnd t
return
endProcedure tstEnv
tstEnvCat: procedure expose m.
call pipeIni
/*
$=/tstEnvCat/
### start tst tstEnvCat ###########################################
c1 contents
c1 line eins |
before writeNow 1 b* --> c*
b1 line eins|
b2 line eins
b2 zwei |
c2 line eins |
after writeNow 1 b* --> c*
c2 contents
c2 line eins |
$/tstEnvCat/ */
call tst t, "tstEnvCat"
b0= jBuf()
b0= jBuf()
b1= jBuf("b1 line eins|")
b2 = jBuf("b2 line eins", "b2 zwei |")
c1 = jBuf("c1 line eins |")
c2 = jBuf("c2 line eins |")
call pipe '+Affff', c1, b0, b1, b2, c2
call out 'before writeNow 1 b* --> c*'
call pipeWriteNow
call out 'after writeNow 1 b* --> c*'
call pipe '-'
call out 'c1 contents'
call pipe '+f' , , c1
call pipeWriteNow
call pipe '-'
call pipe '+f' , , c2
call out 'c2 contents'
call pipeWriteNow
call pipe '-'
call tstEnd t
return
endProcedure tstEnvCat
tstPipe: procedure expose m.
call pipeIni
/*
$=/tstPipe/
### start tst tstPipe #############################################
.+0 vor pipeBegin
#jIn 1# tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
.+7 nach pipeLast
¢7 +6 nach pipe 7!
¢7 +2 nach pipe 7!
¢7 +4 nach nested pipeLast 7!
¢7 (4 +3 nach nested pipeBegin 4) 7!
¢7 (4 (3 +1 nach pipeBegin 3) 4) 7!
¢7 (4 (3 tst in line 1 eins , 3) 4) 7!
¢7 (4 (3 tst in line 2 zwei ; 3) 4) 7!
¢7 (4 (3 tst in line 3 drei .schluss. 3) 4) 7!
¢7 (4 (3 +1 nach writeNow vor pipe 3) 4) 7!
¢7 (4 +3 nach preSuf vor nested pipeLast 4) 7!
¢7 +4 nach preSuf vor nested pipeEnd 7!
¢7 +5 nach nested pipeEnd vor pipe 7!
¢7 +6 nach writeNow vor pipeLast 7!
.+7 nach writeNow vor pipeEnd
.+8 nach pipeEnd
$/tstPipe/ */
say 'x0' m.pipe.0
call tst t, 'tstPipe'
call out '+0 vor pipeBegin'
say 'x1' m.pipe.0
call pipe '+N'
call out '+1 nach pipeBegin'
call pipeWriteNow
call out '+1 nach writeNow vor pipe'
call pipe 'N|'
call out '+2 nach pipe'
call pipe '+N'
call out '+3 nach nested pipeBegin'
call pipePreSuf '(3 ', ' 3)'
call out '+3 nach preSuf vor nested pipeLast'
call pipe 'P|'
call out '+4 nach nested pipeLast'
call pipePreSuf '(4 ', ' 4)'
call out '+4 nach preSuf vor nested pipeEnd'
call pipe '-'
call out '+5 nach nested pipeEnd vor pipe'
call pipe 'N|'
call out '+6 nach pipe'
call pipeWriteNow
say 'out +6 nach writeNow vor pipeLast'
call out '+6 nach writeNow vor pipeLast'
call pipe 'P|'
call out '+7 nach pipeLast'
call pipePreSuf '¢7 ', ' 7!'
call out '+7 nach writeNow vor pipeEnd'
call pipe '-'
call out '+8 nach pipeEnd'
say 'xx' m.pipe.0
call tstEnd t
return
endProcedure tstPipe
tstPipeS: procedure expose m.
/*
$=/tstPipeS/
### start tst tstPipeS ############################################
eine einzige zeile
nach all einzige Zeile
select strip(creator) cr, strip(name) tb,
(row_number()over())*(row_number()over()) rr
from sysibm.sysTables
$/tstPipeS/
*/
call pipeIni
call tst t, "tstPipeS"
call pipe '+s',, 'eine einzige zeile'
call pipeWriteAll
call out 'nach all einzige Zeile'
call pipe 'sss',,
, "select strip(creator) cr, strip(name) tb," ,
, "(row_number()over())*(row_number()over()) rr" ,
, "from sysibm.sysTables"
call pipeWriteAll
call pipe '-'
call tstEnd t
return
endProcedure tstPipeS
tstEnvVars: procedure expose m.
call pipeIni
/*
$=/tstEnvVars/
### start tst tstEnvVars ##########################################
put v1 value eins
v1 hasKey 1 get TST.ADR1
v2 hasKey 0
one to theBur
two to theBuf
v1=TST.ADR1 o=TST.ADR1
v3=v3WieGehts? o=v3WieGehts?
v4=!v4WieGehts? o=!v4WieGehts?
o o0=<o0>
s o0=<o0>
o o0=<o0>
s o0=<o0>
o0&fSt0=rexx o0.fSt0 o=rexx o0.fSt0
o0&fRe0=!rexx o0.fRe0 o=!rexx o0.fRe0
o0&=rexx o0-value o=rexx o0-value
o o0=<o0>
s o0=<o0>
o0&fSt0=put o0.fSt0 o=put o0.fSt0
o0&fRe0=!putO o0.fRe0 o=!putO o0.fRe0
o0&=put o0-value o=put o0-value
$/tstEnvVars/
$=/tstEnvVars1/
### start tst tstEnvVars1 #########################################
m.o1=put-o1-value m.o1.fStr=put-o1.fStr m.o1.fRef=<o0>
o o1=<o1> s o1=<o1>
o1&fStr=put-o1.fStr o=put-o1.fStr
o1&=put-o1-value o=put-o1-value
o1&fRef=<o0> o=<o0>
o1&fRef>fSt0=put o0.fSt0 o=put o0.fSt0
o1&fRef>fRe0=!putO o0.fRe0 o=!putO o0.fRe0
m.o1&fNest.fSt0= put-o1.fNest.fSt0 m.o1&fNest.fRe0= !put-o1&fNest.f+
Re0
o1&fNest.fSt0=put-o1.fNest.fSt0 o=put-o1.fNest.fSt0
o1&fNest&fRe0=!put-o1&fNest.fRe0 o=!put-o1&fNest.fRe0
$/tstEnvVars1/
$=/tstEnvVars2/
### start tst tstEnvVars2 #########################################
o2=<o2> getO(o2)=<o2> getO(o2&fRef)=<o1>
o2&fRef>fStr=put-o1.fStr o=put-o1.fStr
o2&fRef>=put-o1-value o=put-o1-value
o2&fRef>fRef=<o0> o=<o0>
o2&fRef>fRef>fSt0=put o0.fSt0 o=put o0.fSt0
o2&fRef>fRef>fRe0=!putO o0.fRe0 o=!putO o0.fRe0
o2&fRef>fNest.fSt0=put-o1.fNest.fSt0 o=put-o1.fNest.fSt0
o2&fRef>fNest&fRe0=!put-o1&fNest.fRe0 o=!put-o1&fNest.fRe0
$/tstEnvVars2/
$=/tstEnvVarsS/
### start tst tstEnvVarsS #########################################
oS=<oS> oS&fStS=<put oS.fStS>
oS&fStV.0=1 oS&fStV.1=<put oS.fStV.1>
m.oS.fStR.0=2 .2=!<put oS.fStR.2>
oS&fStR.0=2 .1=!<put oS.fStR.1> .2=!<put oS.fStR.2>
m.oS.0=9876 .1234=<put oS.1234>
*** err: undefined var oS&12
oS&0=9876 .12=M. .1234=<put oS.1234>
$/tstEnvVarsS/
$=/tstEnvVars3/
### start tst tstEnvVars3 #########################################
m.<o0>=*o0*val vGet(<o0>>)=*o0*val
m.<o0>.fSt0=*o0.fSt0*val vGet(<o0>>fSt0)=*o0.fSt0*val
m.<o0>.fRe0=<o1> vGet(<o0>>fRe0)=<o1>
m.<o1>=*o1*val vGet(<o0>>fRe0>)=*o1*val
m.<o1>.fStr=*o1.fStr*val vGet(<o0>>fRe0>fStr)=*o1.fStr*val
m.V.tstEnvVar0=<o0> vGet(tstEnvVar0)=<o0>
m.V.tstEnvVar0=<o0> vGet(tstEnvVar0&)=<o0>
m.<o0>=*o0*val vGet(tstEnvVar0&>)=*o0*val
m.<o0>.fSt0=*o0.fSt0*val vGet(tstEnvVar0&fSt0)=*o0.fSt0*val
m.<o0>.fRe0=<o1> vGet(tstEnvVar0&fRe0)=<o1>
m.<o1>=*o1*val vGet(tstEnvVar0&fRe0>)=*o1*val
m.<o1>.fStr=*o1.fStr*val vGet(tstEnvVar0&fRe0>fStr)=*o1.fStr*val
m.<o1>.fVar=tstEnvVar2 vGet(tstEnvVar0&fRe0>fVar)=tstEnvVar2
m.<o2>=*o2*val vGet(tstEnvVar0&fRe0>fVar&)=<o2>
m.<o2>=*o2*val vGet(tstEnvVar0&fRe0>fVar&>)=*o2*val
m.<o2>.fStr=*o2.fStr*val vGet(tstEnvVar0&fRe0>fVar&fStr)=*o2.fStr*v+
al
m.<o0>=*o0*put2 vGet(<o0>>)=*o0*put2
m.<o0>.fSt0=*o0.fSt0*put2 vGet(<o0>>fSt0)=*o0.fSt0*put2
m.<o1>=*o0>fRe0>put2 vGet(<o0>>fRe0>)=*o0>fRe0>put2
m.<o1>.fStr=*o0>fRe0>fStr*put2 vGet(<o0>>fRe0>fStr)=*o0>fRe0>fStr*p+
ut2
m.<o0>=*v0&>*put3 vGet(tstEnvVar0&>)=*v0&>*put3
m.<o0>.fSt0=*v0&fSt0*put3 vGet(tstEnvVar0&fSt0)=*v0&fSt0*put3
m.<o1>=*v0&fRe0>*put3 vGet(tstEnvVar0&fRe0>)=*v0&fRe0>*put3
m.<o1>.fStr=*v0&fRe0>fStr*put3 vGet(tstEnvVar0&fRe0>fStr)=*v0&fRe0>+
fStr*put3
m.<o2>=*v0&fRe0>fVar&>*put3 vGet(tstEnvVar0&fRe0>fVar&>)=*v0&fRe0>f+
Var&>*put3
m.<o2>.fStr=*v0&fRe0>fVar&fStr*put3 vGet(tstEnvVar0&fRe0>fVar&fStr)+
=*v0&fRe0>fVar&fStr*put3
$/tstEnvVars3/
*/
c0 = classNew('n? TstEnvVars0 u f fSt0 v, f = v, f fRe0 r')
c1 = classNew('n? TstEnvVars1 u f fStr v,f fRef r' ,
', f fNest TstEnvVars0, f = v, f fVar v')
o0 = oNew(c0)
o1 = oNew(c1)
o2 = oNew(c1)
call tst t, "tstEnvVars3"
call mAdd t.trans, o0 '<o0>', o1 '<o1>', o2 '<o2>'
fSt0 = 'fSt0'
fRe0 = 'fRe0'
fStr = 'fStr'
fRef = 'fRef'
fVar = 'fVar'
v0 = 'tstEnvVar0'
v2 = 'tstEnvVar2'
m.o0 = '*o0*val'
m.o0.fSt0 = '*o0.fSt0*val'
m.o0.fRe0 = o1
m.o1 = '*o1*val'
m.o1.fStr = '*o1.fStr*val'
m.o1.fRef = o2
m.o1.fVar = v2
m.o2 = '*o2*val'
m.o2.fStr = '*o2.fStr*val'
m.v.v0 = o0
m.v.v2 = o2
call tstEnvVarsMG o0, o0'>'
call tstEnvVarsMG o0'.'fSt0, o0'>'fSt0
call tstEnvVarsMG o0'.'fRe0, o0'>'fRe0
call tstEnvVarsMG o1, o0'>'fRe0'>'
call tstEnvVarsMG o1'.'fStr, o0'>'fRe0'>'fStr
call tstEnvVarsMG v'.'v0, v0
call tstEnvVarsMG v'.'v0, v0'&'
call tstEnvVarsMG o0, v0'&>'
call tstEnvVarsMG o0'.'fSt0, v0'&'fSt0
call tstEnvVarsMG o0'.'fRe0, v0'&'fRe0
call tstEnvVarsMG o1, v0'&'fRe0'>'
call tstEnvVarsMG o1'.'fStr, v0'&'fRe0'>'fStr
call tstEnvVarsMG o1'.'fVar, v0'&'fRe0'>'fVar
call tstEnvVarsMG o2, v0'&'fRe0'>'fVar'&'
call tstEnvVarsMG o2, v0'&'fRe0'>'fVar'&>'
call tstEnvVarsMG o2'.'fStr, v0'&'fRe0'>'fVar'&fStr'
call vPut o0'>', '*o0*put2'
call tstEnvVarsMG o0, o0'>'
call vPut o0'>'fSt0, '*o0.fSt0*put2'
call tstEnvVarsMG o0'.'fSt0, o0'>'fSt0
call vPut o0'>'fRe0'>', '*o0>fRe0>put2'
call tstEnvVarsMG o1, o0'>'fRe0'>'
call vPut o0'>'fRe0'>'fStr, '*o0>fRe0>fStr*put2'
call tstEnvVarsMG o1'.'fStr, o0'>'fRe0'>'fStr
call vPut v0'&>', '*v0&>*put3'
call tstEnvVarsMG o0, v0'&>'
call vPut v0'&'fSt0, '*v0&fSt0*put3'
call tstEnvVarsMG o0'.'fSt0, v0'&'fSt0
call vPut v0'&'fRe0'>', '*v0&fRe0>*put3'
call tstEnvVarsMG o1, v0'&'fRe0'>'
call vPut v0'&'fRe0'>'fStr, '*v0&fRe0>fStr*put3'
call tstEnvVarsMG o1'.'fStr, v0'&'fRe0'>'fStr
call vPut v0'&'fRe0'>'fVar'&>', '*v0&fRe0>fVar&>*put3'
call tstEnvVarsMG o2, v0'&'fRe0'>'fVar'&>'
call vPut v0'&'fRe0'>'fVar'&fStr', '*v0&fRe0>fVar&fStr*put3'
call tstEnvVarsMG o2'.'fStr, v0'&'fRe0'>'fVar'&fStr'
call tstEnd t, "tstEnvVars"
call tst t, "tstEnvVars"
call mAdd t.trans, o0 '<o0>', o1 '<o1>', o2 '<o2>'
call vRemove 'v2'
m.tst.adr1 = 'value eins'
put1 = vPut('v1', oMutate(tst'.'adr1, m.class_V))
call tstOut t, 'put v1' m.put1
call tstOut t, 'v1 hasKey' vHasKey('v1') 'get' vGet('v1')
call tstOut t, 'v2 hasKey' vHasKey('v2')
if 0 then
call tstOut t, 'v2 get' vGet('v2')
call vPut 'theBuf', jBuf()
call pipe '+F' , vGet('theBuf')
call out 'one to theBur'
call out 'two to theBuf'
call pipe '-'
call pipe '+f',, vGet('theBuf')
call pipeWriteNow
call pipe '-'
call tstOut t, 'v1='vGet('v1') 'o='vGet('v1')
call vPut 'v3', 'v3WieGehts?'
call tstOut t, 'v3='vGet('v3') 'o='vGet('v3')
call vPut 'v4', s2o('v4WieGehts?')
call tstOut t, 'v4='vGet('v4') 'o='vGet('v4')
call vPut 'o0', o0
call tstOut t, 'o o0='vGet('o0')
call tstOut t, 's o0='vGet('o0')
fSt0 = 'fSt0'
fRe0 = 'fRe0'
m.o0 = 'rexx o0-value'
m.o0.fSt0 = 'rexx o0.fSt0'
m.o0.fRe0 = s2o('rexx o0.fRe0')
call tstOut t, 'o o0='vGet('o0')
call tstOut t, 's o0='vGet('o0')
call tstOut t, 'o0&fSt0='vGet('o0&fSt0') 'o='vGet('o0&fSt0')
call tstOut t, 'o0&fRe0='vGet('o0&fRe0') 'o='vGet('o0&fRe0')
call tstOut t, 'o0&='vGet('o0&>') 'o='vGet('o0&>')
call vPut 'o0&>', 'put o0-value'
call vPut 'o0&fSt0', 'put o0.fSt0'
call vPut 'o0&fRe0', s2o('putO o0.fRe0')
call tstOut t, 'o o0='vGet('o0')
call tstOut t, 's o0='vGet('o0')
call tstOut t, 'o0&fSt0='vGet('o0&fSt0') 'o='vGet('o0&fSt0')
call tstOut t, 'o0&fRe0='vGet('o0&fRe0') 'o='vGet('o0&fRe0')
call tstOut t, 'o0&='vGet('o0&>') 'o='vGet('o0&>')
call tstEnd t
call tst t, "tstEnvVars1"
call mAdd t.trans, o0 '<o0>', o1 '<o1>', o2 '<o2>'
call vPut 'o1', o1
call vPut 'o1&>', 'put-o1-value'
call vPut 'o1&fStr', 'put-o1.fStr'
call vPut 'o1&fRef', vGet('o0')
call tstOut t, 'm.o1='m.o1 'm.o1.fStr='mGet(o1'.fStr'),
'm.o1.fRef='mGet(o1'.fRef')
call tstOut t, 'o o1='vGet('o1') 's o1='vGet('o1')
call tstOut t, 'o1&fStr='vGet('o1&fStr') 'o='vGet('o1&fStr')
call tstOut t, 'o1&='vGet('o1&>') 'o='vGet('o1&>')
call tstOut t, 'o1&fRef='vGet('o1&fRef') 'o='vGet('o1&fRef')
call tstOut t, 'o1&fRef>fSt0='vGet('o1&fRef>fSt0') ,
'o='vGet('o1&fRef>fSt0')
call tstOut t, 'o1&fRef>fRe0='vGet('o1&fRef>fRe0'),
'o='vGet('o1&fRef>fRe0')
call vPut 'o1&fNest.fSt0', 'put-o1.fNest.fSt0'
call vPut 'o1&fNest.fRe0', s2o('put-o1&fNest.fRe0')
call tstOut t, 'm.o1&fNest.fSt0=' mGet(o1'.fNest.fSt0') ,
'm.o1&fNest.fRe0=' mGet(o1'.fNest.fRe0')
call tstOut t, 'o1&fNest.fSt0='vGet('o1&fNest.fSt0'),
'o='vGet('o1&fNest.fSt0')
call tstOut t, 'o1&fNest&fRe0='vGet('o1&fNest.fRe0'),
'o='vGet('o1&fNest.fRe0')
call tstEnd t
call tst t, "tstEnvVars2"
call mAdd t.trans, o0 '<o0>', o1 '<o1>', o2 '<o2>'
call vPut 'o2', o2
call vPut 'o2&fRef', vGet('o1')
call tstOut t, 'o2='o2 'getO(o2)='vGet('o2'),
'getO(o2&fRef)='vGet('o2&fRef')
call tstOut t, 'o2&fRef>fStr='vGet('o2&fRef>fStr'),
'o='vGet('o2&fRef>fStr')
call tstOut t, 'o2&fRef>='vGet('o2&fRef>'),
'o='vGet('o2&fRef>')
call tstOut t, 'o2&fRef>fRef='vGet('o2&fRef>fRef') ,
'o='vGet('o2&fRef>fRef')
call tstOut t, 'o2&fRef>fRef>fSt0='vGet('o2&fRef>fRef>fSt0') ,
'o='vGet('o2&fRef>fRef>fSt0')
call tstOut t, 'o2&fRef>fRef>fRe0='vGet('o2&fRef>fRef>fRe0'),
'o='vGet('o2&fRef>fRef>fRe0')
call tstOut t, 'o2&fRef>fNest.fSt0='vGet('o2&fRef>fNest.fSt0'),
'o='vGet('o2&fRef>fNest.fSt0')
call tstOut t, 'o2&fRef>fNest&fRe0='vGet('o2&fRef>fNest.fRe0'),
'o='vGet('o1&fNest.fRe0')
call tstEnd t
cS = classNew('n? TstEnvVarsS u f fStS v,f fStV s v, f fStR s r',
', f fNeS s TstEnvVars0, f = s v')
oS = oNew(cS)
call vPut 'oS', oS
oT = oNew(cS)
call tst t, "tstEnvVarsS"
call mAdd t.trans, o0 '<o0>', o1 '<o1>', o2 '<o2>',
, oS '<oS>', oT '<oT>'
call mPut oS'.fStS', '<put oS.fStS>'
call tstOut t, 'oS='vGet('oS') 'oS&fStS='vGet('oS&fStS')
call mPut oS'.fStV.1', '<put oS.fStV.1>'
call mPut oS'.fStV.0', 1
call tstOut t, 'oS&fStV.0='vGet('oS&fStV.0'),
'oS&fStV.1='vGet('oS&fStV.1')
call mPut oS'.fStR.1', s2o('<put oS.fStR.1>')
call mPut oS'.fStR.2', s2o('<put oS.fStR.2>')
call mPut oS'.fStR.0', 2
call tstOut t, 'm.oS.fStR.0='mGet(oS'.fStR.0'),
'.2='mGet(oS'.fStR.2')
call tstOut t, 'oS&fStR.0='vGet('oS&fStR.0'),
'.1='vGet('oS&fStR.1') '.2='vGet('oS&fStR.2')
call mPut oS'.1234', '<put oS.1234>'
call mPut oS'.0', 9876
call mPut oS'.fStR.0', 2
call tstOut t, 'm.oS.0='mGet(oS'.0'),
'.1234='mGet(oS'.1234')
call tstOut t, 'oS&0='vGet('oS&0'),
'.12='vGet('oS&12') '.1234='vGet('oS&1234')
call tstEnd t
return
endProcedure tstEnvVars
tstEnvVarsMG: procedure expose m.
parse arg m, g
call tstOut t, 'm.'m'='m.m 'vGet('g')='vGet(g)
return
tstvWith: procedure expose m.
/*
$=/tstEW2/
### start tst tstEW2 ##############################################
tstK1 TSTEW1
tstK1& !get1 w
tstK1&f1 get1.f1 v
tstK1&f2 !get1.f2 w
tstK1&F3 get1.f3 v
ttstK1&F3.FEINS get1.f3.fEins v
tstK1&F3.FZWEI !get1.f3.fZwei w
tstK1&F3.FDREI o !get1.f3.fDrei w
tstK1&F3.FDREI !get1.f3.fDrei w
tstK1&F3.1 !get1.f3.1 w
tstK1&F3.2 TSTEW1
tstK1&F3.2>F1 get1.f1 v
tstK1&F3.2>F3.2>F2 !get1.f2 w
*** err: undefined var F1
F1 M..
F1 get1.f1 v
f2 !get1.f2 w
F3 get1.f3 v
F3.FEINS get1.f3.fEins v
F3.FZWEI !get1.f3.fZwei w
F3.FDREI o !get1.f3.fDrei w
F3.1 !get1.f3.1 w
pu1 F1 get1.f1 v
pu2 F1 get2.f1 v
po-2 F1 get1.f1 v
*** err: undefined var F1
po-1 F1 M..
$/tstEW2/ */
call pipeIni
c0 = classNew('n? TstEW0 u f FEINS v,f FZWEI w, f FDREI r,v,s r')
call classMet c0, 'oFlds' /* new would do it, but we donot use it*/
cl = classNew('n? TstEW u r TstEW0, f F1 v, f F2 r, f F3 TstEW0')
call classMet cl, 'oFlds' /* new would do it, but we donot use it*/
call oMutate tstEW1, cl
m.tstEW1 = s2o('get1 w')
m.tstEW1.f1 = 'get1.f1 v'
m.tstEW1.f2 = s2o('get1.f2 w')
m.tstEW1.f3 = 'get1.f3 v'
m.tstEW1.f3.fEins = 'get1.f3.fEins v'
m.tstEW1.f3.fZwei = s2o('get1.f3.fZwei w')
m.tstEW1.f3.fDrei = s2o('get1.f3.fDrei w')
m.tstEW1.f3.0 = 3
m.tstEW1.f3.1 = s2o('get1.f3.1 w')
m.tstEW1.f3.2 = tstEW1
m.tstEW1.f3.3 = s2o('get1.f3.3 w')
call oMutate tstEW2, cl
m.tstEW2 = s2o('get2 w')
m.tstEW2.f1 = 'get2.f1 v'
m.tstEW2.f2 = s2o('get2.f2 w')
call vPut 'tstK1', tstEW1
call tst t, 'tstEW2'
call tstOut t, 'tstK1 ' vGet('tstK1')
call tstOut t, 'tstK1& ' vGet('tstK1&>')
call tstOut t, 'tstK1&f1 ' vGet('tstK1&F1')
call tstOut t, 'tstK1&f2 ' vGet('tstK1&F2')
call tstOut t, 'tstK1&F3 ' vGet('tstK1&F3')
call tstOut t, 'ttstK1&F3.FEINS ' vGet('tstK1&F3.FEINS')
call tstOut t, 'tstK1&F3.FZWEI ' vGet('tstK1&F3.FZWEI')
call tstOut t, 'tstK1&F3.FDREI o ' vGet('tstK1&F3.FDREI')
call tstOut t, 'tstK1&F3.FDREI ' vGet('tstK1&F3.FDREI')
call tstOut t, 'tstK1&F3.1 ' vGet('tstK1&F3.1')
call tstOut t, 'tstK1&F3.2 ' vGet('tstK1&F3.2')
call tstOut t, 'tstK1&F3.2>F1 ' vGet('tstK1&F3.2>F1')
call tstOut t, 'tstK1&F3.2>F3.2>F2' ,
vGet('tstK1&F3.2>F3.2>F2')
call tstOut t, 'F1 ' vGet('F1')
call vWith '+', tstEW1
call tstOut t, 'F1 ' vGet('F1')
call tstOut t, 'f2 ' vGet('F2')
call tstOut t, 'F3 ' vGet('F3')
call tstOut t, 'F3.FEINS ' vGet('F3.FEINS')
call tstOut t, 'F3.FZWEI ' vGet('F3.FZWEI')
call tstOut t, 'F3.FDREI o ' vGet('F3.FDREI')
call tstOut t, 'F3.1 ' vGet('F3.1')
call tstOut t, 'pu1 F1 ' vGet('F1')
call vWith '+', tstEW2
call tstOut t, 'pu2 F1 ' vGet('F1')
call vWith '-'
call tstOut t, 'po-2 F1 ' vGet('F1')
call vWith '-'
call tstOut t, 'po-1 F1 ' vGet('F1')
call tstEnd t
/*
$=/tstEW3/
### start tst tstEW3 ##############################################
. s c3&F1 = v(c3&f1)
*** err: null address at &FEINS in c3&F1&FEINS
*** err: undefined var c3&F1&FEINS
. s c3&F1&FEINS = M..
*** err: null address at &FEINS in c3&F3&FEINS
*** err: null address at &FEINS in c3&F3&FEINS
*** err: undefined var c3&F3&FEINS
. s c3&F3&FEINS = M..
. s c3&F3.FEINS = val(c3&F3.FEINS)
*** err: undefined var c3&FEINS
. s c3&FEINS = M..
getO c3&
aft Put s c3&>FEINS = v&&fEins
Push c3 s F3.FEINS = val(c3&F3.FEINS)
aftPut= s F3.FEINS = pushPut(F3.FEINS)
push c4 s F1 = v(c4&f1)
put f2 s F2 = put(f2)
put .. s F3.FEINS = put(f3.fEins)
popW c4 s F1 = v(c3&f1)
*** err: undefined var F1
popW c3 s F1 = M..
. s F222 = f222 pop stop
$/tstEW3/
*/
call tst t, 'tstEW3'
c3 = oNew('TstEW')
call mAdd t.trans, c3 '<c3>'
m.c3.f1 = 'v(c3&f1)'
call vPut 'c3', c3
call tstEnvSG , 'c3&F1'
call tstEnvSG , 'c3&F1&FEINS'
call tstEnvSG , 'c3&F3&FEINS'
call vPut 'c3&F3.FEINS', 'val(c3&F3.FEINS)'
call tstEnvSG , 'c3&F3.FEINS'
call tstEnvSG , 'c3&FEINS'
call tstOut t, 'getO c3&', vGet('c3&')
call vPut 'c3&>', oNew('TstEW0')
call vPut 'c3&>FEINS', 'v&&fEins'
call tstEnvSG 'aft Put', 'c3&>FEINS'
call vWith '+', c3
call tstEnvSG 'Push c3', 'F3.FEINS'
call vPut 'F3.FEINS', 'pushPut(F3.FEINS)'
call tstEnvSG 'aftPut=', 'F3.FEINS'
c4 = oNew('TstEW')
call mAdd t.trans, c4 '<c4>'
m.c4.f1 = 'v(c4&f1)'
call vPut f222, 'f222 no stop'
call vWith '+', c4
call tstEnvSG 'push c4', f1
call vPut f2, 'put(f2)'
call tstEnvSG 'put f2', f2
call vPut f222, 'f222 stopped', 1
call vPut 'F3.FEINS', 'put(f3.fEins)'
call tstEnvSG 'put .. ', 'F3.FEINS'
call vWith '-'
call tstEnvSG 'popW c4', f1
call vWith '-'
call vPut f222, 'f222 pop stop'
call tstEnvSG 'popW c3', f1
call tstEnvSG , f222
call tstEnd t
return
endProcedure tstvWith
tstEnvSG: procedure expose m. t
parse arg txt, nm
call tstOut t, left(txt,10)'s' left(nm, 15)'=' vGet(nm)
return
tstPipeLazy: procedure expose m.
call pipeIni
/*
$=/tstPipeLazy/
### start tst tstPipeLazy #########################################
a1 vor pipeBegin loop lazy 0 writeNow *** <class TstPipeLazyBuf>
bufOpen <
bufClose
#jIn 2# tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
a5 vor 2 writeNow in inIx 4
a2 vor writeNow jBuf
jBuf line 1
jBuf line 2
a3 vor writeNow in inIx 1
tst in line 2 zwei ; .
tst in line 3 drei .schluss..
a4 vor barLast inIx 4
a6 vor barEnd inIx 4
a7 nach barEnd lazy 0 writeNow ***
b1 vor barBegin lazy 0 writeNow *** <class TstPipeLazyRdr>
RdrOpen <
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
rdrClose
b4 vor writeNow
b2 vor writeNow rdr inIx 2
jRead lazyRdr
tst in line 3 drei .schluss..
jRead lazyRdr
b3 vor barLast inIx 4
b5 vor barEnd inIx 4
b6 nach barEnd lazy 0 writeNow ***
a1 vor pipeBegin loop lazy 1 writeAll *** +
.<class TstPipeLazyBuf>
a5 vor 2 writeAll in inIx 0
a2 vor writeAll jBuf
bufOpen <
jBuf line 1
jBuf line 2
bufClose
a3 vor writeAll in inIx 0
#jIn 1# tst in line 1 eins ,
tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
tst in line 3 drei .schluss..
#jIn eof 4#
a4 vor barLast inIx 0
a6 vor barEnd inIx 4
a7 nach barEnd lazy 1 writeAll ***
b1 vor barBegin lazy 1 writeAll *** <class TstPipeLazyRdr>
b4 vor writeAll
b2 vor writeAll rdr inIx 1
RdrOpen <
jRead lazyRdr
#jIn 2# tst in line 2 zwei ; .
tst in line 2 zwei ; .
jRead lazyRdr
#jIn 3# tst in line 3 drei .schluss..
tst in line 3 drei .schluss..
jRead lazyRdr
#jIn eof 4#
rdrClose
b3 vor barLast inIx 1
b5 vor barEnd inIx 4
b6 nach barEnd lazy 1 writeAll ***
$/tstPipeLazy/ */
call tst t, "tstPipeLazy"
do lz=0 to 1
if lz then
w = 'writeAll'
else
w = 'writeNow'
m.t.inIx = 1-lz
ty = classNew('n? TstPipeLazyBuf u JRWDeleg', 'm',
, 'jOpen call tstOut "T", "bufOpen" opt;',
'call jOpen m.m.deleg, opt',
, 'jClose call tstOut "T", "bufClose";',
'call jClose m.m.deleg')
if \ lz then
call mAdd t'.TRANS', ty '<class TstPipeLazyBuf>'
call out 'a1 vor pipeBegin loop lazy' lz w '***' ty
call pipe '+N'
call out 'a2 vor' w 'jBuf'
b = oNew('TstPipeLazyBuf', jBuf('jBuf line 1','jBuf line 2'))
interpret 'call pipe'w 'b'
call out 'a3 vor' w 'in inIx' m.t.inIx
interpret 'call pipe'w
call out 'a4 vor barLast inIx' m.t.inIx
call pipe 'P|'
call out 'a5 vor 2' w 'in inIx' m.t.inIx
interpret 'call pipe'w
call out 'a6 vor barEnd inIx' m.t.inIx
call pipe '-'
call out 'a7 nach barEnd lazy' lz w '***'
ty = classNew('n? TstPipeLazyRdr u JRW', 'm',
, 'jOpen call tstOut "T", "RdrOpen" opt',
, 'jRead call out "jRead lazyRdr"; mr = m.m.rdr;' ,
'm.rStem.0 = jRead(mr); m.rStem.1 = m.mr',
, 'jClose call tstOut "T", "rdrClose";')
if \ lz then
call mAdd t'.TRANS', ty '<class TstPipeLazyRdr>'
r = oNew('TstPipeLazyRdr')
m.r.rdr = m.j.in
if lz then
call mAdd t'.TRANS', r '<lazyRdr>'
m.t.inIx = 2-lz
call out 'b1 vor barBegin lazy' lz w '***' ty
call pipe '+N'
call out 'b2 vor' w 'rdr inIx' m.t.inIx
interpret 'call pipe'w 'r'
call out 'b3 vor barLast inIx' m.t.inIx
call pipe 'P|'
call out 'b4 vor' w
interpret 'call pipe'w
call out 'b5 vor barEnd inIx' m.t.inIx
call pipe '-'
call out 'b6 nach barEnd lazy' lz w '***'
end
call tstEnd t
return
endProcedure tstPipeLazy
tstEnvClass: procedure expose m.
call pipeIni
/*
$=/tstEnvClass/
### start tst tstEnvClass #########################################
a0 vor pipeBegin loop lazy 0 writeNow *** TY
#jIn 2# tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
a5 vor writeNow
a1 vor jBuf()
a2 vor writeNow b
tstR: @<o20 of TstEnvClass10> isA :TstEnvClass10
tstR: .f11 = .
tstR: .F12 = value F12 of o1 <o20 of TstEnvClass10>
tstR: .f13 = .
WriteO o2
tstR: @<oc0 of TstEnvClass20> isA :TstEnvClass20 = valueO2Lazy0
tstR: .f24 = .
tstR: .F25 = value F25 of o20 <o20 of TstEnvClass20>
a3 vor writeNow
tst in line 2 zwei ; .
tst in line 3 drei .schluss..
a4 vor barLast inIx 4
a6 vor barEnd
a7 nach barEnd lazy 0 writeNow ***
a0 vor pipeBegin loop lazy 1 writeAll *** TY
a5 vor writeAll
a1 vor jBuf()
a2 vor writeAll b
tstR: @<o21 of TstEnvClass10> isA :TstEnvClass10
tstR: .f11 = .
tstR: .F12 = value F12 of o1 <o21 of TstEnvClass10>
tstR: .f13 = .
WriteO o2
tstR: @<oc1 of TstEnvClass20> isA :TstEnvClass20 = valueO2Lazy1
tstR: .f24 = .
tstR: .F25 = value F25 of o21 <o21 of TstEnvClass20>
a3 vor writeAll
#jIn 1# tst in line 1 eins ,
tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
tst in line 3 drei .schluss..
#jIn eof 4#
a4 vor barLast inIx 0
a6 vor barEnd
a7 nach barEnd lazy 1 writeAll ***
$/tstEnvClass/ */
call tst t, "tstEnvClass"
t10 = classNew('n? TstEnvClass10 u f f11 v, f F12 v, f f13 v')
t20 = classNew('n? TstEnvClass20 u v, f f24 v, f F25 v')
do lz=0 to 1
if lz then
w = 'writeAll'
else
w = 'writeNow'
m.t.inIx = 1-lz
call out 'a0 vor pipeBegin loop lazy' lz w '***' ty
call pipe '+N'
call out 'a1 vor jBuf()'
b = jOpen(jBuf(), m.j.cWri)
o1 = oNew('TstEnvClass10')
m.o1.F12 = 'value F12 of o1' o1
call mAdd t'.TRANS', o1 '<o2'lz 'of TstEnvClass10>'
call jWrite b, o1
call jWrite b, 'WriteO o2'
o2 = oNew('TstEnvClass20')
m.o2 = 'valueO2Lazy'lz
m.o2.F25 = 'value F25 of o2'lz o2
oc = oCopy(oCopy(o2))
call mAdd t'.TRANS', o2 '<o2'lz 'of TstEnvClass20>'
call mAdd t'.TRANS', oc '<oc'lz 'of TstEnvClass20>'
call jWrite b, oc
call out 'a2 vor' w 'b'
interpret 'call pipe'w jClose(b)
call out 'a3 vor' w
interpret 'call pipe'w
call out 'a4 vor barLast inIx' m.t.inIx
call pipe 'P|'
call out 'a5 vor' w
interpret 'call pipe'w
call out 'a6 vor barEnd'
call pipe '-'
call out 'a7 nach barEnd lazy' lz w '***'
end
call tstEnd t
m.t.trans.0 = 0
return
endProcedure tstEnvClass
tstDsn: procedure expose m.
/*
$=/tstDsn/
### start tst tstDsn ##############################################
aa has 4 members: created
- aa(DREI) 3 lines, aa(drei) 1/3, aa(drei) 2/3, aa(drei) 3/3
- aa(EINS) 1 lines, aa(eins) 1/1
- aa(NULL) 0 lines
- aa(ZWEI) 2 lines, aa(zwei) 1/2, aa(zwei) 2/2
bb has 1 members: copy eins, eins1
- bb(EINS1) 1 lines, aa(eins) 1/1
$/tstDsn/
$=/tstDsnL/
### start tst tstDsnL #############################################
bb has 2 members: copy zwei
- bb(EINS1) 1 lines, aa(eins) 1/1
- bb(ZWEI) 2 lines, aa(zwei) 1/2, aa(zwei) 2/2
cc has 1 members: copy drei cc new
- cc(DREI) 3 lines, aa(drei) 1/3, aa(drei) 2/3, aa(drei) 3/3
bb has 5 members: copy
- bb(DREI) 3 lines, aa(drei) 1/3, aa(drei) 2/3, aa(drei) 3/3
- bb(EINS) 1 lines, aa(eins) 1/1
- bb(EINS1) 1 lines, aa(eins) 1/1
- bb(NULL) 0 lines
- bb(ZWEI) 2 lines, aa(zwei) 1/2, aa(zwei) 2/2
bb has 8 members: copy null eins drei >*4
- bb(DREI) 3 lines, aa(drei) 1/3, aa(drei) 2/3, aa(drei) 3/3
- bb(DREI4) 3 lines, aa(drei) 1/3, aa(drei) 2/3, aa(drei) 3/3
- bb(EINS) 1 lines, aa(eins) 1/1
- bb(EINS1) 1 lines, aa(eins) 1/1
- bb(EINS4) 1 lines, aa(eins) 1/1
- bb(NULL) 0 lines
- bb(NULL4) 0 lines
- bb(ZWEI) 2 lines, aa(zwei) 1/2, aa(zwei) 2/2
bb has 7 members: delete null4
- bb(DREI) 3 lines, aa(drei) 1/3, aa(drei) 2/3, aa(drei) 3/3
- bb(DREI4) 3 lines, aa(drei) 1/3, aa(drei) 2/3, aa(drei) 3/3
- bb(EINS) 1 lines, aa(eins) 1/1
- bb(EINS1) 1 lines, aa(eins) 1/1
- bb(EINS4) 1 lines, aa(eins) 1/1
- bb(NULL) 0 lines
- bb(ZWEI) 2 lines, aa(zwei) 1/2, aa(zwei) 2/2
bb has 3 members: delete eins4 drei4 eins drei
- bb(EINS1) 1 lines, aa(eins) 1/1
- bb(NULL) 0 lines
- bb(ZWEI) 2 lines, aa(zwei) 1/2, aa(zwei) 2/2
bb has 3 members: delete drei4
- bb(EINS1) 1 lines, aa(eins) 1/1
- bb(NULL) 0 lines
- bb(ZWEI) 2 lines, aa(zwei) 1/2, aa(zwei) 2/2
before seqFuenf 5 lines, seqFuenf 1/5, seqFuenf 2/5, seqFue+
nf 3/5, seqFuenf 4/5, seqFuenf 5/5
copy zwei seqFuenf 2 lines, aa(zwei) 1/2, aa(zwei) 2/2
copy null seqFuenf 0 lines
before seqVier 4 lines, seqVier 1/4, seqVier 2/4, seqVier +
3/4, seqVier 4/4
bb has 4 members: copy .seqVier
- bb(EINS1) 1 lines, aa(eins) 1/1
- bb(FROVIER) 4 lines, seqVier 1/4, seqVier 2/4, seqVier +
3/4, seqVier 4/4
- bb(NULL) 0 lines
- bb(ZWEI) 2 lines, aa(zwei) 1/2, aa(zwei) 2/2
delete seqFuenf does not exist
delete seqFuenf does not exist
$/tstDsnL/
*/
do sx=0 to m.tst_csmRZ \== ''
sys = copies(m.tst_csmRz'/', sx)
say 'csm/sys='sys '+++++++++++++++++++++++++++'
call tst t, 'tstDsn'
pr = tstFileName(sys'tstDsn', 'r')
call tstDsnWr pr'.aa(null) ::f', 0
call tstDsnWr pr'.aa(eins)', 1
call tstDsnWr pr'.aa(zwei)', 2
call tstDsnWr pr'.aa(drei)', 3
call tstDsnWr pr'.seqVier ::f', 4
call tstDsnWr pr'.seqFuenf ::f', 5
call tstDsnRL t, pr'.aa', 'created'
call dsnCopy pr'.aa(eins)', pr'.bb(eins1)'
call tstDsnRL t, pr'.bb', 'copy eins, eins1'
call tstEnd t
if sx & \ m.tst_long then
iterate
call tst t, 'tstDsnL'
call dsnCopy pr'.aa(zwei)', pr'.bb'
call tstDsnRL t, pr'.bb', 'copy zwei'
call dsnCopy pr'.aa(drei)', pr'.cc'
call tstDsnRL t, pr'.cc', 'copy drei cc new'
call dsnCopy pr'.aa(*', pr'.bb'
call tstDsnRL t, pr'.bb', 'copy'
call dsnCopy pr'.aa', pr'.bb', 'null>null4 eins>eins4' ,
'drei>drei4'
call tstDsnRL t, pr'.bb', 'copy null eins drei >*4'
call dsnDel pr'.bb(null4)'
call tstDsnRL t, pr'.bb', 'delete null4'
call dsnDel pr'.bb(eins)'
call dsnDel pr'.bb(eins4)'
call dsnDel pr'.bb', 'drei drei4'
call tstDsnRL t, pr'.bb', 'delete eins4 drei4 eins drei'
call dsnDel pr'.bb(drei4)'
call tstDsnRL t, pr'.bb', 'delete drei4'
call tstOut t, 'before' tstDsnr1(pr'.seqFuenf')
call dsnCopy pr'.aa(zwei)', pr'.seqFuenf'
call tstOut t, 'copy zwei' tstDsnr1(pr'.seqFuenf')
call dsnCopy pr'.aa(null)', pr'.seqFuenf'
call tstOut t, 'copy null' tstDsnr1(pr'.seqFuenf')
call tstOut t, 'before' tstDsnr1(pr'.seqVier')
call dsnCopy pr'.seqVier', pr'.bb(froVier)'
call tstDsnRL t, pr'.bb', 'copy .seqVier'
call dsnDel pr'.seqFuenf'
call tstOut t, 'delete' tstDsnr1(pr'.seqFuenf')
call dsnDel pr'.seqFuenf'
call tstOut t, 'delete' tstDsnr1(pr'.seqFuenf')
/* delete all to avoid mixup in next loop */
pr = tstFileName(sys'tstDsn', 'r')
call tstEnd t
end
return
endProcedure tstDsn
tstDsnWr: procedure expose m.
parse arg dsn suf, li
q = strip(substr(dsn, lastPos('.', dsn) + 1))
do ox=1 to li
o.ox = q ox'/'li
end
call writeDsn dsn suf, o., li, 1
return
endProcedure tstDsnWr
tstDsnR1: procedure expose m.
parse arg dsn
q = strip(substr(dsn, lastPos('.', dsn) + 1))
if \ dsnExists(dsn) then
return q 'does not exist'
call readDsn dsn, i.
r = q i.0 'lines'
do ix=1 to i.0
r = r',' strip(i.ix)
end
return r
endProcedure tstDsnR1
tstDsnRL: procedure expose m.
parse arg t, dsn, msg
q = strip(substr(dsn, lastPos('.', dsn) + 1))
call mbrList tst_dsnL, dsn
call tstOut t, q 'has' m.tst_dsnL.0 'members:' msg
do mx=1 to m.tst_dsnL.0
call tstOut t, '-' tstDsnR1(dsn'('m.tst_dsnL.mx')')
end
return
endProcedure tstDsnRL
tstDsn2: procedure expose m.
/*
$=/tstDsnEq/
### start tst tstDsnEq ############################################
seq= TSTDSNS 1 lines, TSTDSNS 1/1
p2s= TSTDSNS 2 lines, TSTDSNP(eins) 1/2, TSTDSNP(eins) 2/2
TSTDSNP has 1 members: par=
- TSTDSNP(ZWEI) 2 lines, TSTDSNP(eins) 1/2, TSTDSNP(eins) 2/2
TSTDSNP has 4 members: s>*=
- TSTDSNP(DREI) 2 lines, TSTDSNP(eins) 1/2, TSTDSNP(eins) 2/2
- TSTDSNP(EINS) 2 lines, TSTDSNP(eins) 1/2, TSTDSNP(eins) 2/2
- TSTDSNP(SEQ) 1 lines, TSTDSNS 1/1
- TSTDSNP(ZWEI) 2 lines, TSTDSNP(eins) 1/2, TSTDSNP(eins) 2/2
$/tstDsnEq/
$=/tstDsnLng/
### start tst tstDsnLng ###########################################
seq= TSTDSNS 1 lines, TSTDSNS 1/1
p2s= TSTDSNS 2 lines, TSTDSNP(eins) 1/2, TSTDSNP(eins) 2/2
TSTDSNP has 1 members: par=
- TSTDSNP(ZWEI) 2 lines, TSTDSNP(eins) 1/2, TSTDSNP(eins) 2/2
TSTDSNP has 4 members: s>*=
- TSTDSNP(DREI) 2 lines, TSTDSNP(eins) 1/2, TSTDSNP(eins) 2/2
- TSTDSNP(EINS) 2 lines, TSTDSNP(eins) 1/2, TSTDSNP(eins) 2/2
- TSTDSNP(SEQ) 1 lines, TSTDSNS 1/1
- TSTDSNP(ZWEI) 2 lines, TSTDSNP(eins) 1/2, TSTDSNP(eins) 2/2
$/tstDsnLng/
$=/tstDsnSht/
### start tst tstDsnSht ###########################################
seq= TSTDSNS 1 lines, TSTDSNS 1/
p2s= TSTDSNS 2 lines, TSTDSNP(ei, TSTDSNP(ei
TSTDSNP has 1 members: par=
- TSTDSNP(ZWEI) 2 lines, TSTDSNP(ei, TSTDSNP(ei
TSTDSNP has 4 members: s>*=
- TSTDSNP(DREI) 2 lines, TSTDSNP(ei, TSTDSNP(ei
- TSTDSNP(EINS) 2 lines, TSTDSNP(ei, TSTDSNP(ei
- TSTDSNP(SEQ) 1 lines, TSTDSNS 1/
- TSTDSNP(ZWEI) 2 lines, TSTDSNP(ei, TSTDSNP(ei
$/tstDsnSht/
*/
call tstIni
tCnt = 0
cRZ = (m.tst_csmRZ \== '') * 3
if m.tst_long then
cSel = ''
else do /* one with iebCopy one with copyW */
cSel = random(0, 10*(cRz+1) - 1)
cSel = cSel + cSel % 5 + 2 random(0, 2*(cRz+1) - 1) * 6 + 1
say 'tstDsn2 selects' cSel
end
do sx=0 to cRz
sFr = copies(m.tst_csmRz'/', sx >= 2)
sTo = copies(m.tst_csmRz'/', sx // 2)
do fx=1 to 2
ff = substr('FV', fx, 1)
fWr = 1
do ty=1 to 2
tx = 1 + (fx <> ty)
tA = word('::F50 ::V54', tx)
tf = substr(tA, 3, 1)
tA = copies(tA, ff <> tf)
do lx=1 to 3 /* 1 + 2 * (ff = tf) */
tCnt = tCnt + 1
if wordPos(tCnt, cSel) < 1 & cSel <> '' then
iterate
if lx = 1 then do
tq = 'Eq'
end
else if lx = 2 then do
tq = 'Lng'
tA = '::'tf'60'
end
else do
tq = 'Sht'
tA = '::'tf || if(tf=='F', 10, 14)
end
if fWr then do
fWr = 0
fS = tstFileName(sFr'fr'ff'.tstDsnS', 'r')
fP = tstFileName(sFr'fr'ff'.tstDsnP', 'r')
call tstDsnWr fS '::'ff'50', 1
call tstDsnWr fP'(eins) ::'ff'50', 2
end
call tst t, 'tstDsn'tq
say '>>>>> csm/sys from' sFr ff 'to' sTo tf tq tA ,
'<<<<<' tCnt 'ff=tf' (ff=tf)
tS = tstFileName(sTo || tq || tf'.tstDsnS', 'r')
tP = tstFileName(sTo || tq || tf'.tstDsnP', 'r')
call dsnCopy fS, tS tA
call tstOut t, 'seq=' tstDsnR1(tS)
call dsnCopy '-' fP'(eins)', tS tA
call tstOut t, 'p2s=' tstDsnR1(tS)
call dsnCopy fP'(eins)', tP'(zwei)' tA
call tstDsnRL t, tP, 'par='
call dsnCopy fS, tP'(seq)' tA
call dsnCopy fP, tP tA, 'eins>drei'
call dsnCopy fP, tP tA
call tstDsnRL t, tP, 's>*='
call tstEnd t
end
end
end
end
return
endProcedure tstDsn2
tstDsnEx: procedure expose m.
/*
$=/tstDsnEx/
### start tst tstDsnEx ############################################
dsnExists(A540769.WK.rexx) 1
dsnExists(RZZ/A540769.WK.rexx) 1
dsnExists(A540769.WK.wk.rexxYY) 0
dsnExists(RZZ/A540769.WK.wk.rexxYY) 0
dsnExists(A540769.WK.rexx(wsh)) 1
dsnExists(RZZ/A540769.WK.rexx(wsh)) 1
dsnExists(A540769.WK.rexx(nonono)) 0
dsnExists(RZZ/A540769.WK.rexx(nonono)) 0
dsnExists(A540769.WK.rxxYY(nonon)) 0
dsnExists(RZZ/A540769.WK.rxxYY(nonon)) 0
*** err: csm rc=8 .
. e 1: stmt=csmExec allocate SYSTEM(?QZ) DDNAME(MBRLISDD) DATASE+
T('A540769.WK.RXXYY') DISP(SHR) timeout(30) .
. e 2: CSMSI77E INVALID SYSTEM NAME (MUST BE * OR A VALID NAME) +
(COL:8)
. e 3: CSMSI77E SYSTEM=?QZ,TIMEOUT=30 .
%%%
dsnExists(?qZ/A540769.WK.rxxYY(nonon)) 0
$/tstDsnEx/
*/
call tst t, 'tstDsnEx'
lst = 'rexx wk.rexxYY rexx(wsh) rexx(nonono) rxxYY(nonon)'
rz = m.tst_csmRZ
do lx =1 to words(lst)
d1 = 'A540769.WK.'word(lst,lx)
call tstOut t, 'dsnExists('d1')' dsnExists(d1)
call tstOut t, 'dsnExists('rz'/'d1')' dsnExists(rz'/'d1)
end
call mAdd t'.TRANS', '00'x '?', '0A'x '?'
call tstOut t, 'dsnExists(?qZ/'d1')' dsnExists('?qz/'d1)
call tstEnd t
return
endProceudre tstDsnEx
tstFile: procedure expose m.
call catIni
/*
$=/tstFile/
### start tst tstFile #############################################
write read 0 last 10 vor anfang
write read 1 last 80 links1 1 und rechts | ..
write read 2 last 80 liinks2 2 und rechts | ..
write read 5 last 80 links5 5 rechts5
write read 99 last 80 links99 99 rechts
write read 100 last 80 links100 100 rechts
write read 101 last 80 links101 101 rechts
write read 999 last 80 links999 999 rechts
write read 1000 last 80 links1000 1000 rechts
write read 1001 last 80 links1001 1001 rechts
write read 2109 last 80 links2109 2109 rechts
out > eins 1 +
. .
out > eins 2 schluss. +
. .
buf eins
buf zwei
buf drei
out > zwei mit einer einzigen Zeile +
. .
. links1 1 und rechts | . +
. .
$/tstFile/ */
call tst t, "tstFile"
pds = tstFilename('lib', 'r')
call tstFileWr pds, 0, ' links0', ' und rechts | . '
call tstFileWr pds, 1, ' links1', ' und rechts | . '
call tstFileWr pds, 2, 'liinks2', ' und rechts | . '
call tstFileWr pds, 5, 'links5', 'rechts5'
call tstFileWr pds, 99, 'links99', 'rechts'
call tstFileWr pds, 100, 'links100', 'rechts'
call tstFileWr pds, 101, 'links101', 'rechts'
call tstFileWr pds, 999, 'links999', 'rechts'
call tstFileWr pds, 1000, 'links1000', 'rechts'
call tstFileWr pds, 1001, 'links1001', 'rechts'
call tstFileWr pds, 2109, 'links2109', 'rechts'
pd2 = tstFilename('li2', 'r')
call pipeIni
call pipe '+F', s2o(tstPdsMbr(pd2, 'eins'))
call out tstFB('out > eins 1') /* simulate fixBlock on linux */
call out tstFB('out > eins 2 schluss.')
call pipe '-'
call pipe '+F', s2o(tstPdsMbr(pd2, 'zwei'))
call out tstFB('out > zwei mit einer einzigen Zeile')
call pipe '-'
b = jBuf("buf eins", "buf zwei", "buf drei")
call pipe '+ffffff', , s2o(tstPdsMbr(pd2, 'eins')), b,
,jBuf(),
,s2o(tstPdsMbr(pd2, 'zwei')),
,s2o(tstPdsMbr(pds, 'wr0')),
,s2o(tstPdsMbr(pds, 'wr1'))
call pipeWriteNow
call pipe '-'
call tstEnd t
return
endProcedure tstFile
/*--- simulate fixBlock 80 on linux ---------------------------------*/
tstFB: procedure expose m.
parse arg line, recL
if m.err_os \== 'LINUX' then
return line
else if recL == '' then
return left(line, 80)
else
return left(line, recL)
endProcedure tstFB
tstPdsMbr: procedure expose m.
parse arg pds, mbr
if m.err_os = 'TSO' then
return pds'('mbr') ::F'
if m.err_os = 'LINUX' then
return pds'.'mbr
call err 'tstPdsMbr implement os' m.err_os
endProcedure tstPdsMbr
tstFileWR: procedure expose m.
parse arg dsn, num, le, ri
io = file(tstPdsMbr(dsn, 'wr'num))
call jOpen io, m.j.cWri
do x = 1 to num /* simulate fixBlock 80 on LINUX*/
call jWrite io, tstFB(le x ri)
end
call jClose io
if num > 100 then
call jReset io, tstPdsMbr(dsn, 'wr'num)
call jOpen io, m.j.cRead
m.io = 'vor anfang'
do x = 1 to num
if \ jRead(io) then
call err x 'not jRead'
else if m.io <> le x ri then
call err x 'read mismatch' m.io
end
if jRead(io) then
call err x 'jRead but should be eof 1'
if jRead(io) then
call err x'+1 jjRead but should be eof 2'
call jClose io
call tstOut t, 'write read' num 'last' length(m.io) strip(m.io,'t')
return
endProcedure tstFileWr
tstFileList: procedure expose m.
call catIni
/*
$=/tstFileList/
### start tst tstFileList #########################################
empty dir
filled dir
<<pref 2 List>>eins
<<pref 2 List>>zwei
<<pref 2 List>>drei
<<pref 2 List>>vier
filled dir recursive
<<pref 2 List>>eins
<<pref 2 List>>zwei
<<pref 2 List>>drei
<<pref 2 List>>vier
<<pref 1 vier>>eins
<<pref 1 vier>>zwei
<<pref 1 vier>>drei
$/tstFileList/ */
/*
$=/tstFileListTSO/
### start tst tstFileListTSO ######################################
empty dir dsnList 0
empty dir fileList
filled dir .* dsnList 3
<<pref 2 LIST>>DREI
<<pref 2 LIST>>EINS
<<pref 2 LIST>>ZWEI
filled dir fileList
<<pref 2 LIST>>DREI
<<pref 2 LIST>>EINS
<<pref 2 LIST>>ZWEI
filled dir dsnList 6
<<pref 2 LIST>>DREI
<<pref 2 LIST>>EINS
<<pref 1 VIER>>DREI
<<pref 1 VIER>>EINS
<<pref 1 VIER>>ZWEI
<<pref 2 LIST>>ZWEI
filled dir fileList recursive
<<pref 2 LIST>>DREI
<<pref 2 LIST>>EINS
<<pref 1 VIER>>DREI
<<pref 1 VIER>>EINS
<<pref 1 VIER>>ZWEI
<<pref 2 LIST>>ZWEI
$/tstFileListTSO/ */
if m.err_os = 'TSO' then
call tst t, "tstFileListTSO"
else
call tst t, "tstFileList"
fi = file(tstFileName('FileList', 'r'))
call fileMkDir fi
fl = fileList(fi)
call tstFileListDsn t, filePath(fi), 'empty dir'
call tstOut t, 'empty dir fileList'
call jWriteNow t, fl
call tstFileListMake t, fi, 2
call tstFileListDsn t, filePath(fi)'.*', 'filled dir .*'
call tstOut t, 'filled dir fileList'
call jWriteNow t, fl
call tstFileListDsn t, filePath(fi), 'filled dir'
call tstOut t, 'filled dir fileList recursive'
call jWriteNow t, fileList(fi, 'r')
call tstEnd t
return
endProcedure tstFileList
tstFileListDsn: procedure expose m.
parse arg t, fi, msg
call tstOut t, msg 'dsnList' dsnList(tst_FileListDsn, fi)
do ox=1 to m.tst_FileListDsn.0
call tstOut t, m.tst_FileListDsn.ox
end
return
endProcedure tstFileListDsn
tstFileListMake: procedure expose m.
parse arg t, fi, lev
if \ fileIsDir(fi) then
call fileMkDir fi
call mAdd t'.TRANS', filePath(fi) || m.file.sep ,
'<<pref' lev right(filePath(fi),4)'>>'
call jCat fileChild(fi, 'eins','::F'),jBuf('zeile eins','eins' lev)
call jCat fileChild(fi, 'zwei','::F'),jBuf('zeile zwei','zwei' lev)
call jCat fileChild(fi, 'drei','::F'),jBuf('zeile drei','drei' lev)
if lev > 1 then
call tstFileListMake t, fileChild(fi, 'vier'), lev-1
return
endProcedure tstFileListMake
/*--- manualTest time -----------------------------------------------*/
tstUtTime: procedure expose m.
say 'begin' utTime() sysvar('sysnode')
do 3000000
end
call sleep 1
say 'end ' utTime()
return
/*--- manualTest Mail -----------------------------------------------*/
tstMail: procedure expose m.
do i=1 to 2
call mailHead xy, 'mail from walter''s rexx' time() i, A540769
call mailText xy, 'und hier kommt der text' ,
, 'und zeile zwei timestamp' i':' date('s') time() ,
, left('und eine lange Zeile 159', 156, '+')159 ,
, left('und eine lange Zeile 160', 157, '+')160 ,
, left('und eine lange Zeile 161', 158, '+')161 ,
, '<ol><li>'left('und eine lange', 200,'+')203 '</li>',
, '<li bgcolor=yellow>und kurz</li></ol>' ,
, '<h1>und Schluss mit html</h1>'
call mailSend xy
call sleep 3
end
return
endprocedure tstMail
tstF: procedure expose m.
/*
$=/tstF/
### start tst tstF ################################################
f(1 23%c345%c67%%8, eins, zwei ) =1 23eins345 zwei 67%8;
f(1\S23%c345%S67%%8, eins, zwei ) =1\S23eins345zwei67%8;
f(1 23%C345%C67%%8, eins, zwei ) =1 23eins345 zwei 67%8;
f(1 23%c345%S67%%8, eins, zwei ) =1 23eins345zwei67%8;
f(1%S2%c3@2%S4@%c5, eins, zwei ) =1eins2 zwei 3zwei4 zwei 5;
f(1%-2C2%3C3@2%3.2C4, eins, zwei ) =1ei2ei 3zwe4;
f(1@F1%c2@f2%c3@F3%c4, eins, zwei ) =1fEins2fZwei3fDrei4;
f(a%(b%3Cc%)d, eins, zwei ) =abinscd;
f(a%(b%3Cc%,d%-3Ce%)f, eins, zwei ) =adbinef;
f(a@2%(b%3Cc%)d, eins, zwei ) =abei cd;
f(a@2%(b%3Cc%,d%-3Ce%)f, eins, zwei ) =adbeief;
tstF2 _ %-9C @%5I @%8I @%+8I @%-8I -----
_ 0 0 0 +0 0 .
_ -1.2 -1 -1 -1 -1 .
_ 2.34 2 2 +2 2 .
_ -34.8765 -35 -35 -35 -35 .
_ 567.91234 568 568 +568 568 .
_ -8901 -8901 -8901 -8901 -8901 .
_ 23456 23456 23456 +23456 23456 .
_ -789012 ***** -789012 -789012 -789012 .
_ 34e6 ***** 34000000 ******** 34000000
_ -56e7 ***** ******** ******** ********
_ 89e8 ***** ******** ******** ********
_ txtli txtli txtli txtli txtli .
_ undEinLan undEi undEinLa undEinLa undEinLa
tstF2 _ %-9C @%5.2I @%12.2I @%+12.2I @%-12.2I -----
_ 0 0.00 0.00 +0.00 0.00 .
_ -1.2 -1.20 -1.20 -1.20 -1.20 .
_ 2.34 2.34 2.34 +2.34 2.34 .
_ -34.8765 ***** -34.88 -34.88 -34.88 .
_ 567.91234 ***** 567.91 +567.91 567.91 .
_ -8901 ***** -8901.00 -8901.00 -8901.00 .
_ 23456 ***** 23456.00 +23456.00 23456.00 .
_ -789012 ***** -789012.00 -789012.00 -789012.00 .
_ 34e6 ***** 34000000.00 +34000000.00 34000000.00 .
_ -56e7 ***** ************ ************ ************
_ 89e8 ***** ************ ************ ************
_ txtli txtli txtli txtli txtli .
_ undEinLan undEi undEinLanger undEinLanger undEinLanger
tstF2 _ %-9C @%7e @% 8E @% 9.3e @% 11.4E -----
_ 0 0.00e00 0.00E00 0.000e00 0.0000E000
_ -1.2 -1.2e00 -1.20E00 -1.200e00 -1.2000E000
_ 2.34 2.34e00 2.34E00 2.340e00 2.3400E000
_ -34.8765 -3.5e01 -3.49E01 -3.488e01 -3.4877E001
_ 567.91234 5.68e02 5.68E02 5.679e02 5.6791E002
_ -8901 -8.9e03 -8.90E03 -8.901e03 -8.9010E003
_ 23456 2.35e04 2.35E04 2.346e04 2.3456E004
_ -789012 -7.9e05 -7.89E05 -7.890e05 -7.8901E005
_ 34e6 3.40e07 3.40E07 3.400e07 3.4000E007
_ -56e7 -5.6e08 -5.60E08 -5.600e08 -5.6000E008
_ 89e8 8.90e09 8.90E09 8.900e09 8.9000E009
_ txtli txtli txtli txtli txtli.
_ undEinLan undEinL undEinLa undEinLan undEinLange
_ 8.76e-07 8.76e-7 8.76E-7 8.760e-7 8.7600E-07
_ 5.43e-11 5.4e-11 5.4E-11 5.43e-11 5.4300E-11
_ -8.76e-07 -8.8e-7 -8.76E-7 -8.760e-7 -8.7600E-07
_ -5.43e-11 -5e-011 -5.4E-11 -5.43e-11 -5.4300E-11
tstF2 _ %-9C @%kt @%kd @%kb -----
_ 0 0s00 0 0 .
_ -1.2 -1s20 -1 -1 .
_ 2.34 2s34 2340m 2 .
_ -34.8765 -0m35 -35 -35 .
_ 567.91234 9m28 568 568 .
_ -8901 -2h28 -9k -9k
_ 23456 6h31 23k 23k
_ -789012 -9d03 -789k -771k
_ 34e6 394d 34M 32M
_ -56e7 -++++ -560M -534M
_ 89e8 +++++ 8900M 8488M
_ txtli txtli txtli txtli
_ undEinLan Text? Text? Text?
_ 8.76e-07 0s00 876n 0 .
_ 5.43e-11 0s00 54p 0 .
_ -8.76e-07 -0s00 -876n -0 .
_ -5.43e-11 -0s00 -54p -0 .
$/tstF/ */
call tst t, 'tstF'
call tstF1 '1 23%c345%c67%%8'
call tstF1 '1\S23%c345%S67%%8'
call tstF1 '1 23%C345%C67%%8'
call tstF1 '1 23%c345%S67%%8'
call tstF1 '1%S2%c3@2%S4@%c5'
call tstF1 '1%-2C2%3C3@2%3.2C4'
call tstF1 '1@F1%c2@f2%c3@F3%c4'
call tstF1 'a%(b%3Cc%)d'
call tstF1 'a%(b%3Cc%,d%-3Ce%)f'
call tstF1 'a@2%(b%3Cc%)d'
call tstF1 'a@2%(b%3Cc%,d%-3Ce%)f'
nums = '0 -1.2 2.34 -34.8765 567.91234 -8901 23456' ,
'-789012 34e6 -56e7 89e8 txtli undEinLangerText?'
call tstF2 '_ %-9C @%5I @%8I @%+8I @%-8I', nums
call tstF2 '_ %-9C @%5.2I @%12.2I @%+12.2I @%-12.2I', nums
num2 = ' 8.76e-07 5.43e-11 -8.76e-07 -5.43e-11'
call tstF2 '_ %-9C @%7e @% 8E @% 9.3e @% 11.4E', nums num2
call tstF2 '_ %-9C @%kt @%kd @%kb', nums num2
call tstEnd t
return
endProcedure tstF
tstF1: procedure expose m.
parse arg fmt
e='eins'
z=' zwei '
f2 = 'f2'
m.e.f1 = 'fEins'
m.e.f2 = 'fZwei'
m.e.f3 = 'fDrei'
call tstOut t, "f("fmt"," e"," z") ="f(fmt, e, z)";"
return
endProcedure tstF1
tstF2: procedure expose m.
parse arg fmt, vals
call tstOut t, 'tstF2' fmt '-----'
do vx=1 to words(vals)
call tstOut t, f(fmt, word(vals, vx))
end
return
endProcedure tstF2
tstFWords: procedure expose m.
/*
$=/tstFWords/
### start tst tstFWords ###########################################
??empty?? .
1space .
, #0-- --
#a%9c#l<<#r>> <<>>
*#a%-7c .
??empty?? eins
1space eins
, #0-- eins
#a%9c#l<<#r>> << eins>>
*#a%-7c eins .
??empty?? einszwei
1space eins zwei
, #0-- eins, zwei
#a%9c#l<<#r>> << eins zwei>>
*#a%-7c eins *zwei .
??empty?? einszweidrei
1space eins zwei drei
, #0-- eins, zwei, drei
#a%9c#l<<#r>> << eins zwei drei>>
*#a%-7c eins *zwei *drei .
$/tstFWords/
*/
ws = ' eins zwei drei '
call tst t, 'tstFWords'
do l=0 to 3
call tstOut t, '??empty?? ' fWords( ,subword(ws,1,l))
call tstOut t, '1space ' fWords(' ' ,subword(ws,1,l))
call tstOut t, ', #0-- ' fWords(', #0--' ,subword(ws,1,l))
call tstOut t, '#a%9c#l<<#r>>',
fWords('#a%9c#l<<#r>>' ,subword(ws,1,l))
call tstOut t, '*#a%-7c ' fWords('*#a%-7c' ,subword(ws,1,l))
end
call tstEnd t
return
endProcedure tstFWords
tstFe: procedure expose m.
/*
$=/tstFe/
### start tst tstFe ###############################################
. 1 < 1.00e00> <1.00e00>
. 0 < 0.00e00> <0.00e00>
. -2.1 <-2.10e00> <-2.1e00>
. .3 < 3.00e-1> <3.00e-1>
. -.45678 <-4.57e-1> <-4.6e-1>
. 901 < 9.01e02> <9.01e02>
. -2345 <-2.35e03> <-2.3e03>
. 678e90 < 6.78e92> <6.78e92>
. 123e-4 < 1.23e-2> <1.23e-2>
. 567e-89 < 5.7e-87> <5.7e-87>
. 12e456 < 1.2e457> <1.2e457>
. 78e-901 < 8e-0900> <8e-0900>
. 2345e5789 < 2e05792> <2e05792>
. 123e-4567 < 1e-4565> <1e-4565>
. 8901e23456 < 9e23459> <9e23459>
. -123e-4567 <-1e-4565> <-0e-999>
. 567e890123 <********> <*******>
. 45678e-901234 < 0e-9999> <0e-9999>
. kurz < kurz> <kurz >
. undLangerText <undLange> <undLang>
$/tstFe/
*/
call tst t, 'tstFe'
vAll = '1 0 -2.1 .3 -.45678 901 -2345 678e90 123e-4' ,
'567e-89 12e456 78e-901 2345e5789 123e-4567 8901e23456' ,
'-123e-4567 567e890123 45678e-901234' ,
'kurz undLangerText'
do vx=1 to words(vAll)
v = word(vAll, vx)
call tstOut t, right(v, 20) '<'fe(v, 8, 2, 'e', ' ')'>' ,
'<'fe(v, 7, 1, 'e', '-')'>'
end
call tstEnd t
return
endProcedure
tstFTst: procedure expose m.
/*
$=/tstFTstS/
### start tst tstFTstS ############################################
1956-01-29-23.34.56.987654 SS => 1956-01-29-23.34.56.987654|
1956-01-29-23.34.56.987654 Ss => 1956-01-29-23.34.56|
1956-01-29-23.34.56.987654 S => 1956-01-29-23.34.56|
1956-01-29-23.34.56.987654 SD => 19560129|
1956-01-29-23.34.56.987654 Sd => 560129|
1956-01-29-23.34.56.987654 SE => 29.01.1956|
1956-01-29-23.34.56.987654 Se => 29.01.56|
1956-01-29-23.34.56.987654 St => 23.34.56|
1956-01-29-23.34.56.987654 ST => 23:34:56.987654|
1956-01-29-23.34.56.987654 SZ => GB29|
1956-01-29-23.34.56.987654 SM => B2923345|
1956-01-29-23.34.56.987654 SH => C33456|
1956-01-29-23.34.56.987654 SY => GB29X3LV|
1956-01-29-23.34.56.987654 SA => C9233456|
1956-01-29-23.34.56.987654 Sj => 56029|
1956-01-29-23.34.56.987654 SJ => 714076|
$/tstFTstS/
$=/tstFTsts/
### start tst tstFTsts ############################################
2014-12-23-16.57.38 sS => 2014-12-23-16.57.38.000000|
2014-12-23-16.57.38 ss => 2014-12-23-16.57.38|
2014-12-23-16.57.38 s => 2014-12-23-16.57.38|
2014-12-23-16.57.38 sD => 20141223|
2014-12-23-16.57.38 sd => 141223|
2014-12-23-16.57.38 sE => 23.12.2014|
2014-12-23-16.57.38 se => 23.12.14|
2014-12-23-16.57.38 st => 16.57.38|
2014-12-23-16.57.38 sT => 16:57:38.000000|
2014-12-23-16.57.38 sZ => EM23|
2014-12-23-16.57.38 sM => M2316573|
2014-12-23-16.57.38 sH => B65738|
2014-12-23-16.57.38 sY => OM23Q5SI|
2014-12-23-16.57.38 sA => C3165738|
2014-12-23-16.57.38 sj => 14357|
2014-12-23-16.57.38 sJ => 735589|
2014-12-23-16.57.38 su +> E1J8X3NE|
2014-12-23-16.57.38 sL +> 00CE3F3AFA6570000000|
$/tstFTsts/
Winterzeit
2014-12-23-16.57.38 su +> E1KCA3JT|
2014-12-23-16.57.38 sL +> 00CE3F48639FB0000000|
Sommerzeit
2014-12-23-16.57.38 su +> E1J8X3NE|
2014-12-23-16.57.38 sL +> 00CE3F3AFA6570000000|
$=/tstFTstD/
### start tst tstFTstD ############################################
23450618 DS => 2345-06-18-00.00.00.000000|
23450618 Ds => 2345-06-18-00.00.00|
23450618 D => 2345-06-18-00.00.00|
23450618 DD => 23450618|
23450618 Dd => 450618|
23450618 DE => 18.06.2345|
23450618 De => 18.06.45|
23450618 Dt => 00.00.00|
23450618 DT => 00:00:00.000000|
23450618 DZ => PG18|
23450618 DM => G1800000|
23450618 DH => A00000|
23450618 DY => UG18A0AA|
23450618 DA => B8000000|
23450618 Dj => 45169|
23450618 DJ => 856296|
$/tstFTstD/
$=/tstFTstd/
### start tst tstFTstd ############################################
120724 dS => 2012-07-24-00.00.00.000000|
120724 ds => 2012-07-24-00.00.00|
120724 d => 2012-07-24-00.00.00|
120724 dD => 20120724|
120724 dd => 120724|
120724 dE => 24.07.2012|
120724 de => 24.07.12|
120724 dt => 00.00.00|
120724 dT => 00:00:00.000000|
120724 dZ => CH24|
120724 dM => H2400000|
120724 dH => A00000|
120724 dY => MH24A0AA|
120724 dA => C4000000|
120724 dj => 12206|
120724 dJ => 734707|
$/tstFTstd/
$=/tstFTstE/
### start tst tstFTstE ############################################
09.12.1345 ES => 1345-12-09-00.00.00.000000|
09.12.1345 Es => 1345-12-09-00.00.00|
09.12.1345 E => 1345-12-09-00.00.00|
09.12.1345 ED => 13451209|
09.12.1345 Ed => 451209|
09.12.1345 EE => 09.12.1345|
09.12.1345 Ee => 09.12.45|
09.12.1345 Et => 00.00.00|
09.12.1345 ET => 00:00:00.000000|
09.12.1345 EZ => PM09|
09.12.1345 EM => M0900000|
09.12.1345 EH => A00000|
09.12.1345 EY => UM09A0AA|
09.12.1345 EA => A9000000|
09.12.1345 Ej => 45343|
09.12.1345 EJ => 491228|
$/tstFTstE/
$=/tstFTste/
### start tst tstFTste ############################################
31.05.24 eS => 2024-05-31-00.00.00.000000|
31.05.24 es => 2024-05-31-00.00.00|
31.05.24 e => 2024-05-31-00.00.00|
31.05.24 eD => 20240531|
31.05.24 ed => 240531|
31.05.24 eE => 31.05.2024|
31.05.24 ee => 31.05.24|
31.05.24 et => 00.00.00|
31.05.24 eT => 00:00:00.000000|
31.05.24 eZ => OF31|
31.05.24 eM => F3100000|
31.05.24 eH => A00000|
31.05.24 eY => YF31A0AA|
31.05.24 eA => D1000000|
31.05.24 ej => 24152|
31.05.24 eJ => 739036|
$/tstFTste/
$=/tstFTstt/
### start tst tstFTstt ############################################
12.34.56 tS => 0001-01-01-12.34.56.000000|
12.34.56 ts => 0001-01-01-12.34.56|
12.34.56 t => 0001-01-01-12.34.56|
12.34.56 tD => 00010101|
12.34.56 td => 010101|
12.34.56 tE => 01.01.0001|
12.34.56 te => 01.01.01|
12.34.56 tt => 12.34.56|
12.34.56 tT => 12:34:56.000000|
12.34.56 tZ => ??01|
12.34.56 tM => ?0112345|
12.34.56 tH => B23456|
12.34.56 tY => ??01M3LV|
12.34.56 tA => A1123456|
12.34.56 tj => 01001|
12.34.56 tJ => 0|
$/tstFTstt/
$=/tstFTstT/
### start tst tstFTstT ############################################
23.45.06.784019 TS => 0001-01-01-23.45.06.784019|
23.45.06.784019 Ts => 0001-01-01-23.45.06|
23.45.06.784019 T => 0001-01-01-23.45.06|
23.45.06.784019 TD => 00010101|
23.45.06.784019 Td => 010101|
23.45.06.784019 TE => 01.01.0001|
23.45.06.784019 Te => 01.01.01|
23.45.06.784019 Tt => 23.45.06|
23.45.06.784019 TT => 23.45.06.784019|
23.45.06.784019 TZ => ??01|
23.45.06.784019 TM => ?0123450|
23.45.06.784019 TH => C34506|
23.45.06.784019 TY => ??01X4MG|
23.45.06.784019 TA => A1234506|
23.45.06.784019 Tj => 01001|
23.45.06.784019 TJ => 0|
$/tstFTstT/
$=/tstFTstYold/
### start tst tstFTstY ############################################
PE25 YS => 2015-04-25-00.00.00.000000|
PE25 Ys => 2015-04-25-00.00.00|
PE25 Y => 2015-04-25-00.00.00|
PE25 YD => 20150425|
PE25 Yd => 150425|
PE25 YE => 25.04.2015|
PE25 Ye => 25.04.15|
PE25 Yt => 00.00.00|
PE25 YT => 00:00:00.000000|
PE25 YZ => ?E25|
PE25 YM => E2500000|
PE25 YH => A00000|
PE25 YY => PE25A0AA|
PE25 YA => C5000000|
PE25 Yj => 15115|
PE25 YJ => 735712|
$/tstFTstYold/
$=/tstFTstM/
### start tst tstFTstM ############################################
I2317495 MS => 0001-08-23-17.49.50.000000|
I2317495 Ms => 0001-08-23-17.49.50|
I2317495 M => 0001-08-23-17.49.50|
I2317495 MD => 00010823|
I2317495 Md => 010823|
I2317495 ME => 23.08.0001|
I2317495 Me => 23.08.01|
I2317495 Mt => 17.49.50|
I2317495 MT => 17:49:50.000000|
I2317495 MZ => ?I23|
I2317495 MM => I2317495|
I2317495 MH => B74950|
I2317495 MY => ?I23R4XP|
I2317495 MA => C3174950|
I2317495 Mj => 01235|
I2317495 MJ => 234|
$/tstFTstM/
$=/tstFTstH/
### start tst tstFTstH ############################################
B23456 HS => 0001-01-01-12.34.56.000000|
B23456 Hs => 0001-01-01-12.34.56|
B23456 H => 0001-01-01-12.34.56|
B23456 HD => 00010101|
B23456 Hd => 010101|
B23456 HE => 01.01.0001|
B23456 He => 01.01.01|
B23456 Ht => 12.34.56|
B23456 HT => 12:34:56.000000|
B23456 HZ => ??01|
B23456 HM => ?0112345|
B23456 HH => B23456|
B23456 HY => ??01M3LV|
B23456 HA => A1123456|
B23456 Hj => 01001|
B23456 HJ => 0|
$/tstFTstH/
$=/tstFTstn/
### start tst tstFTstn ############################################
19560423 17:58:29 nS => 1956-04-23-17.58.29.000000|
19560423 17:58:29 ns => 1956-04-23-17.58.29|
19560423 17:58:29 n => 1956-04-23-17.58.29|
19560423 17:58:29 nD => 19560423|
19560423 17:58:29 nd => 560423|
19560423 17:58:29 nE => 23.04.1956|
19560423 17:58:29 ne => 23.04.56|
19560423 17:58:29 nt => 17.58.29|
19560423 17:58:29 nT => 17:58:29.000000|
19560423 17:58:29 nZ => GE23|
19560423 17:58:29 nM => E2317582|
19560423 17:58:29 nH => B75829|
19560423 17:58:29 nY => GE23R5UJ|
19560423 17:58:29 nA => C3175829|
19560423 17:58:29 nj => 56114|
19560423 17:58:29 nJ => 714161|
$/tstFTstn/
$=/tstFTstN/
### start tst tstFTstN ############################################
32101230 10:21:32.456789 NS => 3210-12-30-10.21.32.456789|
32101230 10:21:32.456789 Ns => 3210-12-30-10.21.32|
32101230 10:21:32.456789 N => 3210-12-30-10.21.32|
32101230 10:21:32.456789 ND => 32101230|
32101230 10:21:32.456789 Nd => 101230|
32101230 10:21:32.456789 NE => 30.12.3210|
32101230 10:21:32.456789 Ne => 30.12.10|
32101230 10:21:32.456789 Nt => 10.21.32|
32101230 10:21:32.456789 NT => 10:21:32.456789|
32101230 10:21:32.456789 NZ => AM30|
32101230 10:21:32.456789 NM => M3010213|
32101230 10:21:32.456789 NH => B02132|
32101230 10:21:32.456789 NY => KM30K2DR|
32101230 10:21:32.456789 NA => D0102132|
32101230 10:21:32.456789 Nj => 10364|
32101230 10:21:32.456789 NJ => 1172426|
$/tstFTstN/
$=/tstFTstY/
### start tst tstFTstY ############################################
RF06R2UT YS => 2017-05-06-17.28.39.000000|
RF06R2UT Ys => 2017-05-06-17.28.39|
RF06R2UT Y => 2017-05-06-17.28.39|
RF06R2UT YD => 20170506|
RF06R2UT Yd => 170506|
RF06R2UT YE => 06.05.2017|
RF06R2UT Ye => 06.05.17|
RF06R2UT Yt => 17.28.39|
RF06R2UT YT => 17:28:39.000000|
RF06R2UT YZ => ?F06|
RF06R2UT YM => F0617283|
RF06R2UT YH => B72839|
RF06R2UT YY => RF06R2UT|
RF06R2UT YA => A6172839|
RF06R2UT Yj => 17126|
RF06R2UT YJ => 736454|
$/tstFTstY/
*/
say "current time '%t '" f('%t ') "'%t D'" f('%t D')
say " '%t S'" f('%t S') "'%t t'" f('%t t') "'%t T'" f('%t T')
allOut = 'Ss DdEetTZMHYAjJ'
allIn = 'S1956-01-29-23.34.56.987654' ,
's2014-12-23-16.57.38' ,
'D23450618' ,
'd120724' ,
'E09.12.1345' ,
'e31.05.24' ,
't12.34.56' ,
'T23.45.06.784019' ,
/* 'YPE25' ,
*/ 'MI2317495' ,
'HB23456' ,
'n19560423*17:58:29' ,
'N32101230*10:21:32.456789',
'YRF06R2UT'
do ix=1 to words(allIn)
parse value word(allIn, ix) with iF 2 iV
iv = translate(iv, ' ', '*')
call tst t, "tstFTst"iF
do ox=1 to length(allOut)
ft = iF || substr(allOut, ox, 1)
call tstOut t, left(iV, 30) ft '=>' f('%t'ft, iV)'|'
if 0 & iF = 'Y' then
say '???' ft '>>>' mGet('F_GEN.%t'ft)
end
if ix=2 then do
call tstOut t, left(iV, 30) iF'u' '+>' f('%t'iF'u', iV)'|'
call tstOut t, left(iV, 30) iF'L' '+>' f('%t'iF'L', iV)'|'
end
call tstEnd t
end
return
endProcedure tstFTst
tstFUnit2: procedure expose m.
/* b
$=/tstFUnit2/
### start tst tstFUnit2 ###########################################
. 12 = 12 12
. 23k = 23000 23552
34 K = 34000 34816
45 M = 45000000 47185920
567G = 567000000000 608811614208
. 678 = 678
$/tstFUnit2/
*/
call tst t, 'tstFUnit2'
call tstOut t, ' 12 =' fUnit2I('d',' 12 ') fUnit2I('b',' 12 ')
call tstOut t, ' 23k =' fUnit2I('d',' 23k') fUnit2I('b',' 23k')
call tstOut t, '34 K =' fUnit2I('d','34 K ') fUnit2I('b','34 K ')
call tstOut t, '45 M =' fUnit2I('d','45 M') fUnit2I('b','45 M')
call tstOut t, '567G =' fUnit2I('d','567G') fUnit2I('b','567G')
call tstOut t, ' 678 =' fUnit2I('t',' 678 ')
/* t umbauen, funktioniert nicht mit jetztigen Metadaten ||||
call tstOut t, ' 78 s ='fUnit2I('t', ' 78 s ')
call tstOut t, '567G' fUnit2I('t', ' 123 ') */
call tstEnd t
return
endProcedure tstFU
tstFmt: procedure expose m.
call pipeIni
/*
$=/tstFmt/
### start tst tstFmt ##############################################
= a2i b3b d4 fl5 ex6
-11 -11 b3 d4-11+d4++++ -111.1000000 -1.11000e-12
-1 -10 b d4-10+d4+++ null1 null3
- -9 b3b-9 d4-9+d4+++ -11.0000000 -1.11900e-10
-8+ -8 b3b- d4-8+d4++ -18.0000000 -1.18000e010
-7 -7 b3b d4-7+d4+ -7.0000000 -1.70000e-07
- -6 b3 d4-6+d4 -0.1111160 -6.00000e006
-5+ -5 b d4-5+d null2 null2
-4 -4 b3b-4 d4-4+ -11114.0000000 -1.11140e008
- -3 b3b- d4-3 -0.1130000 -1.13000e-04
-2+ -2 b3b d4- -0.1200000 -1.20000e001
-1 -1 b3 d4 -0.1000000 -1.00000e-02
0 0 b d null1 null1
1+ 1 b3 d4 0.1000000 1.00000e-02
2++ 2 b3b d42 0.1200000 1.20000e001
3 3 b3b3 d43+ 0.1130000 1.13000e-04
4+ 4 b3b4+ d44+d 11114.0000000 1.11140e008
5++ 5 b d45+d4 null2 null2
6 6 b3 d46+d4+ 0.1111160 1.11116e005
7+ 7 b3b d47+d4++ 0.1111117 7.00000e-08
8++ 8 b3b8 d48+d4+++ 8.0000000 1.80000e009
9 9 b3b9+ d49+d4++++ 0.9000000 1.19000e-08
10 10 b d410+d4++++ null1 null3
11+ 11 b3 d411+d4+++++ 0.1110000 1.00000e-12
1 12 b3b d412+d4++++++ 11112.0000000 2.00000e012
13 13 b3b1 d 1111.3000000 1.13000e-12
14+ 14 b3b14 d4 111111.0000000 1.40000e013
1 15 b d41 null2 null1
16 16 b3 d416 6.0000000 1.16000e003
17+ 17 b3b d417+ 0.7000000 1.11170e-03
1 18 b3b1 d418+d 11.0000000 1.11800e003
19 19 b3b19 d419+d4 0.1190000 9.00000e-05
20+ 20 b d420+d4+ null1 null2
2 21 b3 d421+d4++ 11.1210000 1.11000e-05
22 22 b3b d422+d4+++ 11111.2000000 2.00000e007
23+ 23 b3b2 d423+d4++++ 0.1111123 1.11230e-09
c3L a2i drei d4 fl5 ex6
-11 -1.10E01 b3 d4-11+d -111.1000000 -1.11000e-12
-1 -1.00E01 b d4-10+d null1 null3
- -9.00E00 b3b-9 d4-9+d4 -11.0000000 -1.11900e-10
-8+ -8.00E00 b3b- d4-8+d4 -18.0000000 -1.18000e010
-7 -7.00E00 b3b d4-7+d4 -7.0000000 -1.70000e-07
- -6.00E00 b3 d4-6+d4 -0.1111160 -6.00000e006
-5+ -5.00E00 b d4-5+d null2 null2
-4 -4.00E00 b3b-4 d4-4+ -11114.0000000 -1.11140e008
- -3.00E00 b3b- d4-3 -0.1130000 -1.13000e-04
-2+ -2.00E00 b3b d4- -0.1200000 -1.20000e001
-1 -1.00E00 b3 d4 -0.1000000 -1.00000e-02
0 0.00E00 b d null1 null1
1+ 1.00E00 b3 d4 0.1000000 1.00000e-02
2++ 2.00E00 b3b d42 0.1200000 1.20000e001
3 3.00E00 b3b3 d43+ 0.1130000 1.13000e-04
4+ 4.00E00 b3b4+ d44+d 11114.0000000 1.11140e008
5++ 5.00E00 b d45+d4 null2 null2
6 6.00E00 b3 d46+d4+ 0.1111160 1.11116e005
7+ 7.00E00 b3b d47+d4+ 0.1111117 7.00000e-08
8++ 8.00E00 b3b8 d48+d4+ 8.0000000 1.80000e009
9 9.00E00 b3b9+ d49+d4+ 0.9000000 1.19000e-08
10 1.00E01 b d410+d4 null1 null3
11+ 1.10E01 b3 d411+d4 0.1110000 1.00000e-12
1 1.20E01 b3b d412+d4 11112.0000000 2.00000e012
13 1.30E01 b3b1 d 1111.3000000 1.13000e-12
14+ 1.40E01 b3b14 d4 111111.0000000 1.40000e013
1 1.50E01 b d41 null2 null1
16 1.60E01 b3 d416 6.0000000 1.16000e003
17+ 1.70E01 b3b d417+ 0.7000000 1.11170e-03
1 1.80E01 b3b1 d418+d 11.0000000 1.11800e003
19 1.90E01 b3b19 d419+d4 0.1190000 9.00000e-05
20+ 2.00E01 b d420+d4 null1 null2
2 2.10E01 b3 d421+d4 11.1210000 1.11000e-05
22 2.20E01 b3b d422+d4 11111.2000000 2.00000e007
23+ 2.30E01 b3b2 d423+d4 0.1111123 1.11230e-09
$/tstFmt/ */
call tst t, "tstFmt"
b = jBuf()
st = b'.BUF'
call pipe '+F', b
call tstDataClassOut '. c3 a2i i b3b c5 d4 c13 fl5 f8n2 ex6 e9n3',
, -11, + 23
call pipe '-'
call fTabAuto fTabReset(abc, 1), b
call fTabReset abc, 1
cc = fTabAdd(abc, , , 'c3L')
m.cc.fmt = fTabDetectFmt(st)
call fTabAdd abc, 'a2i', '% 8E'
cc = fTabAdd(abc, 'b3b', ,'drei')
m.cc.fmt = fTabDetectFmt(st, '.b3b')
call fTabAdd abc, 'd4', '%-7C'
cc = fTabAdd(abc, 'fl5')
m.cc.fmt = fTabDetectFmt(st, '.fl5')
cc = fTabAdd(abc, 'ex6')
m.cc.fmt = fTabDetectFmt(st, '.ex6')
call fTab abc, b
call tstEnd t
return
endProcedure tstFmt
tstFTab: procedure expose m.
/*
$=/tstFTab/
### start tst tstFTab #############################################
testData begin
..---------a2i-b3b------------------d4------fl5-----ex6---
-11 -11 b3 -11+d4++++ -111.100 -1e-012
-1 -10 b 4-10+d4+++ null1 null3
- -9 b3b-9 d4-9+d4+++ -11.000 -1e-010
-8+ -8 b3b- d4-8+d4++ -18.000 -1.2e10
-7 -7 b3b d4-7+d4+ -7.000 -1.7e-7
- -6 b3 d4-6+d4 -0.111 -6.0e06
-5+ -5 b d4-5+d null2 null2
-4 -4 b3b-4 d4-4+ ******** -1.1e08
- -3 b3b- d4-3 -0.113 -1.1e-4
-2+ -2 b3b d4- -0.120 -1.2e01
-1 -1 b3 d4 -0.100 -1.0e-2
0 0 b d null1 null1
1+ 1 b3 d4 0.100 1.00e-2
2++ 2 b3b d42 0.120 1.20e01
3 3 b3b3 d43+ 0.113 1.13e-4
4+ 4 b3b4+ d44+d ******** 1.11e08
5++ 5 b d45+d4 null2 null2
6 6 b3 d46+d4+ 0.111 1.11e05
7+ 7 b3b d47+d4++ 0.111 7.00e-8
8++ 8 b3b8 d48+d4+++ 8.000 1.80e09
9 9 b3b9+ d49+d4++++ 0.900 1.19e-8
10 10 b 410+d4++++ null1 null3
11+ 11 b3 11+d4+++++ 0.111 1.0e-12
1 12 b3b 2+d4++++++ ******** 2.00e12
13 13 b3b1 d 1111.300 1.1e-12
14+ 14 b3b14 d4 ******** 1.40e13
1 15 b d41 null2 null1
16 16 b3 d416 6.000 1.16e03
17+ 17 b3b d417+ 0.700 1.11e-3
1 18 b3b1 d418+d 11.000 1.12e03
19 19 b3b19 d419+d4 0.119 9.00e-5
20+ 20 b d420+d4+ null1 null2
2 21 b3 d421+d4++ 11.121 1.11e-5
22 22 b3b d422+d4+++ ******** 2.00e07
23+ 23 b3b2 423+d4++++ 0.111 1.11e-9
..---------a2i-b3b------------------d4------fl5-----ex6---
testData end
$/tstFTab/ */
call pipeIni
call tst t, "tstFTab"
b = jBuf()
st = b'.BUF'
call pipe '+F', b
call tstDataClassOut '. c3 a2i i b3b c5 d4 c13 fl5 f8n2 ex6 e9n3',
, -11, + 23
call pipe 'P|'
call fTabReset ft, 2 1, 1 3, '-'
call fTabAdd ft, '' , '%-6C', '.', , 'testData begin',
, 'testData end'
call fTabAdd ft, 'a2i' , '%6i'
call fTabAdd ft, 'b3b' , '%-12C'
call fTabAdd ft, 'd4' , '%10C'
call fTabAdd ft, 'fl5' , '%8.3I'
call fTabAdd ft, 'ex6' , '%7e'
call fTab ft
call pipe '-'
call tstEnd t
return
endProcedure tstFTab
tstCSV: procedure expose m.
/*
$=/tstCSV/
### start tst tstCSV ##############################################
value,value eins,value zwei
value,"value, , eins",value zwei
value,"","value ""zwei"" oder?"
value,,"value ""zwei"" oder?"
$/tstCSV/ */
m.tstCsv.c.1 = ''
m.tstCsv.c.2 = .eins
m.tstCsv.c.3 = .zwei
m.tstCsv.c.0 = 3
call tst t, "tstCSV"
m.tstCsv.o = 'value'
m.tstCsv.o.eins = 'value eins'
m.tstCsv.o.zwei = 'value zwei'
call tstOut t, csv4O(tstCsv'.'o, tstCsv'.'c, 0)
m.tstCsv.o.eins = 'value, , eins'
call tstOut t, csv4O(tstCsv'.'o, tstCsv'.'c, 0)
m.tstCsv.o.eins = ''
m.tstCsv.o.zwei = 'value "zwei" oder?'
call tstOut t, csv4O(tstCsv'.'o, tstCsv'.'c, 0)
m.tstCsv.o.eins = '---'
call tstOut t, csv4O(tstCsv'.'o, tstCsv'.'c, 1, '---')
call tstEnd t
return
endProcedure tstCSV
tstCSV2: procedure expose m.
/*
$=/tstCSV2/
### start tst tstCSV2 #############################################
w: ¢f1=1 fZwei=eins fDr=r!
w: ¢f1=2 fZwei= zwei , 2 fDr=!
w: ¢f1=3 fZwei=schluss fDr=!
W: ¢F1=1 FZWEI=eins FDR=r!
W: ¢F1=2 FZWEI= zwei , 2 FDR=!
W: ¢F1=3 FZWEI=schluss FDR=!
c: ¢f1=1 fComma=eins fDr=r!
c: ¢f1= 2 fComma= zwei , 2 fDr=!
c: ¢f1=3 fComma=schluss fDr=!
C: ¢F1=1 FCOMMA=eins FDR=r!
C: ¢F1= 2 FCOMMA= zwei , 2 FDR=!
C: ¢F1=3 FCOMMA=schluss FDR=!
o: ¢f1=1 fCol=eins fDr=drei fVie=und vier!
o: ¢f1=222222Z fCol=ccccccccC fDr=dddddddD fVie=vvvvvvvvvvvvvv V!
o: ¢f1=3 fCol=schluss fDr=drei fVie=vier!
O: ¢F1=1 FCOL=eins FDR=drei FVIE=und vier!
O: ¢F1=222222Z FCOL=ccccccccC FDR=dddddddD FVIE=vvvvvvvvvvvvvv V!
O: ¢F1=3 FCOL=schluss FDR=drei FVIE=vier!
$/tstCSV2/
*/
call jIni
call tst t, "tstCSV2"
b = jBuf(' f1 fZwei fDr ', '1 eins r',' 2 " zwei , 2 "',
, '3 schluss')
call tstCsv22 t, 'w', csvWordRdr(b)
call tstCsv22 t, 'W', csvWordRdr(b, 'u')
b = jBuf(' f1 , fComma, fDr ', '1,eins,r',' 2 ," zwei , 2 "',
, '3,schluss')
call tstCsv22 t, 'c', csv2ObjRdr(b)
call tstCsv22 t, 'C', csv2ObjRdr(b, 'u')
b = jBuf(' > f1 >< fCol <fDr fVie',
,' 1eins drei und vier ',
,'222222ZccccccccCdddddddDvvvvvvvvvvvvvv V',
,' 3 schluss dreivier')
call tstCsv22 t, 'o', csvColRdr(b)
call tstCsv22 t, 'O', csvColRdr(b, 'u')
call tstEnd t
return
endProcedure tstCSV2
tstCSV22: procedure expose m.
parse arg t, l, c
call jOpen c, '<'
do while jRead(c)
call tstOut t, l':' o2TexLR(m.c, , '¢', '!')
end
call jCLose c
return
endProcedure tstCSV22
tstCSVExt: procedure expose m.
/*
$=/tstCsvExt/
### start tst tstCsvExt ###########################################
v,string eins, oder nicht?
v,
w,string_W zwei, usw,,,|
c TstCsvExtF class@TstCsvExtF,u f FEINS v,f FZWEI v
o class@TstCsvExtF o1,f1Feins,"f1,fzwei "
c TstCsvExtG class@TstCsvExtG,u f gDrei v,f GVIER v,f gRef r o
f class@TstCsvExtG objG4,
d class@TstCsvExtG objG4,objG4gDrei,objG4.gVier,objG4
d class@TstCsvExtG objG3,,objG3.gVier,objG4
o class@TstCsvExtG G2,g2gDrei,,objG3
b TstCsvExtH class@TstCsvExtH,
m metEins method@metEins,call a b,c,"d e",
c TstCsvExtH class@TstCsvExtH,u v,f rr r o,f rH r class@TstCsvExtH,+
method@metEins
f class@TstCsvExtH H5,
d class@TstCsvExtH H9,H9value,objG3,H5
d class@TstCsvExtH H8,H8value rrWText,!escText,H9
d class@TstCsvExtH H7,H7value rrText,!textli,H8
d class@TstCsvExtH h6,h6-value6 rrLeer,,H7
o class@TstCsvExtH H5,h5Value,o1,h6
$/tstCsvExt/
*/
call jIni
call tst t, "tstCsvExt"
m = 'TST_CsvExt'
call csvExtBegin m
m.o.0 = 0
cF = classNew('n? TstCsvExtF u f FEINS v, f FZWEI v')
cG = classNew('n? TstCsvExtG u f gDrei v, f GVIER v, f gRef r')
cH = class4Name('TstCsvExtH', '-')
if cH == '-' then do
cH = classNew('n TstCsvExtH u')
cH = classNew('n= TstCsvExtH u v, f rr r, f rH r TstCsvExtH',
, 'm metEins call a b,c,"d e",')
end
do cx=1 to m.ch.0 until m.cy == 'm'
cy = m.cH.cx
end
call mAdd t.trans, cF 'class@TstCsvExtF', cG 'class@TstCsvExtG' ,
, cH 'class@TstCsvExtH', cY 'method@'m.cy.name
call csvExt m, o, 'string eins, oder nicht?'
call csvExt m, o
call csvExt m, o, s2o('string_W zwei, usw,,,|')
call csvExt m, o, csv2o('o1',cF, 'f1Feins,"f1,fzwei "')
call csvExt m, o, csv2o(g2, cG, 'g2gDrei,',
|| ','csv2o('objG3', cG, ',objG3.gVier',
|| ','csv2o('objG4', cG, 'objG4gDrei,objG4.gVier,objG4')))
call csvExt m, o, csv2o(h5, cH, 'h5Value,o1',
|| ','csv2o('h6', cH, 'h6-value6 rrLeer,',
|| ','csv2o(h7, cH, 'H7value rrText,textli',
|| ','csv2o(h8, cH, 'H8value rrWText,!escText',
|| ','csv2o(h9, cH, 'H9value,objG3,H5')))))
call outSt o
call tstEnd t
return
endProcedure tstCSVExt
tstCsvV2F: procedure expose m.
/*
$=/tstCsvV2F/
### start tst tstCsvV2F ###########################################
abcd
abcde
abcd&
ef
abc |
abcd&
. |
abcd&
e |
abc&|
abcd&
||
abcd&
e&|
abcd&
efgh
abcd&
efghi
abcd&
efgh&
ij
abcd&
efgh&
ij |
abcd&
efgh&
ijk&|
abcd&
efgh&
ijkl&
||
* f2v
abcd
abcde
abcdef
abc .
abcd .
abcde .
abc&
abcd|
abcde&
abcdefgh
abcdefghi
abcdefghij
abcdefghij .
abcdefghijk&
abcdefghijkl|
* f2v zwei
begin zwei
*** err: csvF2vEnd but strt='drei '
$/tstCsvV2F/
*/
call jIni
call tst t, "tstCsvV2F"
m = 'TST_csvV2F'
call csvV2FBegin m, 5
m.o.0 = 0
call mAdd mCut(i1, 0), 'abcd' ,
, 'abcde' ,
, 'abcdef' ,
, 'abc ' ,
, 'abcd ' ,
, 'abcde ' ,
, 'abc&' ,
, 'abcd|' ,
, 'abcde&' ,
, 'abcdefgh' ,
, 'abcdefghi' ,
, 'abcdefghij' ,
, 'abcdefghij ' ,
, 'abcdefghijk&' ,
, 'abcdefghijkl|'
do ix=1 to m.i1.0
call csvV2F m, o, m.i1.ix
end
call outSt o
call tstOut t, '* f2v'
m.p.0 = 0
call csvF2VBegin m
do ox=1 to m.o.0
call csvF2V m, p, m.o.ox || left(' ', ox // 3)
end
call csvF2VEnd m
call outSt p
call tstOut t, '* f2v zwei'
call mAdd mCut(o2, 0), 'begin zwei', 'drei &'
call csvF2VBegin m
call csvF2V m, mCut(p, 0), m.o2.1
call csvF2V m, p, m.o2.2
call outSt p
call csvF2VEnd m
call tstEnd t
say 'test with 1sRdr'
call tst t, "tstCsvV2F"
b1 = jBuf()
call mAddSt b1'.BUF', i1
call jIni
j1s = csvV2FRdr(b1, 5)
call jWriteAll t, j1s
call tstOut t, '* f2v'
call mAddSt mCut(b1'.BUF', 0), o
j1s = CsvF2VRdr(b1)
call jWriteAll t, j1s
call tstOut t, '* f2v zwei'
call mAddSt mCut(b1'.BUF', 0), o2
j1s = CsvF2VRdr(b1)
call jWriteAll t, j1s
call tstEnd t
return
endProcedure tstCsvV2F
tstCsvInt: procedure expose m.
/*
$=/tstCsvInt/
### start tst tstCsvInt ###########################################
wie geht es, "Dir", denn? .
tstR: @ obj null
wie geht es, "Dir", denn? class_W .
tstR: @tstWriteoV1 isA :TstCsvIntF*2
tstR: .FEINS = f1Feins
tstR: .FZWEI = f1,fzwei .
tstR: @tstWriteoV3 isA :TstCsvIntG*4 = o4Value
tstR: .R1 refTo @tstWriteoV5 :TstCsvIntG*4 = o3Value
tstR: .R1 refTo @tstWriteoV3 done :TstCsvIntG*4 @tstWriteoV3
tstR: @tstWriteoV5 isA :TstCsvIntG*4 = o3Value
tstR: .R1 refTo @tstWriteoV3 :TstCsvIntG*4 = o4Value
tstR: .R1 refTo @tstWriteoV5 done :TstCsvIntG*4 @tstWriteoV5
metEins=call out o, "calling metEins" m.m.R1
$/tstCsvInt/
*/
call jIni
call tst t, "tstCsvInt"
i = 'TST_csvInt'
call csvIntBegin i
call csvInt i, mCut(o, 0), 'v,wie geht es, "Dir", denn? '
call csvInt i, o, 'v,'
call csvInt i, o, 'w,wie geht es, "Dir", denn? class_W '
call csvInt i, o, 'c TstCsvIntF ClassIF,u f FEINS v,f FZWEI v'
call csvInt i, o, 'o ClassIF o1,f1Feins,"f1,fzwei "'
call csvInt i, o, 'b TstCsvIntG ClassIG'
call csvInt i, o, 'm metEins adrM1,call out o,' ,
'"calling metEins" m.m.R1'
call csvInt i, o, 'c TstCsvIntG ClassIG,u v, f R1 r ClassIG, adrM1'
call csvInt i, o, 'f ClassIG o4,'
call csvInt i, o, 'd ClassIG o3,o3Value,o4'
call csvInt i, o, 'o ClassIG o4,o4Value,o3'
call csvInt i, o, 'r o3,'
do ox=1 to m.o.0
call tstTransOc t, m.o.ox
end
call outSt o
ox = m.o.0
call out 'metEins='objMet(m.o.ox, 'metEins')
call tstEnd t
return
endProcedure tstCsvInt
tstFUnit: procedure
/*
$=/tstFUnit/
### start tst tstFUnit ############################################
. 1 ==> 1 =-> -1 =+> +1 =b> 1 .
. 5 ==> 5 =-> -5 =+> +5 =b> 5 .
. 13 ==> 13 =-> -13 =+> +13 =b> 13 .
. 144 ==> 144 =-> -144 =+> +144 =b> 144 .
. 1234 ==> 1234 =-> -1k =+> +1234 =b> 1234 .
. 7890 ==> 7890 =-> -8k =+> +7890 =b> 7890 .
. 0 ==> 0 =-> 0 =+> +0 =b> 0 .
. 234E3 ==> 234k =-> -234k =+> +234k =b> 229k
. 89E6 ==> 89M =-> -89M =+> +89M =b> 85M
. 123E9 ==> 123G =-> -123G =+> +123G =b> 115G
. 4567891E9 ==> 4568T =-> -5P =+> +4568T =b> 4154T
. 0.123 ==> 123m =-> -123m =+> +123m =b> 0 .
. 0.0000456789 ==> 46u =-> -46u =+> +46u =b> 0 .
. 345.567E-12 ==> 346p =-> -346p =+> +346p =b> 0 .
. 123.4567E-15 ==> 123f =-> -123f =+> +123f =b> 0 .
. ABC ==> ABC =-> -ABC =+> ABC =b> ABC
ABCDEFGHIJKLMN ==> JKLMN =-> JKLMN =+> IJKLMN =b> JKLMN
. 1E77 ==> +++++ =-> -++++ =+> ++++++ =b> +++++.
. 1E-77 ==> 0a =-> -0a =+> +0a =b> 0 .
. 18.543E18 ==> 19E =-> -19E =+> +19E =b> 16E
. 20.987E20 ==> 2099E =-> -++++ =+> +2099E =b> 1820E
. 1 ==> 1.000 =-> -1.000 =+> +1.000 =b> 1.000 .
. 5 ==> 5.000 =-> -5.000 =+> +5.000 =b> 5.000 .
. 13 ==> 13.000 =-> -0.013k =+> +0.013k =b> 13.000 .
. 144 ==> 0.144k =-> -0.144k =+> +0.144k =b> 0.141k
. 1234 ==> 1.234k =-> -1.234k =+> +1.234k =b> 1.205k
. 7890 ==> 7.890k =-> -7.890k =+> +7.890k =b> 7.705k
. 0 ==> 0.000 =-> 0.000 =+> +0.000 =b> 0.000 .
. 234E3 ==> 0.234M =-> -0.234M =+> +0.234M =b> 0.223M
. 89E6 ==> 89.000M =-> -0.089G =+> +0.089G =b> 84.877M
. 123E9 ==> 0.123T =-> -0.123T =+> +0.123T =b> 0.112T
. 4567891E9 ==> 4.568P =-> -4.568P =+> +4.568P =b> 4.057P
. 0.123 ==> 0.123 =-> -0.123 =+> +0.123 =b> 0.123 .
. 0.0000456789 ==> 45.679u =-> -0.046m =+> +0.046m =b> 0.000 .
. 345.567E-12 ==> 0.346n =-> -0.346n =+> +0.346n =b> 0.000 .
. 123.4567E-15 ==> 0.123p =-> -0.123p =+> +0.123p =b> 0.000 .
. ABC ==> ABC =-> -ABC =+> ABC =b> ABC
ABCDEFGHIJKLMN ==> HIJKLMN =-> HIJKLMN =+> HIJKLMN =b> HIJKLMN
. 1E77 ==> +++++++ =-> -++++++ =+> +++++++ =b> +++++++.
. 1E-77 ==> 0.000a =-> -0.000a =+> +0.000a =b> 0.000 .
. 18.543E18 ==> 18.543E =-> -++++++ =+> +++++++ =b> 16.083E
. 20.987E20 ==> +++++++ =-> -++++++ =+> +++++++ =b> +++++++.
$/tstFUnit/
$=/tstFUnitT/
### start tst tstFUnitT ###########################################
. .3 ==> 0s30 ++> 0s30 -+> -0s30 --> -0s30
. .8 ==> 0s80 ++> 0s80 -+> -0s80 --> -0s80
. 1 ==> 1s00 ++> 1s00 -+> -1s00 --> -1s00
. 1.2 ==> 1s20 ++> 1s20 -+> -1s20 --> -1s20
. 59 ==> 59s00 ++> 59s00 -+> -0m59 --> -59s00
. 59.07 ==> 59s07 ++> 59s07 -+> -0m59 --> -59s07
. 59.997 ==> 1m00 ++> 1m00 -+> -1m00 --> -1m00
. 60 ==> 1m00 ++> 1m00 -+> -1m00 --> -1m00
. 60.1 ==> 1m00 ++> 1m00 -+> -1m00 --> -1m00
. 611 ==> 10m11 ++> 10m11 -+> -0h10 --> -10m11
. 3599.4 ==> 59m59 ++> 59m59 -+> -1h00 --> -59m59
. 3599.5 ==> 1h00 ++> 1h00 -+> -1h00 --> -1h00
. 3661 ==> 1h01 ++> 1h01 -+> -1h01 --> -1h01
. 83400 ==> 23h10 ++> 23h10 -+> -0d23 --> -23h10
. 84700 ==> 23h32 ++> 23h32 -+> -1d00 --> -23h32
. 86400 ==> 1d00 ++> 1d00 -+> -1d00 --> -1d00
. 89900 ==> 1d01 ++> 1d01 -+> -1d01 --> -1d01
. 8467200 ==> 98d00 ++> 98d00 -+> -98d --> -98d00
. 8595936.00 ==> 99d12 ++> 99d12 -+> -99d --> -99d12
. 8638704.00 ==> 100d ++> 100d -+> -100d --> -100d
. 8640000 ==> 100d ++> 100d -+> -100d --> -100d
. 863913600 ==> 9999d ++> 9999d -+> -++++ --> -9999d
. 863965440 ==> +++++ ++> +++++ -+> -++++ --> -+++++.
. 8.6400E+9 ==> +++++ ++> +++++ -+> -++++ --> -+++++.
$/tstFUnitT/ */
call jIni
call tst t, "tstFUnit"
numeric digits 9
d = 86400
lst = 1 5 13 144 1234 7890 0 234e3 89e6 123e9,
4567891e9 0.123 0.0000456789 345.567e-12 123.4567e-15 ,
abc abcdefghijklmn 1e77 1e-77 18.543e18 20.987e20
do wx=1 to words(lst)
call tstOut t, right(word(lst, wx), 14) ,
'==>' fUnit('d' , word(lst, wx)),
'=->' fUnit('d' , '-'word(lst, wx)),
'=+>' fUnit('d¢+', word(lst, wx)),
'=b>' fUnit('b' , word(lst, wx))
end
do wx=1 to words(lst)
call tstOut t, right(word(lst, wx), 14) ,
'==>' fUnit('d7.3' , word(lst, wx)),
'=->' fUnit('d7.3' , '-'word(lst, wx)),
'=+>' fUnit('d7.3¢+', word(lst, wx)),
'=b>' fUnit('b7.3' , word(lst, wx))
end
call tstEnd t
call tst t, "tstFUnitT"
d = 86400
lst = .3 .8 1 1.2 59 59.07 59.997 60 60.1 611 ,
3599.4 3599.5 3661 d-3000 d-1700 d d+3500 ,
d * 98 d * 99.49 d * 99.985 d*100 d * 9999 d * 9999.6 ,
d * 1e5
do wx=1 to words(lst)
call tstOut t, right(word(lst, wx), 14) ,
'==>' fUnit('t' , word(lst, wx)),
'++>' fUnit('t¢ ', word(lst, wx)),
'-+>' fUnit('t' , '-'word(lst, wx)),
'-->' fUnit('t¢ ', '-'word(lst, wx))
end
call tstEnd t
return
endProcedure tstFUnit
tstSb: procedure expose m.
/*
$=/tstSb/
### start tst tstSb ###############################################
end : 0
char 3 : 1 abc
lit d? : 0 .
lit de : 1 de
lit de ? fg fgh: 1 fg
while HIJ : 0 .
end : 0
while Jih : 1 hi
while ? klj: 1 jklkl ?
end : 1
while ? klj: 0 .
char 3 : 0 .
lit : 0 .
until cba : 0 .
until ?qd : 1 abc
until ?qr : 1 defdef .
until ?qr : 0 .
strEnd ? : 1 ?
strEnd ? : 0 ?
strEnd ? : 1 ab??cd????gh?
strEnd ") ": 1 ab) .
strEnd ") ": 1 ab) cd) ) gh) .
string : 1 'eins?''' v=eins?'
space : 1 >
string : 1 "zwei""" v=zwei"
string ? : 1 ?drei??? v=drei?
*** err: scanErr ending Apostroph missing
. e 1: last token " scanPosition noEnd
. e 2: pos 28 in string 'eins?''' "zwei"""?drei???"noEnd
string : 0 " v=noEnd
$/tstSb/ */
call pipeIni
call tst t, 'tstSb'
call scanSrc s, 'abcdefghijklkl ?'
call out 'end :' scanEnd(s)
call out 'char 3 :' scanChar(s, 3) m.s.tok
call out 'lit d? :' scanLit(s, 'd?') m.s.tok
call out 'lit de :' scanLit(s, 'de') m.s.tok
call out 'lit de ? fg fgh:',
scanLit(s, 'de', '?', 'fg', 'fgh') m.s.tok
call out 'while HIJ :' scanWhile(s, 'HIJ') m.s.tok
call out 'end :' scanEnd(s)
call out 'while Jih :' scanWhile(s, 'Jih') m.s.tok
call out 'while ? klj:' scanWhile(s, '? klj') m.s.tok
call out 'end :' scanEnd(s)
call out 'while ? klj:' scanWhile(s, '? klj') m.s.tok
call out 'char 3 :' scanChar(s, 3) m.s.tok
call out 'lit :' scanLit(s) m.s.tok
call scanSrc s, 'abcdefdef ?'
call out 'until cba :' scanUntil(s, 'cba') m.s.tok
call out 'until ?qd :' scanUntil(s, '?qd') m.s.tok
call out 'until ?qr :' scanUntil(s, '?qr') m.s.tok
call out 'until ?qr :' scanUntil(s, '?qr') m.s.tok
call out 'strEnd ? :' scanStrEnd(s, '?') m.s.tok
call out 'strEnd ? :' scanStrEnd(s, '?') m.s.tok
call scanSrc s, 'ab??cd????gh?ijk'
call out 'strEnd ? :' scanStrEnd(s, '?') m.s.tok
call scanSrc s, 'ab) cd) ) gh) jk) )'
call out 'strEnd ") ":' scanStrEnd(s, ') ') m.s.tok
call out 'strEnd ") ":' scanStrEnd(s, ') ') m.s.tok
call scanSrc s, "'eins?'''" '"zwei"""?drei???"noEnd'
call out 'string :' scanString(s) m.s.tok 'v='m.s.val
call out 'space :' scanWhile(s, ' ') m.s.tok'>'
call out 'string :' scanString(s) m.s.tok 'v='m.s.val
call out 'string ? :' scanString(s, '?') m.s.tok 'v='m.s.val
call out 'string :' scanString(s) m.s.tok 'v='m.s.val
call tstEnd t
return
endProcedure tstSb
tstSb2: procedure expose m.
/*
$=/tstSb2/
### start tst tstSb2 ##############################################
end : 0
char 3 : 1 abc
lit d? : 0 .
lit de : 1 de
lit de ? fg fgh: 1 fg
while HIJ : 0 .
end : 0
while Jih : 1 hi
while ? klj: 1 jklkl ?
end : 1
while ? klj: 0 .
char 3 : 0 .
lit : 0 .
until cba : 0 .
until ?qd : 1 abc
until ?qr : 1 defdef .
until ?qr : 0 .
strEnd ? : 1 ?
strEnd ? : 0 ?
strEnd ? : 1 ab??cd????gh?
strEnd ") ": 1 ab) .
strEnd ") ": 1 ab) cd) ) gh) .
$/tstSb2/ */
call pipeIni
call tst t, 'tstSb2'
call scanSrc s, 'abcdefghijklkl ?'
call out 'end :' scanEnd(s)
call out 'char 3 :' scanChar(s, 3) m.s.tok
call out 'lit d? :' scanLit(s, 'd?') m.s.tok
call out 'lit de :' scanLit(s, 'de') m.s.tok
call out 'lit de ? fg fgh:',
scanLit(s, 'de', '?', 'fg', 'fgh') m.s.tok
call out 'while HIJ :' scanWhile(s, 'HIJ') m.s.tok
call out 'end :' scanEnd(s)
call out 'while Jih :' scanWhile(s, 'Jih') m.s.tok
call out 'while ? klj:' scanWhile(s, '? klj') m.s.tok
call out 'end :' scanEnd(s)
call out 'while ? klj:' scanWhile(s, '? klj') m.s.tok
call out 'char 3 :' scanChar(s, 3) m.s.tok
call out 'lit :' scanLit(s) m.s.tok
call scanSrc s, 'abcdefdef ?'
call out 'until cba :' scanUntil(s, 'cba') m.s.tok
call out 'until ?qd :' scanUntil(s, '?qd') m.s.tok
call out 'until ?qr :' scanUntil(s, '?qr') m.s.tok
call out 'until ?qr :' scanUntil(s, '?qr') m.s.tok
call out 'strEnd ? :' scanStrEnd(s, '?') m.s.tok
call out 'strEnd ? :' scanStrEnd(s, '?') m.s.tok
call scanSrc s, 'ab??cd????gh?ijk'
call out 'strEnd ? :' scanStrEnd(s, '?') m.s.tok
call scanSrc s, 'ab) cd) ) gh) jk) )'
call out 'strEnd ") ":' scanStrEnd(s, ') ') m.s.tok
call out 'strEnd ") ":' scanStrEnd(s, ') ') m.s.tok
call tstEnd t
return
endProcedure tstSb2
tstScan: procedure expose m.
/*
$=/tstScan.1/
### start tst tstScan.1 ###########################################
scan src a034,Und hr123sdfER"st1" 'str2''mit''apo''s' .
scan n tok 4: a034 key val .
scan , tok 1: , key val .
scan n tok 3: Und key val .
scan v tok 1: key val .
scan n tok 10: hr123sdfER key val .
scan q tok 5: "st1" key val st1
scan v tok 1: key val st1
scan a tok 19: 'str2''mit''apo''s' key val str2'mit'apo's
scan v tok 1: key val str2'mit'apo's
$/tstScan.1/ */
call tst t, 'tstScan.1'
call tstScan1 'l"litEins"l"litZwei"ndv" "aq1' ,
,"a034,Und hr123sdfER""st1"" 'str2''mit''apo''s' "
call tstEnd t
/*
$=/tstScan.2/
### start tst tstScan.2 ###########################################
scan src a034,Und hr123sdfER"st1" 'str2''mit''apo''s' .
scan n tok 4: a034 key val .
scan , tok 1: , key val .
scan n tok 3: Und key val .
scan b tok 1: key val .
scan n tok 10: hr123sdfER key val .
scan " tok 5: "st1" key val st1
scan b tok 1: key val st1
scan ' tok 19: 'str2''mit''apo''s' key val str2'mit'apo's
scan b tok 1: key val str2'mit'apo's
$/tstScan.2/ */
call tst t, 'tstScan.2'
call tstScan1 'ndsb1' ,
,"a034,Und hr123sdfER""st1"" 'str2''mit''apo''s' "
call tstEnd t
/*
$=/tstScan.3/
### start tst tstScan.3 ###########################################
scan src a034,'wie 789abc
scan n tok 4: a034 key val .
scan , tok 1: , key val .
*** err: scanErr ending Apostroph missing
. e 1: last token ' scanPosition wie 789abc
. e 2: pos 7 in string a034,'wie 789abc
scan w tok 1: w key val wie 789abc
scan n tok 2: ie key val wie 789abc
scan s tok 1: key val wie 789abc
*** err: scanErr illegal char after number 789
. e 1: last token 789 scanPosition abc
. e 2: pos 14 in string a034,'wie 789abc
scan d tok 3: 789 key val wie 789abc
scan n tok 3: abc key val wie 789abc
$/tstScan.3/ */
call tst t, 'tstScan.3'
call tstScan1 'nds1' ,
,"a034,'wie 789abc"
call tstEnd t
/*
$=/tstScan.4/
### start tst tstScan.4 ###########################################
scan src litEinsefr 23 sdfER'str1'litZwei "str2""mit quo"s .
scan l tok 7: litEins key val .
scan n tok 3: efr key val .
scan b tok 1: key val .
scan d tok 2: 23 key val .
scan b tok 1: key val .
scan n tok 5: sdfER key val .
scan a tok 6: 'str1' key val str1
scan l tok 7: litZwei key val str1
scan b tok 1: key val str1
scan q tok 15: "str2""mit quo" key val str2"mit quo
scan n tok 1: s key val str2"mit quo
scan b tok 1: key val str2"mit quo
$/tstScan.4/ */
call tst t, 'tstScan.4'
call tstScan1 'l"litEins"l"litZwei"ndbaq1' ,
,"litEinsefr 23 sdfER'str1'litZwei ""str2""""mit quo""s "
call tstEnd t
/*
$=/tstScan.5/
### start tst tstScan.5 ###########################################
scan src aha q3 = f ab=cdEf eF='strIng' .
scan s tok 1: key val .
scan k tok 0: key aha val def
scan k tok 1: f key q3 val f
scan s tok 1: key q3 val f
scan k tok 4: cdEf key ab val cdEf
scan s tok 1: key ab val cdEf
scan k tok 8: 'strIng' key eF val strIng
scan s tok 1: key eF val strIng
$/tstScan.5/ */
call tst t, 'tstScan.5'
call tstScan1 'k1'," aha q3 = f ab=cdEf eF='strIng' "
call tstEnd t
return
endProcedure tstScan
/*--- one single test scan with lines to scan in stem ln ------------*/
tstScan1:
parse arg classs, ln
call tstOut t, 'scan src' ln
call scanSrc scanOpt(s), ln
m.s.key = ''
m.s.val = ''
do forever
x = tstScanType(s, classs)
if x == '' then
leave
call tstOut t, 'scan' x 'tok' length(m.s.tok)':' m.s.tok ,
'key' m.s.key 'val' m.s.val
end
return
endProcedure tstScan1
tstScanType: procedure expose m.
parse arg s, opt
cx = 1
a2 = ''
res = 0
do while cx <= length(opt)
f = substr(opt, cx, 1)
cx = cx + 1
if pos(substr(opt, cx, 1), "'""") > 0 then do
m.tstScanType.src = opt
m.tstScanType.pos = cx
call scanString tstScanType
a2 = m.tstScanType.val
cx = m.tstScanType.pos
end
if f == 'a' then
res = scanString(s, "'")
else if f == 'b' then
res = scanSpace(s)
else if f == 'c' then
res = scanChar(s, a2)
else if f == 'd' then
if a2 == 0 then
res = scanNatIA(s)
else
res = scanNat(s)
else if f == 'k' then
res = scanKeyValue(s, 'def')
else if f == 'l' then
res = scanLit(s, a2)
else if f == 'q' then
res = scanString(s, '"')
else if f == 'v' then
res = scanVerify(s, a2)
else if f == 'w' then
res = scanWord(s)
else if f == 'y' then
res = scanVerify(s, a2, 'm')
if res then
return f
end
return scanType(s)
endProcedure tstScanType
tstScanRead: procedure expose m.
/*
$=/tstScanRead/
### start tst tstScanRead #########################################
name erste
space
name Zeile
nextLine
nextLine
space
name dritte
space
name Zeile
space
name schluss
$/tstScanRead/ */
call scanReadIni
call tst t, 'tstScanRead'
b = jBuf('erste Zeile ',,' dritte Zeile schluss ')
s = jOpen(jReset0(scanRead(b)), m.j.cRead)
do while \scanEnd(s)
if scanName(s) then call tstOut t, 'name' m.s.tok
else if scanVerify(s, ' ') then call tstOut t, 'space'
else if scanReadNL(s) then call tstOut t, 'nextLine'
else if \scanEnd(s) then call scanErr s, 'cannot scan'
end
call jClose s
call tstEnd t
/*
$=/tstScanReadMitSpaceLn/
### start tst tstScanReadMitSpaceLn ###############################
name erste
spaceLn
name Zeile
spaceLn
name dritte
spaceLn
name Zeile
spaceLn
name schluss
$/tstScanReadMitSpaceLn/ */
call tst t, 'tstScanReadMitSpaceLn'
s = scanReadOpen(scanRead(b))
do forever
if scanName(s) then call out 'name' m.s.tok
else if scanSpace(s) then call out 'spaceLn'
else if \scanEnd(s) then call scanErr s, 'cannot scan'
else leave
end
call scanReadClose s
call tstEnd t
/*
$=/tstScanJRead/
### start tst tstScanJRead ########################################
1 jRead n tok erste val .
2 jRead s tok val .
3 jRead n tok Zeile val .
4 jRead s tok val .
5 jRead n tok dritte val .
6 jRead s tok val .
7 jRead n tok Zeile val .
8 jRead s tok val .
9 jRead n tok schluss val .
10 jRead s tok val .
11 jRead 0 tok 1 val 1
12 jRead s tok val 1
13 jRead + tok + val 1
14 jRead s tok val 1
15 jRead 0 tok 2. val 2..
16 jRead s tok val 2..
17 jRead + tok + val 2..
18 jRead . tok . val 2..
19 jRead s tok val 2..
20 jRead 0 tok +.3 val +.3
21 jRead 0 tok -45e-3 val -45E-3
22 jRead s tok val -45E-3
23 jRead " tok "a""b" val a"b
24 jRead s tok val a"b
25 jRead ' tok 'c''d' val c'd
className 1: ScanRes 18: ScanRes
$/tstScanJRead/ */
call tst t, 'tstScanJRead'
call jWrite jOpen(b,'>>'), '1 + 2. +. +.3-45e-3 "a""b"' "'c''d'"
s = jOpen(jReset0(scanRead(jClose(b))), '<')
do x=1 while jRead(s)
v = m.s
call out x 'jRead' m.v.type 'tok' m.v.tok 'val' m.v.val
v.x = v
end
call jClose s
call out 'className 1:' className(objClass(v.1)),
'18:' className(objClass(v.18))
call tstEnd t
/*
$=/tstScanReadPos/
### start tst tstScanReadPos ######################################
1
2
345678
4
5678
4
$/tstScanReadPos/ */
call tst t, 'tstScanReadPos'
b = jBuf(1, 2, 345678, 4)
call scanReadOpen scanReadReset(scanOpt(tstScn), b)
do while scanNat(scanSkip(tstScn))
call tstOut t, m.tstScn.tok
end
call scanSetPos tstScn, 3 3
do while scanNat(scanSkip(tstScn))
call tstOut t, m.tstScn.tok
end
call tstEnd t
return
endProcedure tstScanRead
tstScanUtilInto: procedure expose m.
/*
$=/tstScanUtilIntoL/
TEMPLATE P3
DSN('DBAF.DA540769.A802A.P00003.BV5I3NRN.REC')
DISP(OLD,KEEP,KEEP)
TEMPLATE P4
DSN('DBAF.DA540769.A802A.P00004.BV5I3NTK.REC')
DISP(OLD,KEEP,KEEP)
LOAD DATA LOG NO RESUME NO REPLACE COPYDDN(TCOPYD)
STATISTICS INDEX(ALL) REPORT NO UPDATE ALL
EBCDIC CCSID(00500,00000,00000)
SORTKEYS
-- ENFORCE NO
SORTDEVT DISK
SORTNUM 160
WORKDDN(TSYUTD,TSOUTD)
INTO TABLE OA1P.TWB981 PART 1 INDDN TREC134
WORKDDN(TSYUTS,TSOUTS)
INTO TABLE "A540769"
."TWK802A1"
PART 00001 INDDN P0
WHEN(00001:00002) = X'0041'
( "DE1"
POSITION( 00003:00010) DECIMAL
, "CH2"
POSITION( 00011:00015) CHAR(00005)
, "TS3"
POSITION( 00016:00041) TIMESTAMP EXTERNAL
, "TI4"
POSITION( 00042:00049) TIME EXTERNAL
, "DA5"
POSITION( 00050:00059) DATE EXTERNAL
, "IN6"
POSITION( 00060:00063) INTEGER
, "RE7"
POSITION( 00064:00067) FLOAT(21)
)
INTO TABLE "A540769"."TWK802A1"
PART 00002 INDDN P0
WHEN(00001:00002) = X'0041'
( "DE1"
POSITION( 00003:00010) DECIMAL
, "CH2"
POSITION( 00011:00015) CHAR(00005)
)
dobido
$/tstScanUtilIntoL/
$=/tstScanUtilInto/
### start tst tstScanUtilInto #####################################
-- 1 scanUtilInto
. ( "DE1"
. POSITION( 00003:00010) DECIMAL
. , "CH2"
. POSITION( 00011:00015) CHAR(00005)
. , "TS3"
. POSITION( 00016:00041) TIMESTAMP EXTERNAL
. , "TI4"
. POSITION( 00042:00049) TIME EXTERNAL
. , "DA5"
. POSITION( 00050:00059) DATE EXTERNAL
. , "IN6"
. POSITION( 00060:00063) INTEGER
. , "RE7"
. POSITION( 00064:00067) FLOAT(21)
. ) .
. -- table OA1P.TWB981 part 00001
-- 2 scanUtilInto
. ( "DE1"
. POSITION( 00003:00010) DECIMAL
. , "CH2"
. POSITION( 00011:00015) CHAR(00005)
. ) .
. -- table A540769.TWK802A1 part 00002
-- 3 scanUtilInto
$/tstScanUtilInto/ */
call scanReadIni
b = jBuf()
call mAddst b'.BUF', mapInline('tstScanUtilIntoL')
call tst t, 'tstScanUtilInto'
s = jOpen(jReset0(scanUtilOpt(ScanRead(b))), '<')
do ix=1
call out '--' ix 'scanUtilInto'
if \ scanUtilInto(s) then
leave
call out ' -- table' m.s.tb 'part' m.s.part
end
call tstEnd t
return
endProcedure tstSCanUtilInto
tstScanWin: procedure expose m.
/*
$=/tstScanWin/
### start tst tstScanWin ##########################################
info 0: last token scanPosition erste Zeile dr+
itteZe\npos 1 in line 1: erste Zeile
name erste
spaceNL
name Zeile
spaceNL
name dritteZeeeile
info 5: last token dritteZeeeile scanPosition zeile4 +
. fuenfueberSechs\npos 1 in line 4: zeile4
spaceNL
name zeile4
spaceNL
name fuenfueberSechsUnddSiebenUNDundUndUAcht
spaceNL
info 10: last token scanPosition undZehnueberElfundNochWeiterZwoe+
lfundim1\npos 9 in line 10: undZehn
name undZehnueberElfundNochWeiterZwoelfundim13
spaceNL
name Punkt
infoE 14: last token Punkt scanPosition \natEnd after line 13: im13+
. Punkt
$/tstScanWin/ */
call scanWinIni
call tst t, 'tstScanWin'
b = jBuf('?erste Zeile?',,'? dritteZeeeile?', '? zeile4 ',
,'? fuenf?', '?ueberSechsUnddS?', '?iebenUNDundUndU?',
,'?Acht ?', '? ?', '? undZehn?',
,'?ueberElfundNoch?', '?WeiterZwoelfund?', '?im13 Punkt?')
s = jOpen(jReset0(scanWin(b, '15@2')), m.j.cRead)
call tstOut t, 'info 0:' scanInfo(s)
do sx=1 while \scanEnd(s)
if scanSpace(s) then call tstOut t, 'spaceNL'
else if scanName(s) then call tstOut t, 'name' m.s.tok
else if \scanEnd(s) then call scanErr s, 'cannot scan'
if sx // 5 = 0 then
call tstOut t, 'info' sx':' scanInfo(s)
end
call tstOut t, 'infoE' sx':' scanInfo(s)
call tstEnd t
/*
$=/tstScanWinRead/
### start tst tstScanWinRead ######################################
info 0: last token scanPosition erste Zeile z3 +
com Ze\npos 1 in line 1: erste Zeile
name erste
spaceNL
name Zeile
spaceNL
name z3
info 5: last token z3 scanPosition com Zeeeile z4 come4 f+
uenf\npos 4 in line 3: z3 com Zeeeile
spaceNL
name z4
spaceNL
name fuenf
spaceNL
info 10: last token scanPosition com Sechs com sieben comA+
cht com\npos 15 in line 5: fuenf c
name com
spaceNL
name Sechs
spaceNL
name com
info 15: last token com scanPosition sieben comAcht com com +
. com\npos 2 in line 7: m sieben com
spaceNL
name sieben
spaceNL
name Acht
spaceNL
info 20: last token scanPosition ueberElfundNochWeit com elfundim+
13\npos 1 in line 11: ueberElfundNoch
name ueberElfundNochWeit
spaceNL
name im13
spaceNL
name Punkt
info 25: last token Punkt scanPosition \natEnd after line 13: im13 +
. Punkt
infoE 26: last token Punkt scanPosition \natEnd after line 13: im13+
. Punkt
$/tstScanWinRead/ */
call tst t, 'tstScanWinRead'
b = jBuf('?erste Zeile?',,'? z3 com Zeeeile?', '? z4 come4 ',
,'? fuenf c?', '?om Sechs co?', '?m sieben com?',
,'?Acht com com ?', '? com ?', '? com undZehn?',
,'?ueberElfundNoch?', '?Weit com elfund?', '?im13 Punkt?')
s = jReset0(scanWin(b, '15@2'))
call scanOpt s, , , 'com'
call tstOut t, 'info 0:' scanInfo(jOpen(s, m.j.cRead))
do sx=1 while \scanEnd(s)
if scanName(s) then call tstOut t, 'name' m.s.tok
else if scanSpace(s) then call tstOut t, 'spaceNL'
else if \scanEnd(s) then call scanErr s, 'cannot scan'
if sx // 5 = 0 then
call tstOut t, 'info' sx':' scanInfo(s)
end
call tstOut t, 'infoE' sx':' scanInfo(s)
call tstEnd t
/*
$=/tstScanWinPos/
### start tst tstScanWinPos #######################################
infoA1 1: last token 1 scanPosition 2 +
. 3\npos 2 in line 1: 1
1
2
345678
4
infoB1: last token scanPosition \natEnd after line 4: 4
infoC1: last token scanPosition 678 4\npos 4 in line+
. 3: 345678
678
4
infoA0 1: last token -2 scanPosition -1 -0 1 +
. 2\npos 3 in line -2: -2
-2
-1
-0
1
2
345678
4
infoB0: last token scanPosition \natEnd after line 4: 4
infoC0: last token scanPosition 5678 4\npos 3 in line 3: 345678
5678
4
$/tstScanWinPos/ */
call tst t, 'tstScanWinPos'
b = jBuf(1, 2, 345678, 4)
do ox=1 to 0 by -1
if ox then
s = scanWinOpen(scanWinReset(scanOpt(tstScn), b, 20))
else
s = scanWinOpen(scanWinReset(scanOpt(tstScn), b, 10),
,'-2 -1 -0')
do nx=1 while scanNum(scanSkip(s))
if nx = 1 then
call tstOut t, 'infoA'ox nx':' scanInfo(s)
call tstOut t, m.s.tok
end
call tstOut t, 'infoB'ox':' scanInfo(s)
call scanSetPos s, 3 3+ox
call tstOut t, 'infoC'ox':' scanInfo(s)
do while scanNat(scanSkip(s))
call tstOut t, m.s.tok
end
call scanClose s
end
call tstEnd t
return
endProcedure tstScanWin
tstScanSqlStmt: procedure expose m.
/*
$=/tstScanSqlStmt/
### start tst tstScanSqlStmt ######################################
cmd1 select current time stamp from s.1
cmd2 update ";--""'/*"
cmd3 delete '*/''"' / 3 - 1
cmd4 terminator test
cmd5 und so
cmd6 term: ist
cmd7 term> in com nein >
cmd8 .
$/tstScanSqlStmt/ */
call pipeIni
call scanWinIni
call tst t, 'tstScanSqlStmt'
b = jBuf('select -- /* c1', ' /* c1 */ current/* c2 " '' ',
,'c3"', ' c4 */time', 'stamp-- c5', 'from s.1; /* c6 */ ;' ,
,';update ";--""''/*";; del123',
, 'ete ''*/''''"'' / 3 - 1 -- c7', '/*c8 */ ' ,
, ';terminator test; ','terminator|; und-- ', 'so| | |',
, 'term: --#SET TERMINATOR : oder', 'ist: ',
, 'term> /*--#SET TERMINATOR > oder', ' */ in com nein >:')
call scanWinOpen scanSqlStmtOpt(scanWinReset(tstJcat, b, 30), ';')
call scanSqlOpt tstJcat
do sx=1 until nx = ''
nx = scanSqlStmt(tstJCat)
call tstOut t, 'cmd'sx nx
end
call scanReadCLose tstJCat
call tstEnd t
/*
$=/tstScanSqlStmtRdr/
### start tst tstScanSqlStmtRdr ###################################
cmd1 select current time stamp from s.1
cmd2 update ";--""'/*"
cmd3 delete '*/''"' / 3 - 1
cmd4 terminator test
cmd5 und so
cmd6 term: ist
cmd7 term> in com nein >
$/tstScanSqlStmtRdr/ */
call tst t, 'tstScanSqlStmtRdr'
r = jOpen(ScanSqlStmtRdr(b, 30), '<')
do sx=1 while jRead(r)
call tstOut t, 'cmd'sx m.r
end
call jClose r
call tstEnd t
return
endProcedure tstScanSqlStmt
tstScanSql: procedure expose m.
call scanWinIni
/*
$=/tstScanSqlId/
### start tst tstScanSqlId ########################################
sqlId ABC
spaceNL
sqlId AB__345EF
spaceNL
$/tstScanSqlId/ */
call tst t, 'tstScanSqlId'
b = jBuf('abc -- kommentar', right('ab_', 72), '_345ef-- kom')
s = scanOpen(scanSqlReset(tstScn, b))
do sx=1 while \scanEnd(s)
if scanSqlID(s) then call tstOut t, 'sqlId' m.s.val
else if scanSpace(s) then call tstOut t, 'spaceNL'
else call scanErr s, 'cannot scan'
end
call tstEnd t
/*
$=/tstScanSqlDelimited/
### start tst tstScanSqlDelimited #################################
sqlDeId ABC
spaceNL
sqlDeId AB_3F
spaceNL
sqlDeId abc
spaceNL
sqlDeId ab_Ef
spaceNL
$/tstScanSqlDelimited/ */
call tst t, 'tstScanSqlDelimited'
b =jBuf('abc -- kommentar',,' -- ',,right('ab_', 72),'3F-- kom',
, '"abc" -- ko', ' -- ',,right('"ab_', 72),'Ef"-- kom')
s = scanOpen(scanSqlReset(tstScn, b))
do sx=1 while \scanEnd(s)
if scanSqlDeID(s) then call tstOut t, 'sqlDeId' m.s.val
else if scanSpace(s) then call tstOut t, 'spaceNL'
else call scanErr s, 'cannot scan'
end
call tstEnd t
/*
$=/tstScanSqlQualified/
### start tst tstScanSqlQualified #################################
sqlQuId ABC 1 ABC
sqlQuId AB_3F 1 AB_3F
sqlQuId abc 1 abc
sqlQuId ab_Ef 1 ab_Ef
sqlQuId EINS.Zwei.DREI 3 EINS
sqlQuId vi er.fu enf 2 vi er
$/tstScanSqlQualified/ */
call tst t, 'tstScanSqlQualified'
b =jBuf('abc -- kommentar',,' -- ',,right('ab_', 72),'3F-- kom',
, '"abc" -- ko', ' -- ',right('"ab_', 72),'Ef"-- kom',
, 'eins."Zwei', '" -- com', ' . -- com', ' -- com',
, 'drei -- ko', '"vi er"."fu enf " -- co')
s = scanOpen(scanSqlReset(tstScn, b))
do sx=1 while \scanEnd(s)
if scanSqlQuID(s) then
call tstOut t, 'sqlQuId' m.s.val m.s.val.0 m.s.val.1
else if scanSpace(s) then call tstOut t, 'spaceNL'
else call scanErr s, 'cannot scan'
end
call tstEnd t
/*
$=/tstScanSqlNum/
### start tst tstScanSqlNum #######################################
sqlNum 1
spaceNL
sqlNum 2..
spaceNL
sqlNum .3
spaceNL
sqlNum 4.5
spaceNL
sqlNum +6
spaceNL
sqlNum +7.03
spaceNL
sqlNum -8
spaceNL
sqlNum -.9
spaceNL
sqlNum 1E2
spaceNL
sqlNum -2.E-2
spaceNL
sqlNum +.3E+3
spaceNL
$/tstScanSqlNum/ */
call tst t, 'tstScanSqlNum'
b =jBuf('1 2. .3 4.5 +6 + --kom', , ' -- com ', , ' 7.03 -8 - .9',
'1e2 - 2.e-2 + .3e+3')
s = scanOpen(scanSqlReset(tstScn, b))
do sx=1 while \scanEnd(s)
if scanSqlNum(s) then
call tstOut t, 'sqlNum' m.s.val
else if scanSpace(s) then call tstOut t, 'spaceNL'
else call scanErr s, 'cannot scan'
end
call tstEnd t
/*
$=/tstScanSqlNumUnit/
### start tst tstScanSqlNumUnit ###################################
sqlNumUnit 1 KB
spaceNL
sqlNumUnit .3 MB
sqlNumUnit .5
sqlNumUnit +6.E-5 B
spaceNL
sqlNumUnit -7
char *
spaceNL
sqlNumUnit -.8
char T
char B
spaceNL
*** err: scanErr bad unit TB after +9..
. e 1: last token Tb scanPosition .
. e 2: pos 41 in line 1: 1 kb .3mB.5 + 6.e-5B -7* -.8 TB + 9.T+
b
sqlNumUnit +9..
spaceNL
$/tstScanSqlNumUnit/ */
call tst t, 'tstScanSqlNumUnit'
b = jBuf('1 kb .3mB.5 + 6.e-5B -7* -.8 TB + 9.Tb')
s = scanOpen(scanSqlReset(tstScn, b))
do sx=1 while \scanEnd(s)
if scanSqlNumUnit(s, 0, 'B KB MB') then
call tstOut t, 'sqlNumUnit' m.s.val
else if scanSpace(s) then call tstOut t, 'spaceNL'
else if scanChar(s ,1) then call tstOut t, 'char' m.s.tok
else call scanErr s, 'cannot scan'
end
call tstEnd t
/*
$=/tstScanSqlClass/
### start tst tstScanSqlClass #####################################
i a 1 A
d "bC" 1 bC
q d.e 2 D.E
q f." g".h 3 F. g.H
s 'ij''kl' 3 ij'kl
s x'f1f2' 3 12
s X'f3F4F5' 3 345
.. . 3 .
n .0 3 .0
n 123.4 3 123.4
n 5 3 5
i g 1 G
$/tstScanSqlClass/ */
call tst t, 'tstScanSqlClass'
b = jBuf('a "bC" d.e f." g".h' "'ij''kl' x'f1f2' X'f3F4F5'" ,
, '. .0 123.4 5 g')
h = scanOpen(scanSqlReset(tstScn, b))
do sx=1 while scanSqlClass(h)
call tstOut t, m.h.sqlClass m.h.tok m.h.val.0 m.h.val
end
call tstEnd t
return
endProcedure tstScanSql
tstUtc2d: procedure expose m.
/*
$=/tstUtc2d/
### start tst tstUtc2d ############################################
. ff 255
. ffff 65535
. 10000 65536 65536 = 1 * 16 ** 4
. 10001 65537
. ffffff 16777215
. 1000000 16777216 16777216 = 1 * 16 ** 6
. 1000001 16777217
. 20000FF 33554687
. 100000000 4294967296 4294967296 = 1 * 16 ** 8
. 300000000 12884901888 12884901888 = 3 * 16 ** 8
. 3020000EF 12918456559
$/tstUtc2d/
*/
numeric digits 33
call tst t, 'tstUtc2d'
all = 'ff ffff 10000 10001 ffffff 1000000 1000001 20000FF' ,
'100000000 300000000 3020000EF'
do ax = 1 to words(all)
a = word(all, ax)
if substr(a, 2) = 0 then
b = right(left(a, 1) * 16 ** (length(a)-1), 15) ,
'=' left(a, 1) '* 16 **' (length(a)-1)
else
b = ''
call tstout t, right(a, 15)right(utc2d(x2c(a)), 15)b
end
call tstEnd t
return
endProcedure tstUtc2d
/**** tst: test infrastructure ***************************************/
/*--- test hook -----------------------------------------------------*/
wshHook_T: procedure expose m.
parse arg m, rest
do wx=1 to words(rest)
interpret 'call tst'word(rest, wx)
end
if wx > 2 then
call tstTotal
if wx > 1 then
return ''
/* default test */
say ii2rzdb(ee)
say ii2rzdb(eq)
say ii2rzdb(eq)
do y = left(date('s'), 4) - 17 to left(date('s'), 4) + 7
say y timeYear2Y(y) timeY2Year(timeYear2Y(y))
end
do y = left(date('s'), 4) - 69 to left(date('s'), 4) + 30
say y timeYear24(substr(y, 3))
end
d = date('s')
say d 'b' date('b', d , 's')
say d 'b' date('b', 20150101, 's') 'jul' date('j')
say d 'l14' date('b', 20150101, 's') - date('b', 20140101, 's')
say d 'l16' date('b', 20170101, 's') - date('b', 20160101, 's')
say fUnit('d', 3e7)
call err tstEnd
call tstfTst
call sqlConnect DBAF
call catColCom 'cmnBatch', 'DSN_PGROUP_TABLE',
, 'cmnBatch', 'DSN_PGROUP_TABLE_new'
call sqlDisConnect
return ''
endProcedure wshTst
/*--- initialise m as tester with name nm
use inline input nm as compare lines ------------------------*/
tst: procedure expose m.
parse arg m, nm, cmpSt
call tstReset m, nm
m.tst.tests = m.tst.tests+1
if cmpSt == '' then do
cmpSt = mCut(t'.CMP', 0)
call tst4dp cmpSt, mapInline(nm)
end
m.m.cmp = cmpSt
m.m.moreOutOk = 0
call mAdd mCut(m'.IN', 0), 'tst in line 1 eins ,' ,
, 'tst in line 2 zwei ; ' ,
, 'tst in line 3 drei .schluss.'
call tstOut m, left('### start tst' nm '', 67, '#')
call errReset 'hos', 'return tstErrHandler(ggTxt)'
call sqlRetDef
m.m.errCleanup = m.err_cleanup
m.tst_m = m
if m.tst.ini.j == 1 then do
m.m.jWriting = 0
call jOpen jReset(oMutatName(m, 'Tst')), '>'
m.m.in.jReading = 0
call jOpen jReset(oMutatName(m'.IN', 'Tst')), '<'
if m.tst.ini.e \== 1 then do
m.m.oldJin = m.j.in
m.m.oldOut = m.j.out
m.j.in = m'.IN'
m.j.out = m
end
else do
if m.pipe.0 <> 2 then
call tstErr m, 'm.pipe.0' m.pipe.0 '<> 2'
call pipe '+Ff', m , m'.IN'
end
end
if m.tstTime_ini \== 1 then do
m.tstTime_ini = 1
m.tstTimeNm = ''
aE = right(time('L'), 20, 0)
m.tstTimeLaEla = substr(aE, 12) ,
+ 60 * substr(aE, 9, 2) + 3600 * left(aE, 7)
m.tstTimeLaCpu = sysvar('syscpu')
end
return m
endProcedure tst
tstEnd: procedure expose m.
parse arg m, opt opt2
cmp = m.m.cmp
m.m.jReading = 0
m.m.jWriting = 0
drop m.tst_m
if m.tst.ini.j == 1 then do
m.m.jReading = 0
m.m.jWriting = 0
if m.tst.ini.e \== 1 then do
m.j.in = m.m.oldJin
m.j.out = m.m.oldOut
end
else do
if m.j.in \== m'.IN' | m.j.out \== m then
call tstErr m, m.j.in '\==' m '|' m.j.out '\==' m
call pipe '-'
if m.pipe.0 <> 2 then
call tstErr m, 'm.pipe.0' m.pipe.0 '<> 2'
end
end
if m.m.err = 0 then
if m.m.errCleanup \= m.err_cleanup then
call tstErr m, 'err_cleanup' m.err_cleanup '<> old',
m.m.errCleanup
if m.m.out.0 \= m.cmp.0 & \ (m.m.moreOutOk,
& m.m.out.0 > m.cmp.0) then do
call tstErr m, 'old' m.cmp.0 'lines \= new' m.m.out.0
do nx = m.m.out.0 + 1 to min(m.m.out.0+10, m.cmp.0)
say 'old - ' m.cmp.nx
end
end
call errReset 'h'
m.tst.act = ''
soll = 0
if opt = 'err' then do
soll = opt2
if m.m.err \= soll then
call err soll 'errors expected, but got' m.m.err
end
if m.m.err \= soll then do
say 'new lines:' (m.m.out.0 - 1)
call tst2dpSay m.m.name, m'.OUT', 68
end
say left('###' m.m.name 'end with' m.m.err 'errors ', 67, '#')
if 1 & m.m.err \= soll then
call err 'dying because of' m.m.err 'errors'
m.m.trans.0 = m.m.trans.old
nm = strip(m.m.name)
aE = right(time('L'), 20, 0)
aE = substr(aE, 12) + 60 * substr(aE, 9, 2) + 3600 * left(aE, 7)
aC = sysvar('syscpu')
if aE < m.tstTimeLaEla | aC < m.tstTimeLaCpu then
call err 'backward time/cpu'
if m.tstTime.nm \== 1 then do
m.tstTime.nm = 1
m.tstTimeNm = m.tstTimeNm nm
m.tstTime.nm.count = 1
m.tstTime.nm.ela = aE - m.tstTimeLaEla
m.tstTime.nm.cpu = aC - m.tstTimeLaCpu
end
else do
m.tstTime.nm.count = m.tstTime.nm.count + 1
m.tstTime.nm.ela = m.tstTime.nm.ela + aE - m.tstTimeLaEla
m.tstTime.nm.cpu = m.tstTime.nm.cpu + aC - m.tstTimeLaCpu
end
/* say left('%%%time' nm, 20) ,
f('%7.3i %9.3i', aC - m.tstTimeLaCpu , aE - m.tstTimeLaEla) ,
f('cum %6i %7.3i %9.3i', m.tstTime.nm.count, m.tstTime.nm.cpu,
, m.tstTime.nm.ela) */
m.tstTimeLaEla = aE
m.tstTimeLaCpu = aC
return
endProcedure tstEnd
tstTimeTot: procedure expose m.
tCnt = 0
tCpu = 0
tEla = 0
say 'tstTimeTotal'
do tx=1 to words(m.tstTimeNm)
nm = word(m.tstTimeNm, tx)
say left(nm, 12) f('%6i %7.3i %9.3i', m.tstTime.nm.count,
, m.tstTime.nm.cpu, m.tstTime.nm.ela)
tCnt = tCnt + m.tstTime.nm.count
tCpu = tCpu + m.tstTime.nm.cpu
tEla = tEla + m.tstTime.nm.ela
end
say left('total', 12) ,
f('%6i %7.3i %9.3i', tCnt, tCpu, tEla)
return
endProcedre tstTimeTot
tstReset: procedure expose m.
parse arg m, nm
call tstIni
m.m.name = nm
m.m.inIx = 0
m.m.out.0 = 0
m.m.err = 0
m.err.count = 0
m.tst.act = m
if \ datatype(m.m.trans.0, 'n') then
m.m.trans.0 = 0
m.m.trans.old = m.m.trans.0
return
endProcedure tstReset
/*--- tstIni: global initialization ---------------------------------*/
tstIni: procedure expose m.
if m.tst.ini \== 1 then do
m.tst.ini = 1
call mapIni
m.tst.err = 0
m.tst.trc = 0
m.tst.errNames = ''
m.tst.tests = 0
m.tst.act = ''
m.tst_csmRz = 'RZZ'
m.tst_csmDb = 'DE0G'
m.tst_csmRzDb = m.tst_csmRz'/'m.tst_csmDb
m.tst_csmServer = 'CHROI00ZDE0G'
m.tst_long = 0
end
if m.tst.ini.j \== 1 & m.j.ini == 1 then do
m.tst.ini.j = 1
call classNew 'n Tst u JRW', 'm',
, "jOpen",
, "jRead if \ tstRead(m, rStem) then return 0",
, "jWrite call tstWriteBuf m, wStem"
end
if m.tst.ini.e \== 1 & m.pipe_ini == 1 then do
m.tst.ini.e = 1
end
return
endProcedure tstIni
tst2dp: procedure expose m.
parse arg st, dp, ml
dx = m.dp.0
do sx=1 to m.st.0
li = m.st.sx
cx = 1
do until cx > length(li)
c = substr(li, cx, 1)
ou = left('.', strip(c) == '' | pos(c, '.+') > 0)
ex = min(length(li),cx+ml-length(ou)-2)
ou = ou || substr(li, cx, ex+1-cx)
dx = dx + 1
c = right(ou, 1)
if ex < length(li) then
m.dp.dx = ou || '+'
else if strip(c) == '' | pos(c, '.+') > 0 then
m.dp.dx = ou || '.'
else
m.dp.dx = ou
cx = ex +1
end
end
m.dp.0 = dx
return
endProcedure tst2dp
tst2dpSay: procedure expose m.
parse arg name, st, ml
say '$=/'name'/'
call tst2dp st, mCut('TST.TMP', 0), 68
do nx=1 to m.tst.tmp.0
say ' ' m.tst.tmp.nx
end
say '$/'name'/'
return tst2dpSay
tst4dp: procedure expose m.
parse arg st, dp
sx = m.st.0
inData = 0
data = ''
do dx=1 to m.dp.0
li = strip(m.dp.dx)
if pos(left(li, 1), '.+') > 0 then
li = substr(li, 2)
if right(li, 1) == '+' then do
inData = 1
data = data || left(li, length(li)-1)
iterate
end
if right(li, 1) == '.' then
li = left(li, length(li)-1)
sx = sx + 1
m.st.sx = repAll(data || li, '$ä', '/*', '$ö', '*/')
inData = 0
data = ''
end
m.st.0 = sx
if inData then
call err 'end inData'
return
endProcedure tst4dp
/*--- write to test: say lines and compare them ---------------------*/
tstOut: procedure expose m.
parse arg m, arg
do tx=m.m.trans.0 by -1 to 1
arg = repAll(arg, word(m.m.trans.tx, 1),
, subword(m.m.trans.tx, 2))
end
arg = repAll(arg, 'in' m.myWsh':', 'in wsM:')
call mAdd m'.OUT', arg
nx = m.m.out.0
cmp = m.m.cmp
c = m.cmp.nx
if nx > m.cmp.0 then do
if nx = m.cmp.0+1 & \ m.m.moreOutOK then
call tstErr m, 'more new Lines' nx
end
else if c \== arg & c \== '%%%' then do
do cx=1 to min(length(c), length(arg)) ,
while substr(c, cx, 1) == substr(arg, cx, 1)
end
msg = 'old line' nx '<> new overnext, firstDiff' cx',',
'len old' length(c)', new' length(arg)
if cx > 10 then
msg = overlay('|', msg, cx-10)
call tstErr m, msg
say c
end
say arg
return 0
endProcedure tstOut
tstWriteBuf: procedure expose m.
parse arg m, wStem
if wStem == m'.BUF' then do
xStem = mAddSt(mCut(wStem'_tstWriteXStem', 0), wStem)
m.wStem.0 = 0 /* attention avoid infinite recursion | */
end
else
xStem = wStem
do wx=1 to m.xStem.0
call tstWrite m, m.xStem.wx
end
return
endProcedure tstWriteBuf
tstWrite: procedure expose m.
parse arg m, var
cl = objClass(var)
if cl == m.class_N then do
call tstOut m, 'tstR: @ obj null'
end
else if cl == m.class_S then do
call tstOut m, var
end
else if abbrev(var, m.o_escW) then do
call tstOut m, o2String(var)
end
else if cl == m.class_V then do
call tstOut m, m.var
end
else if oKindOf(var, 'JRW') then do
call tstOut m, 'tstWriteO kindOf JRW jWriteNow begin <<<'
call jWriteNow m, var
call tstOut m, 'tstWriteO kindOf JRW jWriteNow end >>>'
end
else if oKindOf(var, 'ORun') then do
call tstOut m, 'tstWriteO kindOf ORun oRun begin <<<'
call oRun var
call tstOut m, 'tstWriteO kindOf ORun oRun end >>>'
end
else do
call tstTransOC m, var
call classOut , var, 'tstR: '
end
return
endProcedure tstWrite
tstTransOC: procedure expose m.
parse arg m, var
cl = objClass(var)
if cl == m.class_N | cl == m.class_S | cl == m.class_W then
return
c1 = className(cl)
vF = 0
do tx=m.m.trans.0 by -1 to 1 until vF & c1 == ''
if word(m.m.trans.tx, 1) == var then
vF = 1
if word(m.m.trans.tx, 1) == c1 then
c1 = ''
end
if \ vF then
call mAdd M'.TRANS', var 'tstWriteoV' ||(m.m.trans.0+1)
if c1 == '' then nop
else if m.cl.name == '' then
call mAdd M'.TRANS', c1 'class*' ||(m.m.trans.0+1)
else if m.cl.name \== m.cl.met then
call mAdd M'.TRANS', c1 m.cl.met ||(m.m.trans.0+1)
return
endProcedure tstTransOC
/*--- translate the tst_csm* variables ------------------------------*/
tstTransCsm: procedure expose m.
parse arg t
say 'csm to' m.tst_csmRzDb m.tst_csmServer
call mAdd t.trans, m.tst_csmRZ '<csmRZ>' ,
, m.tst_csmDb '<csmDB>' ,
, m.tst_csmServer '<csmServer>'
s2 = iirz2sys(m.tst_csmRz)
do sx=0 to 9
call mAdd t.trans, s2 || sx '<csmSys*>'
end
return
endProcedure tstTransCsm
tstRead: procedure expose m.
parse arg mP, rStem
if right(mP, 3) \== '.IN' then
call err 'tstRead bad m' mP
m = left(mP, length(mP)-3)
ix = m.m.inIx + 1
m.m.inIx = ix
m.rStem.0 = ix <= m.mP.0
m.rStem.1 = m.mP.ix
if ix <= m.m.in.0 then
call tstOut m, '#jIn' ix'#' m.m.in.ix
else
call tstOut m, '#jIn eof' ix'#'
return m.rStem.0
endProcedure tstRead
tstFilename: procedure expose m.
parse arg suf, opt
if m.err_os == 'TSO' then do
parse value dsnCsmSys(suf) with sys '/' suf
dsn = dsn2jcl('~tmp.tst.'suf)
if sys \== '*' then
dsn = sys'/'dsn
if opt = 'r' then do
if dsnExists(dsn) then
call dsnDel dsn
do fx=1 to dsnList(tstFileName, dsn)
call dsnDel m.tstFileName.fx
end
end
return dsn
end
else if m.err_os == 'LINUX' then do
if abbrev(suf, '/') then
fn = suf
else
fn = .Stream%%new('~/tmp/tst/'suf)%%qualify /* full path */
cx = lastPos('/', fn)
if cx > 0 then do
dir = left(fn, cx-1)
if \sysIsFileDirectory(dir) then
call adrSh "mkdir -p" dir
if \sysIsFileDirectory(dir) then
call err 'tstFileName could not create dir' dir
end
if opt \= 'r' then
nop
else if sysIsFile(fn) then
call sysFileDelete fn
else if sysIsFileDirectory(fn) then
call adrSh 'rm -r' fn
return fn
end
else
call err 'tstFilename does not implement os' m.err_os
endProcedure tstFilename
/*--- say total errors and fail if not zero -------------------------*/
tstTotal: procedure expose m.
say '######'
/* say '###### astStatsTotals'
do sx=1 to words(m.comp_astStats)
k = word(m.comp_astStats, sx)
say f('%5c %7i %7i %7i', k, m.comp_astStats.k,
, m.comp_astStatT.k, m.comp_astStat1.k)
end
say '######' */
say '######' m.tst.tests 'tests with' ,
m.tst.err 'errors in' m.tst.errNames
say '######'
say '######'
if m.tst.err \== 0 then
call err m.tst.err 'errors total'
return
endProcedure tstTotal
/*--- test err: message, count it and continue ----------------------*/
tstErr: procedure expose m.
parse arg m, msg
say '### error' msg
m.m.err = m.m.err + 1
m.tst.err = m.tst.err + 1
nm = m.m.name
if wordPos(nm, m.tst.errNames) < 1 then
m.tst.errNames = m.tst.errNames nm
return 0
endProcedure tstErr
/*--- tstErrHandler: intercept errors -------------------------------*/
tstErrHandler: procedure expose m.
parse arg ggTxt
m = m.tst.act
if m == '' then
call err ggTxt
m.err.count = m.err.count + 1
call splitNl err, 0, errMsg(' }'ggTxt)
call tstOut m.tst.act, '*** err:' m.err.1
do x=2 to m.err.0
call tstOut m, ' e' (x-1)':' m.err.x
end
return 0
endSubroutine tstErrHandler
tstTrc: procedure expose m.
parse arg msg
m.tst.trc = m.tst.trc + 1
say 'tstTrc' m.tst.trc msg
return m.tst.trc
endProcedure tstTrc
/*--- tstData -------------------------------------------------------*/
tstData: procedure expose m.
parse arg ty 2 le 'n' nu, l, r, num
abs = abs(num)
if nu \== '' then do
if abs // 5 = 0 then
return 'null' || (abs % 5 // nu + 1)
end
if ty = 'c' then do
if le = '' then
le = 8
le = abs // le + 1
if r = '' then
r = '+'
return left(l || num || r, le, right(r, 1))
end
if pos(ty, 'ief') < 1 then
call err 'bad type' ty
nn = abs
if abbrev(num, '-') | abbrev(num, '+') then
parse var num si 2 nn
else
si = ''
if ty == 'e' then
ex = 'e' || left('-', abs // 2) || (abs // 15)
else
ex = ''
if le \== '' then
nn = right(nn, abs // max(1, le - length(si||ex)) + 1, 1)
if ty \== 'i' & (abs // 4) \= 0 & length(nn) > 1 then
nn = overlay('.', nn, length(nn) - abs // length(nn))
return si || nn || ex
endProcedure tstData
tstDataClassFo: procedure expose m.
parse arg flds
ty = ''
do fx=1 by 2 to words(flds)
if word(flds, fx) = '.' then
ty = ty', v'
else
ty = ty', f' word(flds, fx) 'v'
end
t = classNew('n* tstData u' substr(ty, 2))
fo = oNew(m.t.name)
ff = oFldD(fo)
do fx=1 to m.ff.0
f = fo || m.ff.fx
m.f = word(flds, 2*fx)
end
return fo
endProcedure tstDataClassFo
tstDataClassOut: procedure expose m.
parse arg flds, f, t
fo = tstDataClassFo(flds)
ff = oFldD(fo)
do x=f to t
o = oCopy(fo)
do fx=1 to m.ff.0
f = o || m.ff.fx
m.f = tstData(m.f, substr(m.ff.fx, 2),
, '+'substr(m.ff.fx,2)'+', x)
end
call out o
end
return
endProcedure tstDataClassOut
/* copy tstAll end **************************************************/
}¢--- A540769.WK.REXX(TSTERR) cre=2012-03-08 mod=2012-03-08-16.30.24 A540769 ---
/*
tstErr: test err mit out
output sollte folgermassen aussehen:
help +++++
****************************************************** end help
call out eins
fatal error in TSTERR: fehler test
wie gehts
und drittens
err cleanup begin ;say 'cleanup zwei';say 'cleanup eins';
cleanup zwei
cleanup eins
err cleanup end ;say 'cleanup zwei';say 'cleanup eins';
fatal error in TSTERR: divide by zero to show stackHistory +++++
*/
call help 'tst help on' errOS()
call out 'call out eins'
call errReset 'h'
call errAddCleanup "say 'cleanup eins'"
call errAddCleanup "say 'cleanup zwei'"
call err 'fehler test\nwie gehts\nund drittens'
/* copy err begin ******************************************************
messages, errorhandling,help
***********************************************************************/
errIni: procedure expose m.
if m.err.ini == 1 then
return
call outIni
m.err.ini = 1
m.err.handler = ''
m.err.cleanup = ';'
m.err.opt = ''
return
endProcedure errIni
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err.opt, m.err.handler
if pos('I', translate(m.err.opt)) > 0 then
if errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
call adrIsp 'control errors return'
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
call errIni
drop err handler cleanup opt call return
if ggOpt == '' & m.err.handler \== '' then do
if 1 then do /* no detection of recursive err call loop
--> will anyway fail by stack overflow */
interpret m.err.handler
end
else do
/* avoid recursive err call loop */
drop call return
if symbol('m.err.call') \== 'VAR' then
m.err.call = 1
else
m.err.call = m.err.call + 1
if m.err.call > 10 then do
say 'errHandler loop:' m.err.handler
end
else do
m.err.return = 1
call errInterpret m.err.handler
m.err.call = m.err.call - 1
if m.err.return then
return result
end
end
end
call outDst
call errSay ggTxt, 'e'
call errCleanup
if ggOpt == '' then
ggOpt = m.err.opt
ggOpt = translate(ggOpt)
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 then do
call errSay 'divide by zero to show stackHistory', 'e'
x = 1 / 0
end
call errSay 'exit(12)', 'e'
exit errSetRc(12)
endSubroutine err
/*--- error routine: user message cleanup exit -----------------------*/
errEx:
parse arg ggTxt
call errIni
call outDst
call errSay ggTxt
call errCleanup
exit 8
endProcedure errEx
errAddCleanup: procedure expose m.
parse arg code
if m.err.ini \== 1 then
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
if m.err.ini \== 1 then
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
cl = m.err.cleanup
if cl = ';' then
return
m.err.cleanup = ';'
say 'err cleanup begin' cl
call errInterpret cl
say 'err cleanup end' cl
return
endProcedure errCleanup
errInterpret: procedure expose m.
parse arg code
interpret code
m.err.return = 0
return
endProcedure errInterpret
/*--- assert that the passed rexx expression evaluates to true -------*/
assert:
interpret 'assertRes =' arg(1)
if \ assertRes then
call err 'assert failed' arg(1)':' arg(2)
return
endProcedure assert
/*--- output an errorMessage msg with pref pref
split message in lines at '/n' ---------------------------*/
errSay: procedure expose m.
parse arg msg, pref
parse source . . ggS3 . /* current rexx */
if pref == 'e' then
msg = 'fatal error in' ggS3':' msg
else if pref == 'w' then
msg = 'warning in' ggS3':' msg
else if pref \== '' then
msg = pref':' msg
return outNl(msg)
endProcedure errSay
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg, op
call errSay msg, 'e'
call help
call err msg, op
endProcedure errHelp
/*--- return the Operating System we are running on: TSO or LINUX ---*/
errOS: procedure expose m.
parse source os .
return os
endProcedure errOS
/*--- set rc for ispf: -------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared varible 3IspfRc
back as return code
----------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- output a trace message if m.tr is set -----------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
call out 'debug' msg
return
endProcedure debug
/*--- display the first comment block of the source as help ----------*/
help: procedure expose m.
parse source . . s3 .
call out right(' help for rexx' s3, 79, '*')
do ax=1 to arg()
say ' ' arg(ax)
end
do lx=1 by 1
if pos('/*', sourceLine(lx)) > 0 then
leave
else if lx > 10 then do
call out '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
call out li
end
call out right(' end help for rexx' s3, 79, '*')
return 4
endProcedure help
/*--- output all lines (separated by '\n') of all args --------------*/
outNl: procedure expose m.
do ax=1 to max(1, arg())
msg = arg(ax)
sx = 0
bx = -1
do lx=1 until bx >= length(msg)
ex = pos('\n', msg, bx+2)
if ex < 1 then
ex = length(msg)+1
call out substr(msg, bx+2, ex-bx-2)
bx = ex
end
end
return 0
endProcedure outNl
/* copy err end *****************************************************/
/* copy out begin ******************************************************
out interface simple with say only
***********************************************************************/
outIni: procedure expose m.
parse arg msg
return
endProcedure outIni
/*--- output a message to the current destination -------------------*/
out: procedure expose m.
parse arg msg
say msg
return 0
endProcedure out
/*--- set a new out destination and return old one ------------------*/
outDst: procedure expose m.
parse arg d
return ''
endProcedure outDst
/* return the contents of a string or std input */
inp2str: procedure expose m.
parse arg rdr, opt
return rdr
endProcedure inp2str
/* copy out end *****************************************************/
}¢--- A540769.WK.REXX(TT) cre=2009-08-17 mod=2015-05-25-10.45.06 A540769 -------
/* rexx */
m.eins = 'say preting; interpret mk("EINS", "say executing eins")'
say m.eins
interpret m.eins
say m.eins
interpret m.eins
exit
mk: procedure expose m.
parse arg nn, cd
say 'making' nn
m.nn = cd
return cd
say sysvar('sysnode')
exit
call fmtTimeTest
err:
say 'error' arg(1)
exit
fmtTime: procedure expose m.
parse arg s, signed
return fmtUnits(s, 't', signed==1)
endProcedure fmtTime
fmtDec: procedure expose m.
parse arg s, signed
return fmtUnits(s, 'd', signed==1)
endProcedure fmtDec
fmtUnits: procedure expose m.
parse arg s, scale, signed
if s >= 0 then
res = fmtUnitsNN(s, scale, wi)
else
res = '-'fmtUnitsNN(abs(s), scale, wi)
len = m.fmt.units.scale.f.length + signed
if length(res) <= len then
return right(res, len)
if \ abbrev(res, '-') then
return right(right(res, 1), len, '+')
if length(res) = len+1 & datatype(right(res, 1), 'n') then
return left(res, len)
return right(right(res, 1), len, '-')
endProcedure fmtUnits
fmtUnitsNN: procedure expose m.
parse arg s, scale
sf = 'FMT.UNITS.'scale'.F'
sp = 'FMT.UNITS.'scale'.P'
if m.sf \== 1 then do
call fmtIni
if m.sf \== 1 then
call err 'fmtUnitsNN bad scale' scale
end
do q=3 to m.sp.0 while s >= m.sp.q
end
do forever
qb = q-2
qu = q-1
r = format(s / m.sp.qb, ,0)
if q > m.sf.0 then
return r || substr(m.sf.units, qb, 1)
if r < m.sf.q * m.sf.qu then
return (r % m.sf.qu) || substr(m.sf.units, qu, 1) ,
|| right(r //m.sf.qu, m.sf.width, 0)
q = q + 1
end
endProcedure fmtUnitsNN
fmtIni: procedure expose m.
if m.fmt.ini == 1 then
return
m.fmt.ini = 1
call fmtIniUnits 't', '?smhd', 0 100 60 60 24 100, 0.01, 2
call fmtIniUnits 'd', '?.kMGTPE', 0 copies('1000 ',8), 0.001, 3
return
endProcedure fmtIni
fmtIniUnits: procedure expose m.
parse arg sc, us, fact, prod, wi
sf = 'FMT.UNITS.'sc'.F'
sp = 'FMT.UNITS.'sc'.P'
m.sf.0 = words(fact)
if length(us) + 1 <> m.sf.0 then
call err 'fmtIniUnits mismatch' us '<==>' fact
m.sf.1 = word(fact, 1)
m.sp.1 = prod
do wx=2 to m.sf.0
wx1 = wx-1
m.sf.wx = word(fact, wx)
m.sp.wx = m.sp.wx1 * m.sf.wx
end
m.sp.0 = m.sf.0
m.sf.units = us
m.sf.width = wi
m.sf.length= 2 * wi + 1
m.sf = 1
return
endProcedure fmtIniUnits
fmtTimeTest: procedure
d = 86400
lst = .3 .8 1 1.2 59 59.07 59.997 60 60.1 611 ,
3599.4 3599.5 3661 d-3000 d-1700 d d+3500 ,
d * 98 d * 99.49 d * 99.985 d*100 d * 9999 d * 9999.6 ,
d * 1e5
do wx=1 to words(lst)
say right(word(lst, wx), 14) ,
'==>' fmtTime( word(lst, wx) ) ,
'++>' fmtTime( word(lst, wx), 1),
'-+>' fmtTime('-'word(lst, wx), ),
'-->' fmtTime('-'word(lst, wx), 1)'|'
end
do wx=1 to words(lst)
say right(word(lst, wx), 14) ,
'==>' fmtDec( word(lst, wx) ) ,
'++>' fmtDec( word(lst, wx), 1),
'-+>' fmtDec('-'word(lst, wx), ),
'-->' fmtDec('-'word(lst, wx), 1)'|'
end
return
endProcedure fmtTimeTest
say 'result' result
call abc
say 'result' result
abc: return 'abcReturn'
}¢--- A540769.WK.REXX(TTT) cre=2009-11-30 mod=2012-11-15-09.04.39 A540769 ------
trace ?r
call readDsn 'A540769.WK.REXX(TTT)' , x.
call err x.0 x.1
/* copy adrTso begin *************************************************/
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet ---*/
adrTso:
parse arg ggTsoCmd, ggRet
address tso ggTsoCmd
if rc == 0 then return 0
else if ggRet == '*' then return rc
else if wordPos(rc, ggRet) > 0 then return rc
else
call err 'adrTso rc' rc 'for' ggTsoCmd
return /* end adrTso */
/*--- format dsn from tso format to jcl format -----------------------*/
dsn2jcl: procedure expose m.
parse upper arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
cx = pos('~', dsn)
if cx < 1 & addPrefix == 1 then
return sp'.'dsn
do while cx \== 0
le = left(dsn, cx-1)
ri = substr(dsn, cx+1)
if right(le, 1) == '.' | left(ri, 1) == '.' then
dsn = le || sp || ri
else
dsn = le || left('.', le \== '') || sp ,
|| left('.', ri \== '') || ri
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
parse arg dsn, mbr
bx = pos('(', dsn)
if bx > 0 then
dsn = strip(left(dsn, bx-1))
if mbr <> '' then
dsn = dsn'('strip(mbr)')'
return dsn
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn
lx = pos('(', dsn)
rx = pos(')', dsn, lx+1)
if lx < 1 then
return ''
else if lx < rx then
return substr(dsn, lx+1, rx-lx-1)
else
return strip(substr(dsn,lx+1))
endProcedure dsnGetMbr
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: readDDBegin, readDD*, readDDEnd
write: writeBegin, writeDD*, writeEnd
readDD returns true if data read, false at eof
***********************************************************************/
/*--- prepare reading from a DD --------------------------------------*/
readDDBegin: procedure expose m.
parse upper arg ggDD
call errAddCleanup 'call readDDEnd' ggDD', "*"'
return /* end readDDBegin */
/*--- read from DD ggDD into ggSt, return false at eof ---------------*/
readDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskr' ggDD '(stem' ggSt')', 2
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- finish reading DD ggDD ----------------------------------------*/
readDDEnd: procedure expose m.
parse upper arg ggDD, ggRet
call errRmCleanup 'call readDDEnd' ggDD', "*"'
return adrTso('execio 0 diskr' ggDD '(finis)', ggRet)
endProcedure readDDEnd
/*--- prepare writing to DD ggDD -------------------------------------*/
writeDDBegin: procedure expose m.
parse upper arg ggDD
/* ensure file is erased, if no records are written */
call adrTso 'execio' 0 'diskw' ggDD '(open)'
call errAddCleanup 'call writeDDEnd' ggDD', "*"'
return /* end writeDDBegin */
/*--- write to gg ggDD from stem ggSt, ggCnt records -----------------*/
writeDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt == '' then
ggCnt = value(ggst'0')
call adrTso 'execio' ggCnt 'diskw' ggDD '(stem' ggSt')'
return
endSubroutine writeDD
/*--- end writing to dd ggDD (close) --------------------------------*/
writeDDEnd: procedure expose m.
parse upper arg ggDD, ggRet
call errRmCleanup 'call writeDDEnd' ggDD', "*"'
return adrTso('execio 0 diskw' ggDD '(finis)', ggRet)
endProcedure writeDDEnd
/*--- readNx: read next line, using buffer ---------------------------*/
/*--- begin: allocate dsnSpec and ini ------------------------ -------*/
readNxBegin: procedure expose m.
parse arg m, m.m.dsn, m.m.dd, m.m.Cnt
if m.m.dd = '' then
m.m.dd = 'DDNX'
if m.m.cnt = '' then
m.m.cnt = 1000
m.m.cx = m.m.cnt + 999
m.m.buf0x = 0
m.m.0 = 0
m.m.free = subword(dsnAlloc('dd('m.m.dd')' m.m.dsn), 2)
call readDDBegin m.m.dd
return m
endProcedure readDDNxBegin
/*--- return the stem of the next line, or '' at end -----------------*/
readNx: procedure expose m.
parse arg m
m.m.cx = m.m.cx + 1
if m.m.cx <= m.m.0 then
return m'.'m.m.cx
m.m.buf0x = m.m.buf0x + m.m.0
if \ readDD(m.m.dd, 'M.'m'.', m.m.cnt)then
return ''
m.m.cx = 1
return m'.1'
endProcedure readDDNx
/*--- return the stem of the curr line, '' at end --------------------*/
readNxCur: procedure expose m.
parse arg m
if m.m.cx <= m.m.0 then
return m'.'m.m.cx
else
return ''
endProcedure readNxCur
/*--- return the position (line number) of reader
plus le characters of the current line (default 50) ------*/
readnxPos: procedure expose m.
parse arg m, le
li = m'.'m.m.cx
li = strip(m.li, 't')
if arg() < 2 then
le = 50
if le < 1 then
li = ''
else if length(li) <= le then
li = ':' li
else
li = ':' left(li, le-3)'...'
return 'line' (m.m.buf0x + m.m.cx)li
endProcedure readnxPos
/*--- close and deallocate ------------------------------------------*/
readNxEnd: procedure expose m.
parse arg m
call readDDEnd m.m.dd
interpret m.m.free
return
endProcedure readDDNxEnd
/*--- standardise a dsn spec
word1 dsName or -
word2 dd or -
word3 disp or -
word4 to first : attributes in tso format
after first : attributes for new allocation
----------------------------------------------------------------------*/
dsnSpec: procedure expose m.
parse upper arg spec
rr = '' /* put leading - in separate words */
do sx=1 while words(rr) < 3 & wx \= ''
wx = word(spec, sx)
do while abbrev(wx, '-') & words(rr) < 3
wx = substr(wx, 2)
rr = rr '-'
end
rr = rr wx
end
spec = rr subWord(spec, sx)
na = ''
dd = ''
di = ''
if left(spec, 1) = '&' then /* external spec is handled ok */
spec = strip(substr(spec, 2))
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, '.') | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
di = w
else if w = 'CATALOG' then
di = di w
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
na = strip(substr(w, 5, length(w)-5))
else if na == '' then
na = dsn2jcl(w)
else if dd == '' then
dd = w
else if di == '' then
di = w
else
leave
end
if na == '' then
na = '-'
else if abbrev(na, "'") then
na = substr(na, 2, length(na)-2)
if dd == '' then dd = '-'
if di == '' then di = '-'
re = subword(spec, wx)
if abbrev(re, '.') then
re = substr(re, 2)
return na dd di re
endProcedure dsnSpec
/*--- alloc a dsn with dsnAlloc
if the dsn is inuse wait and retry
until either the allocation is successfull
or the timeout occurs --------------------------------------*/
dsnAllocWait: procedure expose m.
parse upper arg spec, pDi, pDD, timeOut
x = max(1, arg() - 1)
do rt=0
m.adrTsoAl.1 = ''
m.adrTsoAl.2 = ''
m.adrTsoAl.3 = ''
call outtrap m.adrTsoAl.
res = dsnAlloc(spec, pDi, pDD, '*')
call outtrap off
if \ abbrev(res, ' ') then
return res
msg = m.adrTsoAl.1'\n'm.adrTsoAl.2'\n'm.adrTsoAl.3
if rt > timeOut & timeOut \== '' then
return err('timeout allocating' spec time() '\n'msg)
if pos('DATA SET IS ALLOCATED TO ANOTHER', msg) < 1 then
return err('allocating' spec'\n'msg)
say time() 'sleep and retry alloc' spec
call sleep 1, 0
end
endProcedure dsnAllocWait
/*--- alloc a dsn or a dd
spec '-'<ddName>
datasetName? disposition? '.'? attributes? (':' newAtts)?
disp default disposition
dd default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc -----*/
dsnAlloc: procedure expose m.
parse upper arg spec, pDi, pDD, retRc
parse value dsnSpec(spec) with na dd di rest
if na = '-' then
m.dsnAlloc.dsn = ''
else
m.dsnAlloc.dsn = na
if na == '-' & dd \== '-' & di == '-' & rest = '' then
return dd
if dd == '-' & pDD \== '' then
dd = pDD
if dd == '-' then do
if symbol('m.adrTso.ddNum') = 'VAR' then
dd = m.adrTso.ddNum + 1
else
dd = 1
m.adrTso.ddNum = dd
dd = 'DD' || dd
end
if di = '-' & pDi \== '' then
di = pDi
if di = '-' then
di = 'SHR'
else if pos('(', na) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if pos('/', na) > 0 then
return csmAlloc(na dd di rest, retRc)
else
return tsoAlloc(na dd di rest, retRc)
endProcedure dsnAlloc
tsoAlloc: procedure expose m.
parse arg na dd disp rest ':' nn, retRc
c = 'alloc dd('dd')' disp
if na \== '-' then
c = c "DSN('"na"')"
else if disp = 'NEW' and nn \== '' then
c = c dsnCreateAtts(,nn)
call outtrap m.adrTsoAl.
alRc = adrTso(c rest, '*')
call outtrap off
if alRc = 0 then do
call errAddCleanup 'call tsoFree' dd', "*"'
return dd 'call tsoFree' dd';'
end
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& sysDsn("'"m.dsnAlloc.dsn"'") == 'DATASET NOT FOUND' then do
say 'tsoAlloc creating' c rest ':'nn
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na dd disp rest, retRc)
end
do ax=1 to m.adrTsoAl.0
say m.adrTsoal.ax
end
if retRc = '*' | wordPos(alRc, retRc) > 0 then
return ' ' alRc
call err 'tsoAlloc rc' alRc 'for' c rest
endProcedure tsoAlloc
tsoAtts: procedure expose m.
parse arg dsn
rc = listDsi("'"dsn"' SMSINFO")
if rc = 0 then
mv = ''
else if rc = 4 & sysReason = 19 then do
mv = 'UNITCNT(30)'
say 'multi volume' mv
end
else if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
al = 'CAT'
al = ''
if right(sysDsSms, 7) == 'LIBRARY' ,
| abbrev(sysDsSms, 'PDS') then
al = al 'DSNTYPE(LIBRARY)'
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
al = al "DSORG("sysDSorg") MGMTCLAS("sysMgmtClass")",
"DATACLAS("sysDataClass")" ,
"RECFM("translate('1 2 3', ' 'sysREcFM, ' 123')")",
"LRECL("SYSLRECL")",
"blksize("sysBLkSIZE")",
"SPACE("sysPrimary"," sysSeconds")" sysUnits mv
return al
endProcedure tsoAtts
tsoFree: procedure expose m.
parse arg dd, ggRet
call adrTso 'free dd('dd')', ggRet
call errRmCleanup 'call tsoFree' dd', "*"'
return
endProcedure tsoFree
dsnCreateAtts: procedure expose m.
parse arg dsn, atts, forCsm
forCsm = forCsm == 1
aU = ' 'translate(atts)
if abbrev(atts, ':') then do
parse var atts a1 atts
bl = 32760
rl = substr(a1, 3)
if abbrev(a1, ':F') then do
if rl = '' then
rl = 80
recfm='f b'
bl = bl - (bl // rl)
end
else do
if rl = '' then
rl = bl-4
recfm = substr(a1, 2, 1) 'b'
end
if forCsm then
atts = atts "recfm("space(recfm, 0)") lrecl("rl")",
"blkSize("bl")"
else
atts = atts "recfm("recfm") lrecl("rl") block("bl")"
end
if pos('(', dsn) > 0 & pos(' DSNTYPE(', aU) < 1 ,
& pos(' DSORG(', aU) < 1 then
atts = atts 'dsntype(library) dsorg(po)'
if pos(' MGMTCLAS(', aU) < 1 then
atts = atts 'mgmtclas(COM#A091)'
if pos(' SPACE(', aU) < 1 then
if forCsm then
atts = atts 'space(10, 1000) cylinder'
else
atts = atts 'space(10, 1000) cyl'
if dsn == '' then
return atts
return "dataset('"dsnSetMbr(dsn)"')" atts
endProcedure dsnCreateAtts
/*--- read the dataset specified in ggDsnSpec to stem ggSt -----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
interpret subword(ggAlloc, 2)
return
endSubroutine readDsn
/*--- write the dataset specified in ggDsnSpec from stem ggSt
write ggCnt records if not empty otherwise ggst0
if ggSay 1 then say ... records written to ... -------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'open finis)'
interpret subword(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
copyDSN: procedure expose m.
parse arg frSpec, toSpec, ggSay
frDD = dsnAlloc(frSpec, 'SHR', 'FRDD')
toDD = dsnAlloc(toSpec, 'OLD', 'TODD')
call readDDBegin word(frDD, 1)
call writeDDBegin word(toDD, 1)
cnt = 0
do while readDD(word(frDD, 1), r.)
call writeDD word(toDD, 1), r.
cnt = cnt + r.0
end
call readDDEnd word(frDD, 1)
call writeDDEnd word(toDD, 1)
interpret ';' subword(frDD, 2) '; ; ;' subword(toDD, 2)
if ggSay == 1 | m.debug == 1 then
say cnt 'records copied from' frSpec 'to' to toSpec
return
endSubroutine writeDsn
/* copy adrTso end ****************************************************/
/* copy err begin ******************************************************
messages, errorhandling,help
***********************************************************************/
errIni: procedure expose m.
if m.err.ini == 1 then
return
call outIni
m.err.ini = 1
m.err.handler = ''
m.err.cleanup = ';'
m.err.opt = ''
return
endProcedure errIni
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err.opt, m.err.handler
if pos('I', translate(m.err.opt)) > 0 then
if errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
call adrIsp 'control errors return'
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
call errIni
drop err handler cleanup opt call return
if ggOpt == '' & m.err.handler \== '' then do
if 1 then do /* no detection of recursive err call loop
--> will anyway fail by stack overflow */
interpret m.err.handler
end
else do
/* avoid recursive err call loop */
drop call return
if symbol('m.err.call') \== 'VAR' then
m.err.call = 1
else
m.err.call = m.err.call + 1
if m.err.call > 10 then do
say 'errHandler loop:' m.err.handler
end
else do
m.err.return = 1
call errInterpret m.err.handler
m.err.call = m.err.call - 1
if m.err.return then
return result
end
end
end
call outDst
call errSay ggTxt, 'e'
call errCleanup
if ggOpt == '' then
ggOpt = m.err.opt
ggOpt = translate(ggOpt)
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 then do
call errSay 'divide by zero to show stackHistory', 'e'
x = 1 / 0
end
call errSay 'exit(12)', 'e'
exit errSetRc(12)
endSubroutine err
/*--- error routine: user message cleanup exit -----------------------*/
errEx:
parse arg ggTxt
call errIni
call outDst
call errSay ggTxt
call errCleanup
exit 8
endProcedure errEx
errAddCleanup: procedure expose m.
parse arg code
if m.err.ini \== 1 then
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
if m.err.ini \== 1 then
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
cl = m.err.cleanup
if cl = ';' then
return
m.err.cleanup = ';'
say 'err cleanup begin' cl
call errInterpret cl
say 'err cleanup end' cl
return
endProcedure errCleanup
errInterpret: procedure expose m.
parse arg code
interpret code
m.err.return = 0
return
endProcedure errInterpret
/*--- assert that the passed rexx expression evaluates to true -------*/
assert:
interpret 'assertRes =' arg(1)
if \ assertRes then
call err 'assert failed' arg(1)':' arg(2)
return
endProcedure assert
/*--- output an errorMessage msg with pref pref
split message in lines at '/n' ---------------------------*/
errSay: procedure expose m.
parse arg msg, pref
parse source . . ggS3 . /* current rexx */
if pref == 'e' then
msg = 'fatal error in' ggS3':' msg
else if pref == 'w' then
msg = 'warning in' ggS3':' msg
else if pref \== '' then
msg = pref':' msg
return outNl(msg)
endProcedure errSay
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg, op
call errSay msg, 'e'
call help
call err msg, op
endProcedure errHelp
/*--- return the Operating System we are running on: TSO or LINUX ---*/
errOS: procedure expose m.
parse source os .
return os
endProcedure errOS
/*--- set rc for ispf: -------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared varible 3IspfRc
back as return code
----------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- output a trace message if m.tr is set -----------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
call out 'debug' msg
return
endProcedure debug
/*--- display the first comment block of the source as help ----------*/
help: procedure expose m.
parse source . . s3 .
call out right(' help for rexx' s3, 79, '*')
do ax=1 to arg()
say ' ' arg(ax)
end
do lx=1 by 1
if pos('/*', sourceLine(lx)) > 0 then
leave
else if lx > 10 then do
call out '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
call out li
end
call out right(' end help for rexx' s3, 79, '*')
return 4
endProcedure help
/*--- output all lines (separated by '\n') of all args --------------*/
outNl: procedure expose m.
do ax=1 to max(1, arg())
msg = arg(ax)
sx = 0
bx = -1
do lx=1 until bx >= length(msg)
ex = pos('\n', msg, bx+2)
if ex < 1 then
ex = length(msg)+1
call out substr(msg, bx+2, ex-bx-2)
bx = ex
end
end
return 0
endProcedure outNl
/* copy err end *****************************************************/
/* copy out begin ******************************************************
out interface simple with say only
***********************************************************************/
outIni: procedure expose m.
parse arg msg
return
endProcedure outIni
/*--- output a message to the current destination -------------------*/
out: procedure expose m.
parse arg msg
say msg
return 0
endProcedure out
/*--- set a new out destination and return old one ------------------*/
outDst: procedure expose m.
parse arg d
return ''
endProcedure outDst
/* return the contents of a string or std input */
inp2str: procedure expose m.
parse arg rdr, opt
return rdr
endProcedure inp2str
/* copy out end *****************************************************/
}¢--- A540769.WK.REXX(TVB) cre=2009-08-07 mod=2009-08-07-15.15.47 A540769 ------
/* rexx ****************************************************************
wsh
***********************************************************************/
call readDsn '~wk.texv(aa)', i.
do y=1 to i.0
say length(i.y) right(i.y, 30)
end
exit
/*--- main code wsh --------------------------------------------------*/
call errReset 'h'
parse arg fun rest
os = errOS()
if 0 then do /* for special tests */
.output$mc$lineOut('hello walti')
x = .output
say .output$mc$class()
say x$mc$class()
x = file('&out')
call jWrite x, 'hallo walti'
call jClose x
exit
end
if 0 then do
call tstSort
call envIni
call tstFile
call tstTotal
exit
end
if 0 then do
do 2
call tstAll
end
exit
end
if 0 then do
call compIni
call tstScanWin
exit
call envIni
call tstFile
call tstFileList
call tstTotal
exit
call tstAll
call envIni
call tstTotal
exit
end
call compIni
/* if os == 'TSO' then
call oSqlIni
*/ if fun = '' & os == 'TSO' then do /* z/OS edit macro */
parse value wshEditMacro() with done fun rest
if done then
return
end
fun = translate(fun)
if fun = '' then
fun = 'S'
if fun = 'S' | fun = 'D' then /* batch interface */
if os == 'TSO' then
exit wshBatchTSO(fun)
else if os == 'LINUX' then
exit wshBatch(fun, '<-%' file('&in'), '>-%' file('&out'))
else
call err 'implemnt wshBatch' os
if wordPos(fun, 'R E S D') > 0 then /* interpreter */
exit wshInter('-'fun rest)
if wordPos(fun, '-R -E -S -D') > 0 then
exit wshInter(fun rest)
if \ abbrev(fun, 'T') then
call err 'bad fun' fun 'in arg' arg
if fun <> 'T' then do /* list of tests */
c = call fun rest
end
else do
c = ''
do wx=1 to words(rest)
c = c 'call tst'word(rest, wx)';'
end
if c = '' then
c = call 'tstAct;'
else if wx > 2 then
c = c 'call tstTotal;'
end
say 'wsh interpreting' c
interpret c
exit 0
/*--- actual test case ----------------------------------------------*/
tstAct: procedure expose m.
call classOut m.class.class, m.class.class
return 0
endProcedure tstAct
/*--- batch: compile shell or data from inp and
run it to output out -----------------------------------*/
wshBatch: procedure expose m.
parse upper arg ty, inp, out
i = cat(inp)
cmp = comp(i)
if pos('D', ty) || pos('d', ty) > 0 then
ty = 'd'
else
ty = 's'
r = compile(cmp, ty)
if out \== '' then
call envPush out
call oRun r
if out \== '' then
call envPop
return 0
endProcedure wshBatch
/*--- interpret user input: rexx, expr, data or shell ---------------*/
wshInter: procedure expose m.
parse arg inp
do forever
w1 = translate(word(inp, 1))
if abbrev(w1, '-') then do
mode = substr(w1, 2)
inp = subWord(inp, 2)
if mode = '' then
return 0
end
if inp <> '' then do
say 'as' mode 'interpreting' inp
if mode = 'R' then
interpret inp
else if mode = 'E' then
interpret 'say' inp
else if mode = 'S' | mode = 'D' then do
call errReset 'h', 'say "******* intercepting error";',
'call errSay ggTxt; return "";'
call oRun compile(comp(jBuf(inp)),
, translate(mode, 'ds', 'DS'))
call errReset 'h'
end
else
say 'mode' mode 'not implemented yet'
end
say 'enter' mode 'expression, - for end, -r or -e for Rexx' ,
'-s or -d for WSH'
parse pull inp
end
endProcedure wshInter
/*--- batch under tso: input dd(WSH), output dd(OUT) if allocated ---*/
wshBatchTSO: procedure expose m.
parse upper arg ty
i = cat("-WSH")
useOut = listDsi('OUT FILE')
if \ (useOut = 16 & sysReason = 2) then
out = '> -out'
else
out = ''
call wshBatch ty, '< -wsh', out
return 0
endProcedure wshBatchTso
/*--- if we are called
not as editmacro return 0
as an editmacro with arguments: return 0 arguments
without arguments: run editMacro interface ------------------*/
wshEditMacro: procedure expose m.
if \ (adrEdit('macro (mArgs) NOPROCESS', '*') == 0) then
return 0
if mArgs \== '' then
return 0 mArgs
call adrEdit '(d) = dataset'
call adrEdit '(m) = member'
if dsnSetMbr(d, m) = 'A540769.WK.REXX(WSH)' then
return 0
call adrIsp 'control errors return'
pc = adrEdit("process dest range Q", 0 4 8 12 16)
dst = ''
if pc = 0 | pc = 8 then do
call adrEdit "(rFi) = lineNum .zFrange"
call adrEdit "(rLa) = lineNum .zLrange"
if pc = 0 then
call adrEdit "(dst) = lineNum .zDest"
else
dst = rLa
end
else if pc = 12 then do
if adrEdit("find first '$***out' 1", 4) = 0 then do
call adrEdit "(dst) = cursor"
call adrEdit "(li) = line" dst
li = overlay(date(s) time(), li, 20)
call adrEdit "line_before" dst "= (li)"
rFi = 1
rLa = dst-1
end
end
if dst = '' then
msg = 'bitte Bereich mit q oder qq auswaehlen ???' rc ,
'oder $***out Zeile einfuegen'
else if rLa < rFi then
msg = 'firstLine' rFi 'before last' rLa
else
msg = ''
if msg \== '' then do
say msg
return 1
end
/* say 'range' c1 'rc' pc':' rFi '-' rLa 'after' dst */
i = jOpen(jBuf(), m.j.cWri)
o = jBuf()
do lx=rFi to rLa
call adrEdit "(li) = line" lx
call jWrite i, li
end
cmp = comp(jClose(i))
if pos('D', mArgs) > 0 then
ty = 'd'
else
ty = 's'
call errReset 'h',
, 'return wshEditCompErrH(ggTxt, ' rFi',' rLa')'
r = compile(cmp, ty)
call errReset 'h',
, 'return wshEditRunErrH(ggTxt, ' quote(o)',' dst')'
call envPush '>%' o
call oRun r
call envPop
lab = wshEditInsLinSt(dst+1, , o'.BUF')
call wshEditLocate dst-7
return 1
endProcedure wshEditMacro
wshEditLocate: procedure
parse arg ln
call adrEdit '(la) = linenum .zl'
if la < 40 then
return
if ln < 7 then
ln = 1
else
ln = min(ln, la - 40)
call adrEdit 'locate ' ln
return
endProcedure wshEditLocate
wshEditCompErrH: procedure expose m.
parse arg ggTxt, rFi, rLa
call errReset 'h'
oo = outDest('=')
call outDest 'i', outDest()';'outDest('s', mCut(ggStem, 0))
call errSay 'compErr' ggTxt
call outDest 'i', oo
parse var m.ggStem.3 "pos " pos . " in line " lin":"
if pos = '' then do
parse var m.ggStem.3 " line " lin":"
pos = 0
end
lab = rFi + lin
if pos \= '' then
lab = wshEditInsLin(lab, 'msgline', right('*',pos))
lab = wshEditInsLinSt((rFi+lin), 'msgline', ggStem)
call wshEditLocate rFi+lin-25
exit 0
endSubroutine wshEditCompErrH
wshEditRunErrH: procedure expose m.
parse arg ggTxt, so, dst
call errReset 'h'
call errSay ggTxt, '*** run error'
lab = wshEditInsLinSt(dst+1, , so'.BUF')
call outDest 's', mCut(ggStem, 0)
call errSay ggTxt, '*** run error'
call wshEditInsLinSt dst+1, msgline, ggStem
exit 0
endSubroutine wshEditRunErrH
wshEditInsLinCmd: procedure
parse arg wh
if dataType(wh, 'n') then do
if adrEdit("label" wh "= .a", 0 8 12) \= 12 then
return 'line_before .a ='
else
return 'line_after .zl ='
end
else if left(wh, 1) == '.' then
return 'line_before' wh '='
else
return wh
endProcedure wshEditInsLinCmd
wshEditInsLin: procedure
parse arg wh, type
cmd = wshEditInsLinCmd(wh)
do ax=3 to arg()
li = strip(arg(ax), 't')
if li == '' then
iterate
if translate(type) = 'MSGLINE' then do while length(li) > 72
sx = lastPos(' ', li, 72)
if sx < 10 then
sx = 72
one = left(li, sx)
li = ' 'strip(substr(li, sx))
call adrEdit cmd type "(one)"
end
call adrEdit cmd type "(li)", 0 4
end
return cmd
endProcedure wshEditInsLin
wshEditInsLinSt: procedure expose m.
parse arg wh, type, st
cmd = wshEditInsLinCmd(wh)
do ax=1 to m.st.0
call wshEditInsLin cmd, type, m.st.ax
end
return cmd
endProcedure wshEditInsLinSt
/*** end wsh, begin all copies ****************************************/
/* copy tstAll begin *************************************************/
tstAll: procedure expose m.
call tstBase
call tstComp
call tstDiv
return 0
endProcedure tstAll
/* copx tstZos begin **************************************************/
tstZOs:
call sqlIni
call tstSql
call tstSqlO
call tstSqlEnv
call tstTotal
return
endProcedure tstZOs
tstWshBatch:
call adrTso 'alloc dd(WSH) shr dsn(WK.TEXT(WSHBATCH))'
call wshBatch
return adrTso('free dd(WSH)')
tstLmdTiming:
parse arg lev
say timing() lev
call lmdBegin abc, lev
c = 0
do while lmdNext(abc, st.)
c = c + st.0
end
call lmdEnd abc
say timing() lev 'with group - without reading' c
call adrIsp 'lmdinit listid(lmdId) level('lev')'
do c=0 while adrIsp('lmdlist listid(&lmdId) dataset(abc)', 8) = 0
end
call adrIsp 'lmdfree listid(&lmdId)'
say timing() lev 'with list' c
return
endProcedure lmdTiming
tstCsi: procedure expose m.
if 0 then do
call lmd 'A540769.*K'
call tstCsiCla 'A540769.WK.REXX'
call tstCsiCla 'A540769.AAA.DATASETS'
call tstCsiCla 'A540769.RRR.DATASETS'
end
if 0 then do
call tstCsiOpNx 'A540769.WK.*E*'
call tstCsiOpNx 'A540769.AAA.DATASETS'
call tstCsiOpNx 'A540769.RRR.DATASETS'
end
if 1 then do
call tstCsiNxCl 'A540769.WK.**'
call tstCsiNxCl 'DBTF.M*.**'
call tstCsiNxCl 'DBTF.BE*.**'
end
return
tstCsi: procedure expose m.
/* call lmd 'A540769.*K' */
call tstCsi1 'A540769.WK.REXX'
call tstCsi1 'A540769.AAA.DATASETS'
call tstCsi1 'A540769.RRR.DATASETS'
return
tstCsiCla:
parse arg ds
say ds '-->' csiCla(ds)
return
tstCsiOpNx: procedure expose m.
parse arg ds
m = 'NUE123'
s = 'res89'
flds = 'devtyp volser mgmtclas comudsiz NOBYTTRK UDATASIZ HARBA'
say 'csiOpen' ds
call csiOpen m, ds, flds
do while csiNext(m, s)
say m.s 'dev' c2x(m.s.devTyp) ,
'vol' m.s.volSer 'cla' m.s.mgmtclas,
'comuDsiz' m.s.comuDsiz 'noBytTrk' m.s.noBytTrk,
'udatasiz' c2x(m.s.udatasiz) ,
'harba' c2x(m.s.harba)
end
return
tstCsiNxCl: procedure expose m.
parse arg ds
m = 'ABC123'
s = 'efg89'
flds = 'devtyp volser mgmtclas'
say 'csiOpen' ds
call csiOpen m, ds, flds
say timing() 'begin'
do i=1 while csiNext(m, s)
nn = csiArcTape(m.s.volser, m.s.mgmtClas, m.s.devtyp, m.s)
/* oo = csiCla(strip(m.s))
if oo <> nn then
say nn '<>' oo m.s
*/ if i // 1000 = 0 then
say timing() i nn m.s
end
say timing() (i-1) nn m.s
return
endProcedure tstCsiNxCl
listCatClass: procedure expose m.
parse upper arg dsn
call outtrap x., '*'
call adrTso "listcat volume entry('"dsn"')", 4
rt = rc
call outtrap off
/* say 'listct rc =' rt 'lines' x.0 */
cl = ''
vo = ''
if word(x.1, 3) \== dsn then
call jOut 'err ??? for dsn' dsn 'bad first line' x.1
else if pos('NOT FOUND', x.1) > 0 then
return 'notFound'
else if word(x.1, 1)\== 'NONVSAM' then
call jOut 'err ??? for dsn' dsn 'bad first line' x.1
do x=2 to x.0 while vo = '' & left(x.x, 1) = ' '
/* say x.x */
p = pos('MANAGEMENTCLASS-', x.x)
if p > 0 then
vo = strip(word(substr(x.x, p+16), 1), 'l', '-')
p = pos('VOLSER--', x.x)
if p > 0 then
vo = strip(word(substr(x.x, p+6), 1), 'l', '-')
p = pos('DEVCLASS--', x.x)
dt = strip(word(substr(x.x, p+8), 1), 'l', '-')
end
/* say 'lc' cl 'vo' vo 'dt' dt 'dsn' dsn */
if vo = '' then
call jOut '??? err no volume for dsn' dsn
else if vo = 'ARCIVE' then
res = 'arcive'
else if cl = '' then
res = 'tape'
else
res = cl
if abbrev(res, 'ar') \= abbrev(dt, "X'0") ,
| abbrev(res, 'ta') \= abbrev(dt, "X'7") ,
| (left(res, 1) >= 'A') \= abbrev(dt, "X'3") then
call jOut 'err ??? mismatch cl' cl 'vo' vo 'dt' dt 'dsn' dsn
return res
endProcedure listCatClass
/* copx tstZos end **************************************************/
/* copx tstDiv begin **************************************************/
tstDiv:
call tstSort
call tstMatch
call tstTotal
return
endProcedure tstDiv
tstSort: procedure expose m.
call tstSortComp
call tstSortComp '<<='
call tstSortComp 'm.aLe <<= m.aRi'
call tstSortComp 'if 1 then cmp = m.aLe <<= m.aRi; else call err sd'
return
endProcedure tstSort
tstSortComp: procedure expose m.
parse arg cmp
/*<<tstSort
### start tst tstSort #############################################
sort 29 c ACHT DREI DREIZEHN EINS ELF FUENF M.I.25 M.I.26 M.I.27 M+
..I.29 NEUN SECHS SIEBEN VIER VIERZEHN ZEHN ZWEI ZWOELF 0 1 1 1 2 2+
. 3 3 4 4
sort 22 c ACHT DREIZEHN ELF M.I.25 M.I.26 M.I.27 M.I.29 NEUN VIERZ+
EHN ZEHN ZWOELF 0 1 1 1 2 2 3 3 4 4
sort 15 c M.I.25 M.I.26 M.I.27 M.I.29 0 1 1 1 2 2 3 3 4 4
sort 8 c M.I.25 M.I.26 M.I.27 M.I.29 0 1 1
sort 1 M.I.29
tstSort */
/*<<tstSortAscii
### start tst tstSortAscii ########################################
sort 29 0 1 1 1 2 2 3 3 4 4 ACHT DREI DREIZEHN EINS ELF FUENF M.I.+
25 M.I.26 M.I.27 M.I.29 NEUN SECHS SIEBEN VIER VIERZEHN ZEHN ZWEI Z+
WOELF c
sort 22 0 1 1 1 2 2 3 3 4 4 ACHT DREIZEHN ELF M.I.25 M.I.26 M.I.27+
. M.I.29 NEUN VIERZEHN ZEHN ZWOELF c
sort 15 0 1 1 1 2 2 3 3 4 4 M.I.25 M.I.26 M.I.27 M.I.29 c
sort 8 0 1 1 M.I.25 M.I.26 M.I.27 M.I.29 c
sort 1 M.I.29
tstSortAscii */
say '### start with comparator' cmp '###'
if errOS() == 'LINUX' then
call tst t, "tstSortAscii"
else
call tst t, "tstSort"
call mAdd mCut(i, 0), eins, zwei, drei, vier, fuenf, sechs,
,sieben, acht, neun, zehn, elf, zwoelf, dreizehn, vierzehn
call mAdd i, 1, 2, 3, 4, 4, 3, 2, 1, 0, 1,
, 'M.I.25', 'M.I.26', 'M.I.27', 'c', 'M.I.29'
do yy = m.i.0 by -1 to 1
do x = 0 to yy
m.i.0 = x
call sort i, o, cmp
m = ''
la = ''
if x <> m.o.0 then
call err 'size mismatch' x '<>' m.o.0
do y=1 to m.o.0
m = m m.o.y
if \ (la << m.o.y) then
call err 'sort mismatch' yy x y '\' la '<<' m.o.y
end
end
if yy // 7 = 1 then
call tstOut t, 'sort' yy m
do x = 2 to yy
x1 = x-1
m.i.x1 = m.i.x
end
end
call tstEnd t
return
endProcedure tstSort
tstMatch: procedure expose m.
/*<<tstMatch
### start tst tstMatch ############################################
match(eins, e?n*) 1 1 2,i,s trans(E?N*) EiNs
match(eins, eins) 1 1 0 trans(EINS) EINS
match(e1nss, e?n*) 1 1 2,1,ss trans(?*) 1ss
match(eiinss, e?n*) 0 0 -9
match(einss, e?n *) 0 0 -9
match(ein s, e?n *) 1 1 2,i,s trans(E?N *) EiN s
match(ein abss , ?i*b*) 1 1 3,e,n a,ss trans(?I*B*) eIn aBss .
match(ein abss wie gehtsssxdirx und auch , ) 0 0 -9
match(ies000, *000) 1 1 1,ies trans(*000) ies000
match(xx0x0000, *000) 1 1 1,xx0x0 trans(*000) xx0x0000
match(000x00000xx, 000*) 1 1 1,x00000xx trans(000*) 000x00000xx
match(000xx, *0*) 1 1 2,00,xx trans(ab*cd*ef) ab00cdxxef
tstMatch */
call tst t, "tstMatch"
call tstOut t, matchTest1('eins', 'e?n*' )
call tstOut t, matchTest1('eins', 'eins' )
call tstOut t, matchTest1('e1nss', 'e?n*', '?*' )
call tstOut t, matchTest1('eiinss', 'e?n*' )
call tstOut t, matchTest1('einss', 'e?n *' )
call tstOut t, matchTest1('ein s', 'e?n *' )
call tstOut t, matchTest1('ein abss ', '?i*b*' )
call tstOut t, matchTest1('ein abss wie gehtsssxdirx und auch ' )
call tstOut t, matchTest1('ies000', '*000' )
call tstOut t, matchTest1('xx0x0000', '*000' )
call tstOut t, matchTest1('000x00000xx', '000*' )
call tstOut t, matchTest1('000xx', '*0*', 'ab*cd*ef' )
call tstEnd t
return
matchTest1:
parse arg w, m, m2
r = 'match('w',' m')' match(w, m) match(w, m, vv) m.vv.0
do x=1 to m.vv.0
r = r','m.vv.x
end
if m2 = '' then
m2 = translate(m)
if m.vv.0 >= 0 then
r = r 'trans('m2')' matchTrans(m2, vv)
return r
endProcedure matchTest1
/* copx tstDiv end **************************************************/
/* copx tstSql begin **************************************************/
tstSqlUtils: procedure expose m.
call sqlConnect 'DBAF'
id = 'A540769.dsnUtils'
rst = 'NO'
retcode = -9876
e = ''
z = 0
st = "TEMPLATE TCOPYD",
"DSN('&SSID..&JO..&US..P&PART(2)..D&DATE(3)..T&TIME.')",
"DATACLAS(NULL12) MGMTCLAS(COM#A011) STORCLAS(FAR$N)",
"SPACE (150,3750) TRK UNCNT 59;",
"listdef abc include tablespace DA540769.A002* partlevel;",
"listdef mf include tablespace MF01A1A.A110A partlevel;",
"copy list abc copyddn(tcopyd) shrlevel change;"
st = translate(st)
call sqlExec "call SYSPROC.DSNUTILS ( :id, :rst,",
":st,:retcode, :ANY" copies(',:e,:e,:z',12) ")"
call sqlExec ,
'ASSOCIATE LOCATOR (:RESULTS) WITH PROCEDURE SYSPROC.DSNUTILS'
say 'results' results
call sqlExec 'ALLOCATE C111 CURSOR FOR RESULT SET :RESULTS'
say 'allocated c111'
do while sqlExec('fetch c111 into :seq, :txt', 0 100) = 0
say 'sysPrint' seq strip(txt, 't')
end
call sqlExec 'close c111'
say 'closed'
call sqlDisconnect
exit
endProcedure tstSqlUtils
tstSqlStored: procedure expose m.
call sqlConnect 'DBAF'
rst = 'NO'
retcode = -9876
e = ''
z = 0
st = "abc"
call sqlExec "call SYSPROC.COMMAND ( :st, :rst)"
say 'after call st='st 'rst='rst
call sqlExec ,
'ASSOCIATE LOCATOR (:RESULTS) WITH PROCEDURE SYSPROC.COMMAND'
say 'results' results
call sqlExec 'ALLOCATE C111 CURSOR FOR RESULT SET :RESULTS'
say 'allocated c111'
do while sqlExec('fetch c111 into :seq, :txt', 0 100) = 0
say 'sysPrint' seq strip(txt, 't')
end
call sqlExec 'close c111'
say 'closed'
call sqlDisconnect
return
endProcedure tstSqlStored
tstSqlStoredWK: procedure expose m.
call sqlConnect 'DBAF'
/* st = "direct wkUtiSub"
rst = 'NO'
say 'before call st='st 'rst='rst
call sqlExec "call A540769.WKUTILSUB ( :st, :rst)"
say 'after call st='st 'rst='rst
*/ rst = 'NO'
retcode = -9876
e = ''
z = 0
prc = 'DB2UTIL.DB2UTIL'
st = "DA540769.A2*" /* DA540769.A1*" */
say "call" prc "("st", ...)"
call sqlExec "call" prc "(:st, :rst)"
say 'after call st='st 'rst='rst
call sqlExec ,
'ASSOCIATE LOCATOR (:RESULTS) WITH PROCEDURE' prc
/* say 'results' results */
call sqlExec 'ALLOCATE C111 CURSOR FOR RESULT SET :RESULTS'
say ''
say '***** utility output'
do while sqlExec('fetch c111 into :seq, :txt', 0 100) = 0
say 'sysPrint' seq strip(txt, 't')
end
call sqlExec 'close c111'
say '***** end output'
call sqlDisconnect
return 0
endProcedure tstSqlStoredWK
tstSqlStoredSQL1: procedure expose m.
call sqlConnect 'DBIA'
rst = 'NO'
retcode = -9876
e = ''
z = 0
st = "DA540769.A2* DA540769.A1*"
call sqlExec "call A540769.WKSQL1 ( :st, :rst)"
say 'after call st='st 'rst='rst
call sqlExec ,
'ASSOCIATE LOCATOR (:RESULTS) WITH PROCEDURE A540769.WKUTIL'
say 'results' results
call sqlExec 'ALLOCATE C111 CURSOR FOR RESULT SET :RESULTS'
say 'allocated c111'
do while sqlExec('fetch c111 into :seq, :txt', 0 100) = 0
say 'sysPrint' seq strip(txt, 't')
end
call sqlExec 'close c111'
say 'closed'
call sqlDisconnect
return
endProcedure tstSqlStoredSQL1
tstSqlTriggerTiming:
parse upper arg tb ni
m.noInsert = ni == 0
cnt = 200000
if tb = '' then
TB = 'GDB9998.TWK511TRI'
call sqlConnect dbaf
say timing() 'noInsert' m.noInsert 'tb' tb
call sql2St 49, '*', cc, 'select max(pri) MX from' tb
if m.cc.1.mx == m.sqlNull then
m.cc.1.mx = 0
von = m.cc.1.mx + 1
bis = m.cc.1.mx + cnt
say m.cc.0 'max' m.cc.1.mx 'von' von 'bis' bis 'count' cnt tb
if right(tb, 2) = 'A1' then do
call sqlPrepare 3, 'insert into' tb '(pri, short, long, par)' ,
'values (?, ?, ?, ?)'
do ax=von to bis
call sqlExecute 3, ax,
, ax 'wsh short', ax 'wsh long long long long long ',
, (ax-1) // 1000 + 1
end
end
else do
call sqlPrepare 3, 'insert into' tb '(pri, short, long)' ,
'values (?, ?, ?)'
do ax=von to bis
call sqlExecute 3, ax,
, ax 'wsh short', ax 'wsh long long long long long ',
, (ax-1) // 1000 + 1
end
end
/* call sqlLn 5,,, 'select * from' tb 'where pri >=' von */
call sqlExImm 'commit'
say timing()
call sqlDisconnect
return
endProcedure tstSqlTriggerTiming
tstSql: procedure expose m.
cx = 2
/*<<tstSql
### start tst tstSql ##############################################
*** err: sqlCode -204 A540769.SYSDUMMY IS AN UNDEFINED NAME .
. e 1: warnings
. e 2: state 42704
. e 3: stmt = execSql prepare s7 from :src
. e 4: with src = select * from sysdummy
fetchA 1 ab= m.abcdef.123.AB abc ef= efg
fetchA 0 ab= m.abcdef.123.AB abc ef= efg
sqlVars :M.STST.A :M.STST.A.SQLIND, :M.STST.B :M.STST.B.SQLIND, +
:M.STST.C :M.STST.C.SQLIND
1 all from dummy1
a=a b=2 c=0
sqlVarsNull 1
a=a b=2 c=---
fetchBT 1 SYSTABLES
fetchBT 0 SYSTABLES
fetchBI 1 SYSINDEXES
fetchBI 0 SYSINDEXES
opAllCl 3
fetchC 1 SYSTABLES
fetchC 2 SYSTABLESPACE
fetchC 3 SYSTABLESPACESTATS
PreAllCl 3
fetchD 1 SYSIBM.SYSTABLES
fetchD 2 SYSIBM.SYSTABLESPACE
fetchD 3 SYSIBM.SYSTABLESPACESTATS
tstSql */
call tst t, "tstSql"
call sqlConnect 'DBAF'
src = 'select * from sysdummy'
call sqlExec 'prepare s7 from :src'
call sqlPrepare cx, "select 'abc' , 'efg'",
'from sysibm.sysDummy1'
call sqlExec 'declare c'cx 'cursor for s'cx
call sqlOpen cx
a = 'abcdef'
b = 123
do i=1 to 2
call jOut 'fetchA' sqlFetchInto(cx, ':m.a.b.ab, :m.a.b.ef') ,
'ab= m.'a'.' || b'.'ab m.a.b.ab 'ef=' m.a.b.ef
end
call sqlClose cx
drop stst a b c m.stst.a m.stst.b m.stst.c
sv = sqlVars('M.STST', A B C , 1)
call jOut 'sqlVars' sv
call jOut sqlPreAllCl(cx,
, "select 'a', 2, case when 1=0 then 1 else null end ",
"from sysibm.sysDummy1",
, stst, sv) 'all from dummy1'
call jOut 'a='m.stst.a 'b='m.stst.b 'c='m.stst.c
call jOut 'sqlVarsNull' sqlVarsNull(stst, A B C)
call jOut 'a='m.stst.a 'b='m.stst.b 'c='m.stst.c
call sqlPreDeclare cx, "select name" ,
"from sysibm.sysTables" ,
"where creator = 'SYSIBM' and name = ?"
call sqlOpen cx, 'SYSTABLES'
call jOut 'fetchBT' sqlFetchInto(cx, ':NM') nm
call jOut 'fetchBT' sqlFetchInto(cx, ':NM') nm
call sqlClose cx
call sqlOpen cx, 'SYSINDEXES'
a = 'a b c'
b = 1234565687687234
call jOut 'fetchBI' sqlFetchInto(cx, ':NM') nm
call jOut 'fetchBI' sqlFetchInto(cx, ':NM') nm
call sqlClose cx
src = "select name" ,
"from sysibm.sysTables" ,
"where creator = 'SYSIBM' and name like 'SYSTABLES%'",
"fetch first 3 rows only"
call sqlPreDeclare cx, src
st = 'wie geht'' s'
call jOut 'opAllCl' sqlOpAllCl(cx, st, ':M.ST.SX.NAME')
do x=1 to m.st.0
call jOut 'fetchC' x m.st.x.name
end
st = 'auch noch'
src = "select strip(creator) || '.' || strip(name)" substr(src,12)
call jOut 'PreAllCl' sqlPreAllCl(cx+11, src, st, ':M.ST.SX.NAME')
do x=1 to m.st.0
call jOut 'fetchD' x m.st.x.name
end
call sqlDisconnect
call tstEnd t
return
endProcedure tstSql
tstSqlO: procedure expose m.
/*<<tstSqlO
### start tst tstSqlO #############################################
*** err: sqlCode -204 A540769.SYSDUMMY IS AN UNDEFINED NAME .
. e 1: warnings
. e 2: state 42704
. e 3: stmt = execSql prepare s7 from :src
. e 4: with src = select * from sysdummy
REQD=Y col=123 case=--- col5=anonym
NAME T DBNAME TSNAME .
SYSTABAUTH T DSNDB06 SYSDBASE .
SYSTABCONST T DSNDB06 SYSOBJ .
SYSTABLEPART T DSNDB06 SYSDBASE .
SYSTABLEPART_HI T DSNDB06 SYSHIST .
SYSTABLES T DSNDB06 SYSDBASE .
NAME T DBNAME TSNAME .
SYSTABAUTH T DSNDB06 SYSDBASE
SYSTABCONST T DSNDB06 SYSOBJ .
SYSTABLEPART T DSNDB06 SYSDBASE
SYSTABLEPART_HIST T DSNDB06 SYSHIST .
SYSTABLES T DSNDB06 SYSDBASE
tstSqlO */
call tst t, "tstSqlO"
call sqlConnect 'DBAF'
src = 'select * from sysdummy'
call sqlExec 'prepare s7 from :src'
call sql2Cursor 13,
, 'select d.*, 123, current timestamp "jetzt und heute",',
'case when 1=0 then 1 else null end caseNull,',
"'anonym'" ,
'from sysibm.sysdummy1 d'
call sqlOpen 13
do while sqlFetch(13, abc)
call jOut 'REQD='m.ABC.IBMREQD 'col='m.ABC.col2,
'case='m.ABC.CASENULL,
'col5='m.ABC.col5
je = 'jetzt'
jetzt = m.ABC.je
dd = date('s')
dd = left(dd, 4)'-'substr(dd, 5, 2)'-'right(dd, 2)'-' ,
|| left(time(), 2)'.'
say 'jetzt='jetzt 'date time' dd
if \ abbrev(jetzt, dd) then
call err 'date mismatch abbrev' dd
end
call sqlClose 13
call sql2Cursor 13 ,
, 'select name, class, dbName, tsName' ,
/* ,alteredTS, obid, cardf'*/ ,
'from sysibm.systables' ,
"where creator = 'SYSIBM' and name like 'SYSTA%'" ,
"fetch first 5 rows only",
, , 'sl<15'
call sqlOpen 13
call jOut fmtFldTitle(m.sql.13.fmt)
do while sqlFetchLn(13, li)
call jOut m.li
end
call sqlClose 13
call sqlGenFmt m.sql.13.fmt, 13, 'sst'
call sqlOpen 13
do ix=1 while sqlFetch(13, fe.ix)
end
m.fe.0 = ix-1
call fmtFldSquash sqFmt, sqlClass(13), fe
call jOut fmtFldTitle(sqFmt)
do ix=1 to m.fe.0
call jOut oFldCat(sqlClass(13), fe.ix, sqFmt)
end
call sqlClose 13
if 0 then do
call sql2Cursor 13 ,
, 'select *',
'from sysibm.systables' ,
"where creator = 'SYSIBM' and name like 'SYSTA%'" ,
"fetch first 1 rows only",
, , 'sl<15'
call sqlOpen 13
call jOut fmtFldTitle(m.sql.13.fmt)
do while sqlFetchLn(13, li)
call jOut m.li
end
call sqlClose 13
end
call sqlDisconnect
call tstEnd t
return
endProcedure tstSqlO
tstSqlEnv: procedure expose m.
/*<<tstSqlEnv
### start tst tstSqlEnv ###########################################
REQD=Y COL2=123 case=--- COL5=anonym
sql fmtFldRw sl<15
NAME T DBNAME TSNAME .
SYSTABAUTH T DSNDB06 SYSDBASE .
SYSTABCONST T DSNDB06 SYSOBJ .
SYSTABLEPART T DSNDB06 SYSDBASE .
SYSTABLEPART_HI T DSNDB06 SYSHIST .
SYSTABLES T DSNDB06 SYSDBASE .
sql fmtFldSquashRW
NAME T DBNAME TSNAME .
SYSTABAUTH T DSNDB06 SYSDBASE
SYSTABCONST T DSNDB06 SYSOBJ .
SYSTABLEPART T DSNDB06 SYSDBASE
SYSTABLEPART_HIST T DSNDB06 SYSHIST .
SYSTABLES T DSNDB06 SYSDBASE
sqlLn sl=
COL1 T DBNAME COL4 .
SYSTABAUTH T DSNDB06 SYSDBASE
SYSTABCONST T DSNDB06 SYSOBJ .
SYSTABLEPART T DSNDB06 SYSDBASE
SYSTABLEPART_ T DSNDB06 SYSHIST .
SYSTABLES T DSNDB06 SYSDBASE
sqlLn ---
NAME T DBNAME TSNAME .
SYSTABAUTH T DSNDB06 SYSDBASE
SYSTABCONST T DSNDB06 SYSOBJ .
SYSTABLEPART T DSNDB06 SYSDBASE
SYSTABLEPART_HIST T DSNDB06 SYSHIST .
SYSTABLES T DSNDB06 SYSDBASE
tstSqlEnv */
call tst t, "tstSqlEnv"
call sqlConnect 'DBAF'
call envBarBegin
call jOut 'select d.*, 123, current timestamp "jetzt und heute",'
call jOut 'case when 1=0 then 1 else null end caseNull,'
call jOut "'anonym'"
call jOut 'from sysibm.sysdummy1 d'
call envBar
call sql 13
call envBarLast
do while envRead(abc)
call jOut 'REQD='envGet('ABC.IBMREQD'),
'COL2='envGet('ABC.COL2'),
'case='envGet('ABC.CASENULL'),
'COL5='envGet('ABC.COL5')
jetzt = envGet('ABC.jetzt')
say 'jetzt='jetzt
dd = date('s')
dd = left(dd, 4)'-'substr(dd, 5, 2)'-'right(dd, 2)'-' ,
|| left(time(), 2)'.'
if \ abbrev(jetzt, dd) then
call err 'date mismatch abbrev' dd
end
call envBarEnd
call jOut 'sql fmtFldRw sl<15'
call envBarBegin
call jOut 'select name, class, dbName, tsName'
/* ,alteredTS, obid, cardf'*/
call jOut 'from sysibm.systables'
call jOut "where creator = 'SYSIBM' and name like 'SYSTA%'"
call jOut "fetch first 5 rows only"
call envBar
call sql 13
call envBarLast
call fmtFldRW sqlGenFmt(fmtAbc, 13, 'sl<15')
call envBarEnd
call jOut 'sql fmtFldSquashRW'
call envBarBegin
call jOut 'select name, class, dbName, tsName'
/* ,alteredTS, obid, cardf'*/
call jOut 'from sysibm.systables'
call jOut "where creator = 'SYSIBM' and name like 'SYSTA%'"
call jOut "fetch first 5 rows only"
call envBar
call sql 13
call envBarLast
call fmtFldSquashRW
call envBarEnd
call jOut 'sqlLn sl='
call envBarBegin
call jOut 'select char(name, 13), class, dbName, char(tsName, 8)'
/* ,alteredTS, obid, cardf'*/
call jOut 'from sysibm.systables'
call jOut "where creator = 'SYSIBM' and name like 'SYSTA%'"
call jOut "fetch first 5 rows only"
call envBarLast
call sqlLn 13, , ,'sl='
call envBarEnd
call jOut 'sqlLn ---'
call envBarBegin
call jOut 'select name, class, dbName, tsName'
/* ,alteredTS, obid, cardf'*/
call jOut 'from sysibm.systables'
call jOut "where creator = 'SYSIBM' and name like 'SYSTA%'"
call jOut "fetch first 5 rows only"
call envBarLast
call sqlLn 13
call envBarEnd
call sqlDisconnect
call tstEnd t
return
endProcedure tstSqlEnv
/* copx tstSql end ***************************************************/
/* copx tstComp begin **************************************************
test the wsh compiler
***********************************************************************/
tstComp: procedure expose m.
call compIni
call tstCompDataConst
call tstCompDataVars
call tstCompShell
call tstCompPrimary
call tstCompStmt
call tstCompDataIO
call tstCompPipe
call tstCompRedir
call tstCompComp
call tstTotal
return
endProcedure tstComp
tstCompRun: procedure expose m.
parse arg class cnt
src = jBuf()
call jOpen src, m.j.cWri
do sx=2 to arg()
call jWrite src, arg(sx)
end
cmp = comp(jClose(src))
call jOut 'compile' class',' (sx-2) 'lines:' arg(2)
r = compile(cmp, class)
say "compiled: >>>>" r "<<<<" m.r.code
call jOut "run without input"
call mCut 'T.IN', 0
call oRun r
if cnt == 3 then do
call jOut "run with 3 inputs"
call mAdd 'T.IN', "eins zwei drei", "zehn elf zwoelf?",
, "zwanzig 21 22 23 24 ... 29|"
m.t.inIx = 0
call oRun r
end
return
endProcedure tstCompRun
tstCompDataConst: procedure expose m.
/*<<tstCompDataConst
### start tst tstCompDataConst ####################################
compile d, 8 lines: Lline one, $** asdf
run without input
. Lline one, .
line two..
line threecontinued on 4
line five fortsetzung
line six fortsetzung
tstCompDataConst */
call tst t, 'tstCompDataConst'
call tstCompRun 'd' ,
, ' Lline one, $** asdf',
, 'line two.',
, 'line three$*+ bla bla' ,
, 'continued on 4',
, 'line five $*( und so',
, 'weiter $abc $? $''$*)'' $"$*)" und weiter $*) fortsetzung',
, 'line six $*( und $*( $** $*( so',
, 'weiter $abc $? $*)'' $"$*)" und weiter $*) fortsetzung'
call tstEnd t
return
endProcedure tstCompDataComm
tstCompDataVars: procedure expose m.
/*<<tstCompDataVars
### start tst tstCompDataVars #####################################
compile d, 4 lines: Lline one, $** asdf
run without input
. Lline one, .
lline zwei output
lline 3 .
variable v1 = valueV1 ${v1}= valueV1| .
tstCompDataVars */
call tst t, 'tstCompDataVars'
call tstCompRun 'd' ,
, ' Lline one, $** asdf',
, ' $$ lline zwei output',
, 'lline 3 $=v1= valueV1 ' ,
, 'variable v1 = $v1 $"${v1}=" ${ v1 }| '
call tstEnd t
return
endProcedure tstCompDataVars
tstCompShell: procedure expose m.
/*<<tstCompShell
### start tst tstCompShell ########################################
compile s, 9 lines: $$ Lline one, $** asdf
run without input
Lline one,
lline zwei output
v1 = valueV1 ${v1}= valueV1|
REXX JOUT L5 CONTINUED L6 CONTINUED L7
L8 ONE
L9 END
tstCompShell */
call tst t, 'tstCompShell'
call tstCompRun 's' ,
, ' $$ Lline one, $** asdf',
, ' $$ lline zwei output',
, ' $=v1= valueV1 ' ,
, '$$ v1 = $v1 $"${v1}=" ${ v1 }| ' ,
, 'call jOut rexx jout l5, ' ,
, ' continued l6 , ' ,
, ' continued l7 ' ,
, 'call jOut l8 one ' ,
, 'call jOut l9 end'
call tstEnd t
return
endProcedure tstCompDataVars
tstCompPrimary: procedure expose m.
/*<<tstCompPrimary
### start tst tstCompPrimary ######################################
compile d, 11 lines: Strings $"$""$""""$""" $'$''$''''$'''
run without input
Strings $"$""$" $'$''$'
rexx 3*5 = 15
data line three line four bis hier
shell line five line six bis hier
var get v1 value Eins, v1 value Eins .
var isDef v1 1, v2 0 .
#jIn eof 1#
var read >1 0 rr undefined
#jIn eof 2#
var read >2 0 rr undefined
run with 3 inputs
Strings $"$""$" $'$''$'
rexx 3*5 = 15
data line three line four bis hier
shell line five line six bis hier
var get v1 value Eins, v1 value Eins .
var isDef v1 1, v2 0 .
#jIn 1# eins zwei drei
var read >1 1 rr eins zwei drei
#jIn 2# zehn elf zwoelf?
var read >2 1 rr zehn elf zwoelf?
tstCompPrimary */
call tst t, 'tstCompPrimary'
call envRemove 'v2'
call tstCompRun 'd' 3 ,
, 'Strings $"$""$""""$"""' "$'$''$''''$'''",
, 'rexx 3*5 = $( 3 * 5 $)',
, 'data $-¢ line three',
, 'line four $! bis hier',
, 'shell $-{ $$ line five',
, '$$ line six $} bis hier',
, '$= v1 = value Eins $=rr=undefined',
, 'var get v1 $v1, v1 ${ v1 } ',
, 'var isDef v1 ${? v$( 1 * 1 + 0 $) }, v2 ${?v2 } ',
, 'var read >1 ${> rr} rr $rr' ,
, 'var read >2 ${> rr} rr $rr'
call tstEnd t
return
endProcedure tstCompPrimary
tstCompStmt: procedure expose m.
/*<<tstCompStmt1
### start tst tstCompStmt1 ########################################
compile s, 8 lines: $= v1 = value eins $= v2 % 3*5*7 .
run without input
data v1 value eins v2 105
eins
zwei
drei
vier
fuenf
elf
zwoelf dreiZ .
vierZ .
fuenfZ
lang v1 value eins v2 945
oRun ouput 1
tstCompStmt1 */
call tst t, 'tstCompStmt1'
call envPut 'oRun', oRunner('call jOut "oRun ouput" (1*1)')
call envRemove 'v2'
call tstCompRun 's' ,
, '$= v1 = value eins $= v2 % 3*5*7 ',
, '$$ data v1 $v1 v2 ${ v2 }',
, '$$eins $@{$$ zwei $$ drei ',
, ' $@{ $} $@{ $@{ $$vier $} $} $} $$fuenf',
, '$$elf $@¢ zwoelf dreiZ ',
, ' $@¢ $! $@¢ $@¢ vierZ $! $! $! $$fuenfZ',
, '$% "lang v1" $v1 "v2" ${v2}*9',
, '$@run $oRun'
call tstEnd t
/*<<tstCompStmt2
### start tst tstCompStmt2 ########################################
compile s, 1 lines: $@for qq $$ loop qq $qq
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
loop qq eins zwei drei
#jIn 2# zehn elf zwoelf?
loop qq zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
loop qq zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
tstCompStmt2 */
call tst t, 'tstCompStmt2'
call tstCompRun 's' 3 ,
, '$@for qq $$ loop qq $qq'
call tstEnd t
return
endProcedure tstCompStmt
tstCompDataIO: procedure expose m.
/*<<tstCompDataHereData
### start tst tstCompDataHereData #################################
compile d, 13 lines: herdata $<<stop .
run without input
. herdata .
heredata 1 $x
heredata 2 $y
nach heredata
. herdata ¢ .
heredata 1 xValue
heredata 2 yValueY
nach heredata ¢
. herdata { .
HEREDATA 1 xValue
heredata 2 yValueY
nach heredata {
tstCompDataHereData */
call tst t, 'tstCompDataHereData'
call tstCompRun 'd' ,
, ' herdata $<<stop ',
, 'heredata 1 $x',
, 'heredata 2 $y',
, 'stop $$ nach heredata',
, ' herdata ¢ $<<¢stop ',
, '$=x=xValue$=y=yValueY',
, 'heredata 1 $x',
, 'heredata 2 $y',
, 'stop $$ nach heredata ¢',
, ' herdata { $<<{st',
, 'call jOut heredata 1 $x',
, '$$heredata 2 $y',
, 'st $$ nach heredata {'
call tstEnd t
/*<<tstCompDataIO
### start tst tstCompDataIO #######################################
compile d, 5 lines: input 1 $<$dsn $*+.
run without input
. input 1 .
readInp line 1 .
readInp line 2 .
. nach dsn input und nochmals mit & .
readInp line 1 .
readInp line 2 .
. und schluiss..
tstCompDataIO */
dsn = word(tstPdsMbr(tstFilename('lib37', 'r'), 'readInp'), 1)
dsnFB = dsn tstFB('::F37', 0)
b = jBuf(tstFB('readInp line 1', 37),
,tstFB('readInp line 2', 37))
extFd = tstFB('&dsn('dsn') dd(xyz)', 0)
extFd = tstFB(dsn 'dd(xyz) ::f', 0)
if extFd = '' then
extFd = dsn
call jCat file(dsnFB), b
call envPut 'dsn', dsn
call tst t, 'tstCompDataIO'
call tstCompRun 'd' ,
, ' input 1 $<$dsn $*+',
, tstFB('::f', 0),
, ' nach dsn input und nochmals mit & ' ,
, ' $<'extFD,
, ' und schluiss.'
call tstEnd t
return
endProcedure tstCompDataIO
tstCompPipe: procedure expose m.
/*<<tstCompPipe1
### start tst tstCompPipe1 ########################################
compile s, 1 lines: call envPreSuf "(1 ", " 1)"
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
(1 eins zwei drei 1)
#jIn 2# zehn elf zwoelf?
(1 zehn elf zwoelf? 1)
#jIn 3# zwanzig 21 22 23 24 ... 29|
(1 zwanzig 21 22 23 24 ... 29| 1)
#jIn eof 4#
tstCompPipe1 */
call tst t, 'tstCompPipe1'
call tstCompRun 's' 3 ,
, ' call envPreSuf "(1 ", " 1)"'
call tstEnd t
/*<<tstCompPipe2
### start tst tstCompPipe2 ########################################
compile s, 2 lines: call envPreSuf "(1 ", " 1)"
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
#jIn 2# zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
¢2 (1 eins zwei drei 1) 2!
¢2 (1 zehn elf zwoelf? 1) 2!
¢2 (1 zwanzig 21 22 23 24 ... 29| 1) 2!
tstCompPipe2 */
call tst t, 'tstCompPipe2'
call tstCompRun 's' 3 ,
, ' call envPreSuf "(1 ", " 1)"' ,
, ' $| call envPreSuf "¢2 ", " 2!"'
call tstEnd t
/*<<tstCompPipe3
### start tst tstCompPipe3 ########################################
compile s, 3 lines: call envPreSuf "(1 ", " 1)"
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
#jIn 2# zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
<3 ¢2 (1 eins zwei drei 1) 2! 3>
<3 ¢2 (1 zehn elf zwoelf? 1) 2! 3>
<3 ¢2 (1 zwanzig 21 22 23 24 ... 29| 1) 2! 3>
tstCompPipe3 */
call tst t, 'tstCompPipe3'
call tstCompRun 's' 3 ,
, ' call envPreSuf "(1 ", " 1)"' ,
, ' $| call envPreSuf "¢2 ", " 2!"',
, ' $| call envPreSuf "<3 ", " 3>"'
call tstEnd t
/*<<tstCompPipe4
### start tst tstCompPipe4 ########################################
compile s, 7 lines: call envPreSuf "(1 ", " 1)"
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
#jIn 2# zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
<3 ¢222 ¢221 ¢21 ¢20 (1 eins zwei drei 1) 20! 21! 221! 222! 3>
<3 ¢222 ¢221 ¢21 ¢20 (1 zehn elf zwoelf? 1) 20! 21! 221! 222! 3>
<3 ¢222 ¢221 ¢21 ¢20 (1 zwanzig 21 22 23 24 ... 29| 1) 20! 21! 221!+
. 222! 3>
tstCompPipe4 */
call tst t, 'tstCompPipe4'
call tstCompRun 's' 3 ,
, ' call envPreSuf "(1 ", " 1)"' ,
, ' $| $@{ call envPreSuf "¢20 ", " 20!"',
, ' $| call envPreSuf "¢21 ", " 21!"',
, ' $| $@{ call envPreSuf "¢221 ", " 221!"',
, ' $| call envPreSuf "¢222 ", " 222!"',
, '$} $} ',
, ' $| call envPreSuf "<3 ", " 3>"'
call tstEnd t
return
endProcedure tstCompPipe
tstCompRedir: procedure expose m.
/*<<tstCompRedir
### start tst tstCompRedir ########################################
compile s, 6 lines: $>#eins $@for vv $$<$vv> $; .
run without input
#jIn eof 1#
output eins .
output piped zwei .
run with 3 inputs
#jIn 1# eins zwei drei
#jIn 2# zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
output eins <eins zwei drei> <zehn elf zwoelf?> <zwanzig 21 22 23 2+
4 ... 29|>
output piped zwei ab<eins zwei drei>yz ab<zehn elf zwoelf?>yz ab<zw+
anzig 21 22 23 24 ... 29|>yz
tstCompRedir */
call tst t, 'tstCompRedir'
dsn = word(tstPdsMbr(tstFilename('libvb', 'r'), 'redir1'), 1)
call envPut 'dsn', dsn
call tstCompRun 's' 3 ,
, ' $>#eins $@for vv $$<$vv> $; ',
, ' $$ output eins $-{$<#eins$}$; ',
, ' $@for ww $$b${ww}y ',
, ' $> $dsn 'tstFB('::v', 0),
, '$| call envPreSuf "a", "z" $<# eins',
, '$;$$ output piped zwei $-{$<$dsn$} '
call tstEnd t
return
endProcedure tstCompRedir
tstCompComp: procedure expose m.
/*<<tstCompCompShell
### start tst tstCompCompShell ####################################
compile s, 5 lines: $$compiling shell $; $= rrr = $-cmpShell $<<aaa
run without input
compiling shell
running einmal
RUN 1 COMPILED einmal
#jIn eof 1#
running zweimal
RUN 1 COMPILED zweimal
#jIn eof 2#
run with 3 inputs
compiling shell
running einmal
RUN 1 COMPILED einmal
#jIn 1# eins zwei drei
compRun eins zwei dreieinmal
#jIn 2# zehn elf zwoelf?
compRun zehn elf zwoelf?einmal
#jIn 3# zwanzig 21 22 23 24 ... 29|
compRun zwanzig 21 22 23 24 ... 29|einmal
#jIn eof 4#
running zweimal
RUN 1 COMPILED zweimal
#jIn eof 5#
tstCompCompShell */
call tst t, 'tstCompCompShell'
call tstCompRun 's' 3 ,
, "$$compiling shell $; $= rrr = $-cmpShell $<<aaa",
, "call jOut run 1*1*1 compiled $cc; $@for v $$ compRun $v$cc",
, "aaa $;",
, "$=cc=einmal $$ running $cc $@run $rrr",
, "$=cc=zweimal $$ running $cc $@run $rrr"
call tstEnd t
/*<<tstCompCompData
### start tst tstCompCompData #####################################
compile s, 5 lines: $$compiling data $; $= rrr = $-cmpData $<<aaa
run without input
compiling data
running einmal
call jOut run 1*1*1 compiled einmal
running zweimal
call jOut run 1*1*1 compiled zweimal
run with 3 inputs
compiling data
running einmal
call jOut run 1*1*1 compiled einmal
running zweimal
call jOut run 1*1*1 compiled zweimal
tstCompCompData */
call tst t, 'tstCompCompData'
call tstCompRun 's' 3 ,
, "$$compiling data $; $= rrr = $-cmpData $<<aaa",
, "call jOut run 1*1*1 compiled $cc",
, "aaa $;",
, "$=cc=einmal $$ running $cc $@run $rrr",
, "$=cc=zweimal $$ running $cc $@run $rrr"
call tstEnd t
return
endProcedure tstCompComp
/* copx tstComp end *************************************************/
/* copx tstBase begin **************************************************
test the basic classes
***********************************************************************/
tstBase: procedure expose m.
call tstTstSay
call oIni
call tstM
call tstMap
call tstMapVia
call tstClass
call tstClass2
call tstO
call jIni
call tstJSay
call tstJ
call tstJ2
call catIni
call tstCat
call envIni
CALL TstEnv
CALL TstEnvCat
call tstEnvBar
call tstEnvVars
call tstTotal
call tstEnvLazy
call tstEnvClass
call tstFile /* reimplent zOs ||| */
call tstFileList
call tstFmt
call tstTotal
call scanIni
call tstScan
call ScanReadIni
call tstScanRead
call tstScanWin
call tstScanSQL
call tstTotal
return
endProcedure tstBase
/*--- test the tst Module, check the output visually ----------------*/
tstTstSay: procedure expose m.
call tstIni
oldErr = m.tst.err
oldNames = m.tst.errNames
say '+++ tstTstSay start with' oldErr 'totErrs and',
m.tst.tests 'tests'
/*<<tstTstSayEins
### start tst tstTstSayEins #######################################
test eins einzige testZeile
tstTstSayEins */
call tst x, 'tstTstSayEins'
call tstOut x, "test eins einzige testZeile"
call tstEnd x
if m.x.err <> 0 then
call err '+++ tstTstSay errs' m.x.err 'expected' 0
/*<<tstTstSayZwei
### start tst tstTstSayZwei #######################################
zwei 1. testZeile
zwei 2. und letzte testZeile
tstTstSayZwei */
call tst x, 'tstTstSayZwei'
call tstOut x, "zwei 1. testZeile"
call tstOut x, "zwei 2. und letzte testZeile"
call tstEnd x
if m.x.err <> 0 then
call err '+++ tstTstSay errs' m.x.err 'expected' 0
call tst x, 'tstTstSayZwei'
call tstOut x, "zwei 1. testZeile " /* ein space zuviel */
call tstOut x, "zwei 2. und letzte testZeile"
call tstOut x, "zwei 3. zuviel"
call tstEnd x
if m.x.err <> 3 then
call err '+++ tstTstSay errs' m.x.err 'expected' 3
/*<<tstTstSayDrei
### start tst tstTstSayDrei #######################################
drei 1. testZeile vor empty Zeile
..
drei 3. testZeile vor 10 space
. .
drei 5. testZeile ziemlich lang 66 +
. 77 5 10 15++++++++++++++++++++
.+++++++++++++++++++++++++++++++++++++++++++.
tstTstSayDrei */
call tst y, 'tstTstSayDrei'
call tstOut y, 'drei 1. testZeile vor empty Zeile'
call tstOut y, ''
call tstOut y, 'drei 3. testZeile vor 10 space'
call tstOut y, left('', 10)
call tstOut y, 'drei 5. testZeile ziemlich lang',
left(66, 66) left('77 5 10 15', 77, '+')
call tstEnd y
if m.y.err <> 0 then
call err '+++ tstTstSay errs' m.x.err 'expected' 0
if m.tst.err <> oldErr + 3 then
call err '+++ tstTstSay totErrs' m.tst.err 'expected' 3
say '+++ tstTstSay end Ok with' m.tst.err 'totErrs and' ,
m.tst.tests 'tests'
m.tst.err = oldErr
m.tst.errNames = oldNames
return
endProcedure tstTstSay
tstM: procedure expose m.
/*<<tstM
### start tst tstM ################################################
symbol m.b LIT
mInc b 2 m.b 2
symbol m.a LIT
mAdd a A.2
mAdd a A.3
m.a: 3: 1=eins 2=zwei 3=drei 4=M.A.4
m.c: 5: 1=c vorAddSt a 2=eins 3=zwei 4=drei 5=c nacAddSt a 6=M.C.6
tstMSubj1 tstMSubj1 added listener 1
tstMSubj1 notified list1 1 arg tstMSubj1 registered list
tstMSubj1 notified list1 1 arg tstMSubj1 notify 11
tstMSubj1 tstMSubj1 added listener 2
tstMSubj1 notified list2 2 arg tstMSubj1 registered list
tstMSubj1 notified list1 1 arg tstMSubj1 notify 12
tstMSubj1 notified list2 2 arg tstMSubj1 notify 12
tstMSubj2 tstMSubj2 added listener 1
tstMSubj2 notified list1 1 arg tstMSubj2 registered list
tstMSubj2 tstMSubj2 added listener 2
tstMSubj2 notified list2 2 arg tstMSubj2 registered list
tstMSubj1 notified list1 1 arg tstMSubj1 notify 13
tstMSubj1 notified list2 2 arg tstMSubj1 notify 13
tstMSubj2 notified list1 1 arg tstMSubj2 notify 24
tstMSubj2 notified list2 2 arg tstMSubj2 notify 24
tstM */
drop m.b m.a m.a.0 m.a.1 m.a.2
call tst t, 'tstM'
call tstOut t, 'symbol m.b' symbol('m.b')
m.b = 1
call tstOut t, 'mInc b' mInc(b) 'm.b' m.b
call tstOut t, 'symbol m.a' symbol('m.a')
call tstOut t, 'mAdd a' mAdd(mCut(a, 0), 'eins', 'zwei')
call tstOut t, 'mAdd a' mAdd(a, 'drei')
call tstOut t, 'm.a:' m.a.0': 1='m.a.1 '2='m.a.2 '3='m.a.3 '4='m.a.4
call mAdd mCut(c, 0), 'c vorAddSt a'
call mAddSt c, a
call mAdd c, 'c nacAddSt a'
call tstOut t, 'm.c:' m.c.0': 1='m.c.1 '2='m.c.2 '3='m.c.3,
'4='m.c.4 '5='m.c.5 '6='m.c.6
s1 = 'tstMSubj1'
s2 = 'tstMSubj2'
/* we must unregister for the second test */
drop m.m.subLis.s1 m.m.subLis.s1.0 m.m.subLis.s2 m.m.subLis.s2.0
call mRegisterSubject s1,
, 'call tstOut t, "'s1'" subject "added listener" listener;',
'call mNotify1 "'s1'", listener, "'s1' registered list"'
call mRegister s1,
, 'call tstOut t, subject "notified list1" listener "arg" arg'
call mNotify s1, s1 'notify 11'
call mRegister s1,
, 'call tstOut t, subject "notified list2" listener "arg" arg'
call mRegister s2,
, 'call tstOut t, subject "notified list1" listener "arg" arg'
call mRegister s2,
, 'call tstOut t, subject "notified list2" listener "arg" arg'
call mNotify s1, s1 'notify 12'
call mRegisterSubject s2,
, 'call tstOut t, "'s2'" subject "added listener" listener;',
'call mNotify1 "'s2'", listener, "'s2' registered list"'
call mNotify s1, s1 'notify 13'
call mNotify s2, s2 'notify 24'
call tstEnd t
return
endProcedure tstM
tstMap: procedure expose m.
/*<<tstMap
### start tst tstMap ##############################################
mapNew m keys m-keys 0
map m zwei --> 2
map m Zwei is not defined
map stem m-keys 4
map m eins --> 1
map m zwei --> 2
map m drei --> 3
map m vier --> 4
*** err: duplicate key eins in map m
map m zwei is not defined
q 2 zw dr
map stem Q 2
map Q zw --> 2Q
map Q dr --> 3Q
map stem m 3
map m eins --> 1
map m zwei --> 2PUT
map m vier --> 4PUT
*** err: duplicate key zwei in map m
tstMapLong eins keys 3
tstMapLong zweiMal keys 48
tstMapLong dreiMal keys 93
tstMapLong vier keys 138
tstMapLong <fuenf> keys 188
tstMap clear keys 0
inline1 3
inline1 1 == inline1 eins==
inline1 2 ====
inline1 3 == inline1 drei==
inline2 1 1 == inline2 eins==
inline3 nicht gefunden
tstMap */
/*<<tstMapInline1
inline1 eins
inline1 drei
tstMapInline1 */
/*<<tstMapInline2
inline2 eins
tstMapInline2 */
call tst t, 'tstMap'
m = mapNew('K')
ky = mapKeys(m)
call mAdd t'.TRANS', m 'm', ky 'm-keys'
call tstOut t, 'mapNew' m 'keys' ky m.ky.0
call mapAdd m, 'eins', 1
call mapAdd m, 'zwei', 2
call mapAdd m, 'drei', 3
call mapAdd m, 'vier', 4
call tstMapShow m, 'zwei'
call tstMapShow m, 'Zwei'
call tstMapShowSt m, mapKeys(m)
call mapAdd m, 'eins', 1
call mapReset m, '='
call tstMapShow m, 'zwei'
call mapAdd m, 'eins', 1
call mapAdd m, 'zwei', 2
call mapPut m, 'zwei', 2Put
call mapPut m, 'vier', 4Put
call mapReset q, '='
call mapAdd q, 'zw', 2q
call mapAdd q, 'dr', 3q
call tstOut t, 'q' m.q.0 m.q.1 m.q.2
call tstMapShowSt q, mapKeys(q)
call tstMapShowSt m, mapKeys(m)
call mapAdd m, 'zwei', 2addDup
call tstMapLong m, 'eins' ,201, 2000, -2, 2
call tstMapLong m, 'zweiMal' ,201, 2000, -2, 2
call tstMapLong m, 'dreiMal' ,201, 2000, 2,-2
call tstMapLong m, 'vier ' ,2010, 201, -2, 2
call tstMapLong m, '<fuenf>' ,2010, 201, 2,-2
call mapClear m
keys = mapKeys(m)
call tstOut t, 'tstMap clear keys' m.keys.0
i = mapInline('tstMapInline1')
call tstOut t, 'inline1' m.i.0
do x=1 to m.i.0
call tstOut t, 'inline1' x '=='m.i.x'=='
end
i = mapInline('tstMapInline2')
call tstOut t, 'inline2' m.i.0 '1 =='m.i.1'=='
call tstOut t, 'inline3' mapInline('tstMapInline3', 'nicht gefunden')
call tstEnd t
return
endProcedure tstMap
tstMapLong: procedure expose m.
parse arg m, w, f1, t1, f2, t2
if f1 < t1 then
b1 = 201
else
b1 = -201
if f2 < t2 then
b2 = 1
else
b2 = -1
lo = copies(w, 2100 % length(w))
keys = mapKeys(m)
keyCn = m.keys.0
call tstOut t, 'tstMapLong' w 'keys' keyCn
do x = f1 by b1 to t1
do y = x+f2 by b2 to x+t2
k = left(lo, y)
if mapHasKey(m, k) then
call err 'mapLong hasKey before' w y
call mapAdd m, k, w y
if \ mapHasKey(m, k) then
call err 'mapLong \ hasKey after' w y
if mapGet(m, k) \== w y then
call err 'mapLong \ get <> ' w y
keys = mapKeys(m)
if keyCn + 1 \= m.keys.0 then
call err 'mapLong keys .0 <> ' w y
keyCn = m.keys.0
if k \== m.keys.keyCn then
call err 'mapLong keys . ' keyCn '<>' w y
end
end
return
endProcedure tstMapLong
tstMapVia: procedure expose m.
/*<<tstMapVia
### start tst tstMapVia ###########################################
map M K --> A
mapVia(m, K) A
*** err: missing m.A at 3 in mapVia(M, K*)
mapVia(m, K*) M.A
mapVia(m, K*) valAt m.a
mapVia(m, K*) valAt m.a
*** err: missing m.A.aB at 5 in mapVia(M, K*aB)
mapVia(m, K*aB) M.A.aB
mapVia(m, K*aB) valAt m.A.aB
*** err: missing m.valAt m.a at 4 in mapVia(M, K**)
mapVia(m, K**) M.valAt m.a
mapVia(m, K**) valAt m.valAt m.a
mapVia(m, K**F) valAt m.valAt m.a.F
tstMapVia */
call tst t, 'tstMapVia'
u = 'A.aB'
v = 'valAt m.a'
drop m.a m.u m.v m.v.f
call mapReset m, 'K'
call mapAdd m, k, a
call tstMapShow m, k
call tstOut t, 'mapVia(m, K) ' mapVia(m, 'K')
call tstOut t, 'mapVia(m, K*) ' mapVia(m, 'K*')
m.a = v
call tstOut t, 'mapVia(m, K*) ' mapVia(m, 'K*')
call tstOut t, 'mapVia(m, K*) ' mapVia(m, 'K*')
call tstOut t, 'mapVia(m, K*aB) ' mapVia(m, 'K*aB')
m.u = 'valAt m.'u
call tstOut t, 'mapVia(m, K*aB) ' mapVia(m, 'K*aB')
call tstOut t, 'mapVia(m, K**) ' mapVia(m, 'K**')
v = m.a
m.v = 'valAt m.'v
m.v.f = 'valAt m.'v'.F'
call tstOut t, 'mapVia(m, K**) ' mapVia(m, 'K**')
call tstOut t, 'mapVia(m, K**F) ' mapVia(m, 'K**F')
call tstEnd t
return
endProcedure tstMapVia
tstMapShow: procedure expose m.
parse arg a, key
if mapHasKey(a, key) then
call tstOut t, 'map' a key '-->' mapGet(a, key)
else
call tstOut t, 'map' a key 'is not defined'
return
endProcedure tstMapShow
tstMapShowSt: procedure expose m.
parse arg a, st
call tstOut t, 'map stem' st m.st.0
do wx=1 to m.st.0
call tstMapShow a, m.st.wx
end
return
endProcedure tstMapShow
tstClass2: procedure expose m.
/*<<tstClass2
### start tst tstClass2 ###########################################
@CLASS.4 isA :class union
. choice n union
. .NAME = class
. .CLASS refTo @CLASS.3 :class union
. choice u stem 8
. .1 refTo @CLASS.11 :class union
. choice c union
. .NAME = v
. .CLASS refTo @CLASS.1 :class union
. choice v = v
. .2 refTo @CLASS.12 :class union
. choice c union
. .NAME = r
. .CLASS refTo @CLASS.7 :class union
. choice f union
. .NAME = CLASS
. .CLASS refTo @CLASS.6 :class union
. choice r .CLASS refTo @CLASS.4 done :class @CLASS.4
. .3 refTo @CLASS.13 :class union
. choice c union
. .NAME = s
. .CLASS refTo @CLASS.7 done :class @CLASS.7
. .4 refTo @CLASS.15 :class union
. choice c union
. .NAME = u
. .CLASS refTo @CLASS.14 :class union
. choice s .CLASS refTo @CLASS.6 done :class @CLASS.6
. .5 refTo @CLASS.16 :class union
. choice c union
. .NAME = f
. .CLASS refTo @CLASS.8 :class union
. choice u stem 2
. .1 refTo @CLASS.5 :class union
. choice f union
. .NAME = NAME
. .CLASS refTo @CLASS.1 done :class @CLASS.1
. .2 refTo @CLASS.7 done :class @CLASS.7
. .6 refTo @CLASS.17 :class union
. choice c union
. .NAME = n
. .CLASS refTo @CLASS.8 done :class @CLASS.8
. .7 refTo @CLASS.18 :class union
. choice c union
. .NAME = c
. .CLASS refTo @CLASS.8 done :class @CLASS.8
. .8 refTo @CLASS.19 :class union
. choice c union
. .NAME = m
. .CLASS refTo @CLASS.10 :class union
. choice u stem 2
. .1 refTo @CLASS.5 done :class @CLASS.5
. .2 refTo @CLASS.9 :class union
. choice f union
. .NAME = MET
. .CLASS refTo @CLASS.1 done :class @CLASS.1
tstClass2 */
call tst t, 'tstClass2'
call classOut , m.class.class
call tstEnd t
/* call out 'nach pop' *** ???wktest */
return
endProcedure tstClass2
tstClass: procedure expose m.
/*<<tstClass
### start tst tstClass ############################################
Q n =className= tstClassTf12
Q.eins.zwei v ==> M.Q.eins.zwei
*** err: basicClass v end of Exp expected: v tstClassTf12 .
R n =className= uststClassTf12
R n =className= uststClassTf12in
R n =className= tstClassTf12
R.eins.zwei v ==> M.R.eins.zwei
R s =stem.0= 2
R.1 r ==> M.R.1
R.1 n =className= tstClassTf12
R.1.eins.zwei v ==> M.R.1.eins.zwei
R.2 r ==> M.R.2
R.2 n =className= tstClassTf12
R.2.eins.zwei v ==> M.R.2.eins.zwei
S s =stem.0= 2
S.1.eins v ==> M.S.1.eins
S.1 m =met-metA--> say "metA"
S.1 m =met-metB--> say "metB"
S.2.zwei v ==> M.S.2.zwei
S.2 m =met-metA--> say "metA"
S.2 m =met-metB--> say "metB"
class of mutate qq tstClassTf12
tstClass */
f = 'eins.zwei'
e = 'eins'
z = 'zwei'
drop m.q.f m.r.f m.r.0 m.r.1 m.r.1.f m.r.2 m.r.2.f
drop m.s.0 m.s.1 m.s.1.e m.s.2 m.s.2.z
call classIni
call tst t, 'tstClass'
t1 = classNew('n tstClassTf12 f eins f zwei v')
call tstClassOut t, t1, q
z = m.class.0
errDef = 'n tstClassB n tstClassC u tstClassTf12, s u v tstClassTf12'
if class4name(errDef, ' ') == ' ' then
t2 = classNew(errDef)
else /* the second time we do not get the error anymore,
because the err did not abend | */
call tstOut t,
,'*** err: basicClass v end of Exp expected: v tstClassTf12 '
t2 = classNew('n uststClassTf12 n uststClassTf12in u tstClassTf12',
, classNew('s u r, tstClassTf12'))
m.r.0 = 2
call tstClassOut t, t2, r
t3 = classNew('s u c 1 f eins v, c 2 f zwei v',
,'m', 'metA say "metA"', 'metB say "metB"')
m.s.0 = 2
m.s.1 = 1
m.s.2 = 2
call tstClassOut t, t3, s
call oMutate qq, 'tstClassTf12'
tt = objClass(qq)
call tstOut t, 'class of mutate qq' m.tt.name
call tstEnd t
return
endProcedure tstClass
tstClassOut: procedure expose m.
parse arg o, t, a
if pos(m.t, 'vr') > 0 then
return tstOut(o, a m.t '==>' m.a)
if m.t == 'n' then do
call tstOut o, a m.t '=className=' m.t.name
return tstClassOut(o, m.t.class, a)
end
if m.t == 'f' then
return tstClassOut(o, m.t.class, a'.'m.t.name)
if m.t = 'u' then do
do ux=1 to m.t.0
call tstClassOut o, m.t.ux, a
end
return 0
end
if m.t = 's' then do
call tstOut o, a m.t '=stem.0=' m.a.0
do ux=1 to m.a.0
call tstClassOut o, m.t.class, a'.'ux
end
return 0
end
if m.t = 'c' then do
if m.t.name = m.a then
call tstClassOut o, m.t.class, a
return 0
end
if m.t = 'm' then
return tstOut(o, a m.t '=met-'m.t.name'-->' m.t.met)
call err 'bad class type' m.t 1/0
endProcedure tstClassOut
tstO: procedure expose m.
/*<<tstO
### start tst tstO ################################################
class method calls of TstOEins
. met Eins.eins M
FLDS of <obj e of TstOEins> .FEINS, .FZWEI
methodcalls of object e of TstOEins
. met Eins.eins <obj e of TstOEins>
. met Eins.zwei <obj e2 of TstOEins>
*** err: no method nein in class TstOEins of object <obj e+
. of TstOEins>
*** err: no class found for object noObj
class method calls of TstOEins
. met Elf.zwei M
FLDS of <obj f of TstOElf> .FEINS, .FZWEI, .FELF
methodcalls of object f of TstOElf
. met Eins.eins <obj f of TstOElf>
. met Elf.zwei <obj f of TstOElf>
. met Elf.drei <obj f of TstOElf>
methodcalls of object f cast To TstOEins
. met Eins.eins <obj f of TstOElf>
. met Eins.zwei <obj f of TstOElf>
FLDS of <cast(f, TstOEins)> .FEINS, .FZWEI
oCopy c1 of class TstOEins, c2
C1 n =className= TstOEins
C1.FEINS v ==> M.C1.FEINS
C1.FZWEI v ==> M.C1.FZWEI
C1 m =met-eins--> call tstOut t, " met Eins.eins" m
C1 m =met-zwei--> call tstOut t, " met Eins.zwei" m
C2 n =className= TstOEins
C2.FEINS v ==> M.C1.FEINS
C2.FZWEI v ==> M.C1.FZWEI
C2 m =met-eins--> call tstOut t, " met Eins.eins" m
C2 m =met-zwei--> call tstOut t, " met Eins.zwei" m
oCopy c3 of class TstOElf, c4
C4 n =className= TstOElf
C4 n =className= TstOEins
C4.FEINS v ==> M.C3.FEINS
C4.FZWEI v ==> M.C3.FZWEI
C4 m =met-eins--> call tstOut t, " met Eins.eins" m
C4 m =met-zwei--> call tstOut t, " met Eins.zwei" m
C4.FELF r ==> M.C3.FELF
C4 m =met-zwei--> call tstOut t, " met Elf.zwei" m
C4 m =met-drei--> call tstOut t, " met Elf.drei" m
tEinsDop <class TstOEins>
oRun 7*3 21
oRun 12*12 144
tstO */
call tst t, 'tstO'
tEins = classNew('n TstOEins u f FEINS v,f FZWEI v', 'm',
, 'eins call tstOut t, " met Eins.eins" m',
, 'zwei call tstOut t, " met Eins.zwei" m')
call mAdd t.trans, tEins '<class TstOEins>'
call tstOut t, 'class method calls of TstOEins'
interpret classMet('TstOEins', 'eins')
e = oNew('TstOEins')
e2 = oNew('TstOEins')
call mAdd t.trans, e '<obj e of TstOEins>'
call mAdd t.trans, e2 '<obj e2 of TstOEins>'
tEins = classNew('n TstOEins u f FEINS v,f FZWEI v', 'm',
, 'eins call tstOut t, " met Eins.eins" m',
, 'zwei call tstOut t, " met Eins.zwei" m')
call tstOut t, 'FLDS of' e mCat(oFlds(e), ', ')
call tstOut t, 'methodcalls of object e of TstOEins'
call tstOmet e, 'eins'
call tstOmet e2, 'zwei'
call tstOmet e, 'nein'
call tstOmet 'noObj', 'nein'
tElf = classNew('n TstOElf u TstOEins, f FELF r', 'm',
, 'zwei call tstOut t, " met Elf.zwei" m',
, 'drei call tstOut t, " met Elf.drei" m')
call tstOut t, 'class method calls of TstOEins'
interpret classMet('TstOElf', 'zwei')
f = oNew('TstOElf')
call mAdd t.trans, f '<obj f of TstOElf>'
call tstOut t, 'FLDS of' f mCat(oFlds(f), ', ')
call tstOut t, 'methodcalls of object f of TstOElf'
call tstOmet f, 'eins'
call tstOmet f, 'zwei'
call tstOmet f, 'drei'
call tstOut t, 'methodcalls of object f cast To TstOEins'
call tstOmet oCast(f, 'TstOEins'), 'eins'
call tstOmet oCast(f, 'TstOEins'), 'zwei'
call tstOut t, 'FLDS of <cast(f, TstOEins)>',
mCat(oFlds(oCast(f, 'TstOEins')), ', ')
call oMutate c1, 'TstOEins'
call tstOut t, 'oCopy c1 of class TstOEins, c2'
call tstClassOut t, tEins, c1
call oCopy c1, c2
call tstClassOut t, tEins, c2
call tstOut t, 'oCopy c3 of class TstOElf, c4'
call oMutate c3, 'TstOElf'
call oCopy c3, c4
call tstClassOut t, tElf, c4
tEinsDop = classNew('n TstOEins u f FEINS v,f FZWEI v', 'm',
, 'eins call tstOut t, " met Eins.eins" m',
, 'zwei call tstOut t, " met Eins.zwei" m')
call tstOut t, 'tEinsDop' tEinsDop
e3 = oNew('TstOEins')
if e3 <<= e | e3 <<= e2 then
call err 'doppelt reinitialised objects'
rr = oRunner('return 7 * 3')
call tstOut t, 'oRun 7*3' oRun(rr)
r12 = oRunner('return 12 * 12')
call tstOut t, 'oRun 12*12' oRun(r12)
call tstEnd t
return
endProcedure tstO
tstOmet: procedure expose m.
parse arg m, met
interpret objMet(m, met)
return
endProcedure tstOmet
tstJSay: procedure expose m.
/*<<tstJSay
### start tst tstJSay #############################################
*** err: call of abstract method jOpen(<obj j of JRW>, openArg)
*** err: jWrite(<obj j of JRW>, writeArg) but not opened w
*** err: can only write JRWSay.jOpen(<obj s of JRWSay>, open<Arg)
*** err: jWrite(<obj s of JRWSay>, write s vor open) but not opened+
. w
*** err: can only read JRWEof.jOpen(<obj e of JRWEof>, open>Arg)
*** err: jRead(<obj e of JRWEof>, XX) but not opened r
read e vor open 0 m.xx valueBefore
read e nach open 0 m.xx M.XX
out eins
#jIn 1# tst in line 1 eins ,
out zwei jIn 1 vv=readAdrVV
#jIn 2# tst in line 2 zwei ; .
out drei jIn 1 vv=readAdrVV Schluss
tstJSay */
call tst t, 'tstJSay'
call jIni
j = oNew('JRW')
call mAdd t'.TRANS', j '<obj j of JRW>'
call jOpen j, 'openArg'
call jWrite j, 'writeArg'
s = oNew('JRWSay')
call mAdd t'.TRANS', s '<obj s of JRWSay>'
call jOpen s, 'open<Arg'
call jWrite s, 'write s vor open'
call jOpen s
call jWrite s, 'write s nach open'
e = oNew('JRWEof')
call mAdd t'.TRANS', e '<obj e of JRWEof>'
call jOpen e, 'open>Arg'
m.xx = 'valueBefore'
call tstOut t, 'read e vor open' jRead(e, xx) 'm.xx' m.xx
call jOpen e
call tstOut t, 'read e nach open' jRead(e, xx) 'm.xx' m.xx
call jOut 'out eins'
vv = 'readAdrVV'
m.vv = 'readAdrVVValueBefore'
call jOut 'out zwei jIn' jIn(vv) 'vv='vv
m.vv = 'readAdrVVValueBefore'
call jOut 'out drei jIn' jIn(vv) 'vv='vv 'Schluss'
call tstEnd t
return
endProcedure tstJSay
tstJ: procedure expose m.
/*<<tstJ
### start tst tstJ ################################################
out eins
#jIn 1# tst in line 1 eins ,
1 jIn() tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
2 jIn() tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
3 jIn() tst in line 3 drei .schluss..
#jIn eof 4#
jIn() 3 reads vv VV
*** err: already opened jOpen(<buf b>, <)
line buf line one
line buf line two
line buf line three
line buf line four
*** err: jWrite(<buf b>, buf line five while reading) but not opene+
d w
tstJ */
call jIni
call tst t, "tstJ"
b = jOpen(jBuf(), '>')
call mAdd t'.TRANS', b '<buf b>'
call jOut 'out eins'
do lx=1 by 1 while jIn(var)
call jOut lx 'jIn()' m.var
end
call jOut 'jIn()' (lx-1) 'reads vv' vv
call jWrite b, 'buf line one'
call mAdd m.b.stem, 'buf line two', 'buf line three'
call jWrite b, 'buf line four'
call jOpen b, '<'
call jClose b
call jOpen b, '<'
do while (jRead(b, line))
call jOut 'line' m.line
end
call jWrite b, 'buf line five while reading'
call jClose b
call tstEnd t
return
endProcedure tstJ
tstJ2: procedure expose m.
/*<<tstJ2
### start tst tstJ2 ###############################################
class1 <Tst?1 class> <Tst?1 name>
class2 <Tst?1 class> <Tst?1 name>
class3 <Tst?1 class> <Tst?1 name>
b read EINS feld eins, ZWEI feld zwei, DREI feld drei
b read EINS feld eins, ZWEI feld zwei 2, DREI feld drei
c read EINS feld eins, ZWEI feld zwei, DREI drei cat 1
tstR: @CCC isA :<Tst?1 name> union
tstR: .EINS = feld eins
tstR: .ZWEI = feld zwei
tstR: .DREI = drei cat 1
c read EINS feld eins, ZWEI feld zwei 2, DREI drei cat 2
tstR: @CCC isA :<Tst?1 name> union
tstR: .EINS = feld eins
tstR: .ZWEI = feld zwei 2
tstR: .DREI = drei cat 2
tstJ2 */
call tst t, "tstJ2"
ty = classNew('n Tst* u f EINS v, f ZWEI v, f DREI v')
call mAdd t'.TRANS', ty '<Tst?1 class>'
call mAdd t'.TRANS', m.ty.name '<Tst?1 name>'
call tstOut t, 'class1' ty m.ty.name
ty = classNew('n Tst* u f EINS v, f ZWEI v, f DREI v')
call tstOut t, 'class2' ty m.ty.name
ty = classNew('n Tst* u f EINS v, f ZWEI v, f DREI v')
call tstOut t, 'class3' ty m.ty.name
call oMutate qq, m.ty.name
m.qq.eins = 'feld eins'
m.qq.zwei = 'feld zwei'
m.qq.drei = 'feld drei'
b = jBuf()
call jOpen b, '>'
call jWriteR b, qq
m.qq.zwei = 'feld zwei 2'
call jWriteR b, qq
call jOpen jClose(b), '<'
c = jOpen(jBuf(), '>')
do xx=1 while jRead(b, res)
call jOut 'b read EINS' m.res.eins', ZWEI' m.res.zwei,
|| ', DREI' m.res.drei
m.res.drei = 'drei cat' xx
call jWriteR c, res
end
call jOpen jClose(c), '<'
do while jRead(c, ccc)
call jOut 'c read EINS' m.ccc.eins', ZWEI' m.ccc.zwei,
|| ', DREI' m.ccc.drei
call jOuR ccc
end
call tstEnd t
return
endProcedure tstJ2
tstCat: procedure expose m.
/*<<tstCat
### start tst tstCat ##############################################
catRead 1 line 1
catRead 2 line 2
catRead 3 line 3
appRead 1 line 1
appRead 2 line 2
appRead 3 line 3
appRead 4 append 4
appRead 5 append 5
tstCat */
call tst t, "tstCat"
i = cat('%' jBuf('line 1', 'line 2'), '%' jBuf('line 3'))
call jOpen i, m.j.cRead
do lx=1 by 1 while jRead(i, v)
call tstOut t, 'catRead' lx m.v
end
call jOpen jClose(i), m.j.cApp
call jWrite i, 'append 4'
call jWrite i, 'append 5'
call jOpen jClose(i), m.j.cRead
do lx=1 by 1 while jRead(i, v)
call tstOut t, 'appRead' lx m.v
end
call tstEnd t
return
endProcedure tstCat
tstEnv: procedure expose m.
/*<<tstEnv
### start tst tstEnv ##############################################
before envPush
after envPop
*** err: jWrite(<jBuf c>, write nach pop) but not opened w
#jIn 1# tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
before writeNow 2 c --> std
before writeNow 1 b --> c
b line eins
b zwei |
nach writeNow 1 b --> c
add nach pop
after push c only
tst in line 1 eins ,
tst in line 2 zwei ; .
tst in line 3 drei .schluss..
nach writeNow 2 c --> std
*** err: jWrite(<jBuf c>, ) but not opened w
tstEnv */
call tst t, "tstEnv"
c = jBuf()
call mAdd t'.TRANS', c '<jBuf c>'
call jOut 'before envPush'
b = jBuf("b line eins", "b zwei |")
call envPush '<%' b, '>%' c
call jOut 'before writeNow 1 b --> c'
call envwriteNow
call jOut 'nach writeNow 1 b --> c'
call envPop
call jOut 'after envPop'
call jWrite c, 'write nach pop'
call mAdd c'.BUF', 'add nach pop'
call envPush '>>%' c
call jOut 'after push c only'
call envwriteNow
call envPop
call envPush '<%' c
call jOut 'before writeNow 2 c --> std'
call envwriteNow
call jOut 'nach writeNow 2 c --> std'
call envPop
call jWrite c
call tstEnd t
return
endProcedure tstEnv
tstEnvCat: procedure expose m.
/*<<tstEnvCat
### start tst tstEnvCat ###########################################
c1 contents
c1 line eins |
before writeNow 1 b* --> c*
b1 line eins|
b2 line eins
b2 zwei |
c2 line eins |
after writeNow 1 b* --> c*
c2 contents
c2 line eins |
tstEnvCat */
call tst t, "tstEnvCat"
b0= jBuf()
b0= jBuf()
b1= jBuf("b1 line eins|")
b2 = jBuf("b2 line eins", "b2 zwei |")
c1 = jBuf("c1 line eins |")
c2 = jBuf("c2 line eins |")
call envPush '<+%' b0, '<+%' b1, '<+%' b2, '<%' c2,'>>%' c1
call jOut 'before writeNow 1 b* --> c*'
call envwriteNow
call jOut 'after writeNow 1 b* --> c*'
call envPop
call jOut 'c1 contents'
call envPush '<%' c1
call envwriteNow
call envPop
call envPush '<%' c2
call jOut 'c2 contents'
call envwriteNow
call envPop
call tstEnd t
return
endProcedure tstEnvCat
tstEnvBar: procedure expose m.
/*<<tstEnvBar
### start tst tstEnvBar ###########################################
.+0 vor envBarBegin
#jIn 1# tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
.+7 nach envBarLast
¢7 +6 nach envBar 7!
¢7 +2 nach envBar 7!
¢7 +4 nach nested envBarLast 7!
¢7 (4 +3 nach nested envBarBegin 4) 7!
¢7 (4 (3 +1 nach envBarBegin 3) 4) 7!
¢7 (4 (3 tst in line 1 eins , 3) 4) 7!
¢7 (4 (3 tst in line 2 zwei ; 3) 4) 7!
¢7 (4 (3 tst in line 3 drei .schluss. 3) 4) 7!
¢7 (4 (3 +1 nach writeNow vor envBar 3) 4) 7!
¢7 (4 +3 nach preSuf vor nested envBarLast 4) 7!
¢7 +4 nach preSuf vor nested envBarEnd 7!
¢7 +5 nach nested envBarEnd vor envBar 7!
¢7 +6 nach writeNow vor envBarLast 7!
.+7 nach writeNow vor envBarEnd
.+8 nach envBarEnd
tstEnvBar */
call tst t, 'tstEnvBar'
call jOut '+0 vor envBarBegin'
call envBarBegin
call jOut '+1 nach envBarBegin'
call envwriteNow
call jOut '+1 nach writeNow vor envBar'
call envBar
call jOut '+2 nach envBar'
call envBarBegin
call jOut '+3 nach nested envBarBegin'
call envPreSuf '(3 ', ' 3)'
call jOut '+3 nach preSuf vor nested envBarLast'
call envBarLast
call jOut '+4 nach nested envBarLast'
call envPreSuf '(4 ', ' 4)'
call jOut '+4 nach preSuf vor nested envBarEnd'
call envBarEnd
call jOut '+5 nach nested envBarEnd vor envBar'
call envBar
call jOut '+6 nach envBar'
call envwriteNow
say 'jOut +6 nach writeNow vor envBarLast'
call jOut '+6 nach writeNow vor envBarLast'
call envBarLast
call jOut '+7 nach envBarLast'
call envPreSuf '¢7 ', ' 7!'
call jOut '+7 nach writeNow vor envBarEnd'
call envBarEnd
call jOut '+8 nach envBarEnd'
call tstEnd t
return
endProcedure tstEnvBar
tstEnvVars: procedure expose m.
/*<<tstEnvVars
### start tst tstEnvVars ##########################################
put v1 value eins
v1 hasKey 1 get value eins
v2 hasKey 0
via v1.fld via value
one to theBur
two to theBuf
tstEnvVars */
call tst t, "tstEnvVars"
call envRemove 'v2'
put1 = envPut('v1', 'value eins')
call tstOut t, 'put v1' put1
call tstOut t, 'v1 hasKey' envHasKey('v1') 'get' envGet('v1')
call tstOut t, 'v2 hasKey' envHasKey('v2')
if 0 then
call tstOut t, 'v2 get' envGet('v2')
m.put1.fld = 'via value'
call tstOut t, 'via v1.fld' envVia('v1*FLD')
call envPush '># theBuf'
call jOut 'one to theBur'
call jOut 'two to theBuf'
call envPop
call envPush '<# theBuf'
call envwriteNow
call envPop
call tstEnd t
return
endProcedure tstEnvVars
tstEnvLazy: procedure expose m.
/*<<tstEnvLazy
### start tst tstEnvLazy ##########################################
a1 vor envBarBegin loop lazy 0 writeNow *** <class TstEnvLazyBuf>
bufOpen <%
bufClose
#jIn 2# tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
a5 vor 2 writeNow jIn inIx 4
a2 vor writeNow jBuf
jBuf line 1
jBuf line 2
a3 vor writeNow jIn inIx 1
tst in line 2 zwei ; .
tst in line 3 drei .schluss..
a4 vor barLast inIx 4
a6 vor barEnd inIx 4
a7 nach barEnd lazy 0 writeNow ***
b1 vor barBegin lazy 0 writeNow *** <class TstEnvLazyRdr>
RdrOpen <%
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
rdrClose
b4 vor writeNow
b2 vor writeNow rdr inIx 2
jRead lazyRdr
tst in line 3 drei .schluss..
jRead lazyRdr
b3 vor barLast inIx 4
b5 vor barEnd inIx 4
b6 nach barEnd lazy 0 writeNow ***
a1 vor envBarBegin loop lazy 1 writeAll *** <class TstEnvLazyBuf>
a5 vor 2 writeAll jIn inIx 0
a2 vor writeAll jBuf
bufOpen <%
jBuf line 1
jBuf line 2
bufClose
a3 vor writeAll jIn inIx 0
#jIn 1# tst in line 1 eins ,
tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
tst in line 3 drei .schluss..
#jIn eof 4#
a4 vor barLast inIx 0
a6 vor barEnd inIx 4
a7 nach barEnd lazy 1 writeAll ***
b1 vor barBegin lazy 1 writeAll *** <class TstEnvLazyRdr>
b4 vor writeAll
b2 vor writeAll rdr inIx 1
RdrOpen <%
*** err: jWrite(ENV.lazyNoOut, jRead lazyRdr) but not opened w
#jIn 2# tst in line 2 zwei ; .
tst in line 2 zwei ; .
*** err: jWrite(ENV.lazyNoOut, jRead lazyRdr) but not opened w
#jIn 3# tst in line 3 drei .schluss..
tst in line 3 drei .schluss..
*** err: jWrite(ENV.lazyNoOut, jRead lazyRdr) but not opened w
#jIn eof 4#
rdrClose
b3 vor barLast inIx 1
b5 vor barEnd inIx 4
b6 nach barEnd lazy 1 writeAll ***
tstEnvLazy */
call tst t, "tstEnvLazy"
do lz=0 to 1
if lz then
w = 'writeAll'
else
w = 'writeNow'
m.t.inIx = 1-lz
ty = classNew('n TstEnvLazyBuf u JBuf', 'm',
, 'jOpen call tstOut "T", "bufOpen" opt;',
'return jOpen(oCast(m, "JBuf"), opt)',
, 'jClose call tstOut "T", "bufClose";',
'return jClose(oCast(m, "JBuf"), opt)')
if \ lz then
call mAdd t'.TRANS', ty '<class TstEnvLazyBuf>'
call jOut 'a1 vor envBarBegin loop lazy' lz w '***' ty
call envBarBegin
call jOut 'a2 vor' w 'jBuf'
b = oMutate(jBuf('jBuf line 1','jBuf line 2'),
,'TstEnvLazyBuf')
interpret 'call env'w '"<%" b'
call jOut 'a3 vor' w 'jIn inIx' m.t.inIx
interpret 'call env'w
call jOut 'a4 vor barLast inIx' m.t.inIx
call envBarLast
call jOut 'a5 vor 2' w 'jIn inIx' m.t.inIx
interpret 'call env'w
call jOut 'a6 vor barEnd inIx' m.t.inIx
call envBarEnd
call jOut 'a7 nach barEnd lazy' lz w '***'
ty = classNew('n TstEnvLazyRdr u JRW', 'm',
, 'jOpen call tstOut "T", "RdrOpen" opt;m.m.jReading=1',
, 'jRead call jOut "jRead lazyRdr"; return jIn(var);',
, 'jClose call tstOut "T", "rdrClose";')
if \ lz then
call mAdd t'.TRANS', ty '<class TstEnvLazyRdr>'
r = oNew('TstEnvLazyRdr')
if lz then
call mAdd t'.TRANS', r '<lazyRdr>'
m.t.inIx = 2-lz
call jOut 'b1 vor barBegin lazy' lz w '***' ty
call envBarBegin
if lz then
call mAdd t'.TRANS', m.j.jOut '<barBegin out>'
call jOut 'b2 vor' w 'rdr inIx' m.t.inIx
interpret 'call env'w 'm.j.cRead || m.j.cObj r'
call jOut 'b3 vor barLast inIx' m.t.inIx
call envBarLast
call jOut 'b4 vor' w
interpret 'call env'w
call jOut 'b5 vor barEnd inIx' m.t.inIx
call envBarEnd
call jOut 'b6 nach barEnd lazy' lz w '***'
end
call tstEnd t
return
endProcedure tstEnvLazy
tstEnvClass: procedure expose m.
/*<<tstEnvClass
### start tst tstEnvClass #########################################
a0 vor envBarBegin loop lazy 0 writeNow *** TY
#jIn 2# tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
a5 vor writeNow
a1 vor jBuf()
a2 vor writeNow b
tstR: @LINE isA :TstEnvClass10 union
tstR: .f11 = M.<o20 of TstEnvClass10>.f11
tstR: .F12 = value F12 of o1 <o20 of TstEnvClass10>
tstR: .f13 = M.<o20 of TstEnvClass10>.f13
writeR o2
tstR: @LINE isA :TstEnvClass20 union = valueO2Lazy0
tstR: .f24 = M.<o20 of TstEnvClass20>.f24
tstR: .F25 = value F25 of o20 <o20 of TstEnvClass20>
a3 vor writeNow
tst in line 2 zwei ; .
tst in line 3 drei .schluss..
a4 vor barLast inIx 4
a6 vor barEnd
a7 nach barEnd lazy 0 writeNow ***
a0 vor envBarBegin loop lazy 1 writeAll *** TY
a5 vor writeAll
a1 vor jBuf()
a2 vor writeAll b
tstR: @LINE isA :TstEnvClass10 union
tstR: .f11 = M.<o21 of TstEnvClass10>.f11
tstR: .F12 = value F12 of o1 <o21 of TstEnvClass10>
tstR: .f13 = M.<o21 of TstEnvClass10>.f13
writeR o2
tstR: @LINE isA :TstEnvClass20 union = valueO2Lazy1
tstR: .f24 = M.<o21 of TstEnvClass20>.f24
tstR: .F25 = value F25 of o21 <o21 of TstEnvClass20>
a3 vor writeAll
#jIn 1# tst in line 1 eins ,
tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
tst in line 3 drei .schluss..
#jIn eof 4#
a4 vor barLast inIx 0
a6 vor barEnd
a7 nach barEnd lazy 1 writeAll ***
tstEnvClass */
call tst t, "tstEnvClass"
do lz=0 to 1
if lz then
w = 'writeAll'
else
w = 'writeNow'
m.t.inIx = 1-lz
t10 = classNew('n TstEnvClass10 u f f11 v, f F12 v, f f13 v')
t20 = classNew('n TstEnvClass20 u v, f f24 v, f F25 v')
call jOut 'a0 vor envBarBegin loop lazy' lz w '***' ty
call envBarBegin
call jOut 'a1 vor jBuf()'
b = jOpen(jBuf(), m.j.cWri)
o1 = oNew('TstEnvClass10')
m.o1.F12 = 'value F12 of o1' o1
call mAdd t'.TRANS', o1 '<o2'lz 'of TstEnvClass10>'
call jWriteR b, o1
call jWrite b, 'writeR o2'
o2 = oNew('TstEnvClass20')
m.o2 = 'valueO2Lazy'lz
m.o2.F25 = 'value F25 of o2'lz o2
oc = oCopyNew(oCopyNew(o2))
call mAdd t'.TRANS', o2 '<o2'lz 'of TstEnvClass20>'
call mAdd t'.TRANS', oc '<oc'lz 'of TstEnvClass20>'
call jWriteR b, oc
call jOut 'a2 vor' w 'b'
interpret 'call env'w '"<%"' jClose(b)
call jOut 'a3 vor' w
interpret 'call env'w
call jOut 'a4 vor barLast inIx' m.t.inIx
call envBarLast
call jOut 'a5 vor' w
interpret 'call env'w
call jOut 'a6 vor barEnd'
call envBarEnd
call jOut 'a7 nach barEnd lazy' lz w '***'
end
call tstEnd t
return
endProcedure tstEnvClass
tstFile: procedure expose m.
/*<<tstFile
### start tst tstFile #############################################
write read 0 last 10 vor anfang
write read 1 last 80 links1 1 und rechts | ..
write read 2 last 80 liinks2 2 und rechts | ..
write read 5 last 80 links5 5 rechts5
write read 99 last 80 links99 99 rechts
write read 100 last 80 links100 100 rechts
write read 101 last 80 links101 101 rechts
write read 999 last 80 links999 999 rechts
write read 1000 last 80 links1000 1000 rechts
write read 1001 last 80 links1001 1001 rechts
write read 2109 last 80 links2109 2109 rechts
out > eins 1 +
. .
out > eins 2 schluss. +
. .
buf eins
buf zwei
buf drei
out > zwei mit einer einzigen Zeile +
. .
. links1 1 und rechts | . +
. .
tstFile */
call tst t, "tstFile"
pds = tstFilename('lib', 'r')
call tstFileWr pds, 0, ' links0', ' und rechts | . '
call tstFileWr pds, 1, ' links1', ' und rechts | . '
call tstFileWr pds, 2, 'liinks2', ' und rechts | . '
call tstFileWr pds, 5, 'links5', 'rechts5'
call tstFileWr pds, 99, 'links99', 'rechts'
call tstFileWr pds, 100, 'links100', 'rechts'
call tstFileWr pds, 101, 'links101', 'rechts'
call tstFileWr pds, 999, 'links999', 'rechts'
call tstFileWr pds, 1000, 'links1000', 'rechts'
call tstFileWr pds, 1001, 'links1001', 'rechts'
call tstFileWr pds, 2109, 'links2109', 'rechts'
pd2 = tstFilename('li2', 'r')
call envPush '>' tstPdsMbr(pd2, 'eins')
call jOut tstFB('out > eins 1') /* simulate fixBlock on linux */
call jOut tstFB('out > eins 2 schluss.')
call envPop
call envPush '>' tstPdsMbr(pd2, 'zwei')
call jOut tstFB('out > zwei mit einer einzigen Zeile')
call envPop
b = jBuf("buf eins", "buf zwei", "buf drei")
call envPush '<' tstPdsMbr(pd2, 'eins'), '<%' b,
,'<%' jBuf(),
,'<' tstPdsMbr(pd2, 'zwei'),
,'<' tstPdsMbr(pds, 'wr0'),
,'<' tstPdsMbr(pds, 'wr1')
call envwriteNow
call envPop
call tstEnd t
return
endProcedure tstFile
/*--- simulate fixBlock 80 on linux ---------------------------------*/
tstFB: procedure expose m.
parse arg line, recL
if errOS() \== 'LINUX' then
return line
else if recL == '' then
return left(line, 80)
else
return left(line, recL)
endProcedure tstFB
tstPdsMbr: procedure expose m.
parse arg pds, mbr
os = errOS()
if os = 'TSO' then
return pds'('mbr') ::F'
if os = 'LINUX' then
return pds'.'mbr
call err 'tstPdsMbr implement os' os
endProcedure tstPdsMbr
tstFileWR: procedure expose m.
parse arg dsn, num, le, ri
io = file(tstPdsMbr(dsn, 'wr'num))
call jOpen io, m.j.cWri
do x = 1 to num /* simulate fixBlock 80 on LINUX*/
call jWrite io, tstFB(le x ri)
end
if num > 100 then
call jReset jClose(io), tstPdsMbr(dsn, 'wr'num)
call jOpen jClose(io), m.j.cRead
m.vv = 'vor anfang'
do x = 1 to num
if \ jRead(io, vv) then
call err x 'not jRead'
else if m.vv <> le x ri then
call err x 'read mismatch' m.vv
end
if jRead(io, vv) then
call err x 'jRead'
if jRead(io, vv) then
call err x'+1 jRead'
call jClose io
call tstOut t, 'write read' num 'last' length(m.vv) strip(m.vv,'t')
return
endProcedure tstFileRW
tstFileList: procedure expose m.
/*<<tstFileList
### start tst tstFileList #########################################
empty dir
filled dir
<<pref 2 List>>drei
<<pref 2 List>>eins
<<pref 2 List>>zwei
<<pref 2 List>>vier
filled dir recursive
<<pref 2 List>>drei
<<pref 2 List>>eins
<<pref 2 List>>zwei
<<pref 2 List>>vier
<<pref 1 vier>>drei
<<pref 1 vier>>eins
<<pref 1 vier>>zwei
tstFileList */
/*<<tstFileListTSO
### start tst tstFileListTSO ######################################
empty dir
filled dir
<<pref 2 LIST>>DREI
<<pref 2 LIST>>EINS
<<pref 2 LIST>>ZWEI
filled dir recursive
<<pref 2 LIST>>DREI
<<pref 2 LIST>>EINS
<<pref 1 VIER>>DREI
<<pref 1 VIER>>EINS
<<pref 1 VIER>>ZWEI
<<pref 2 LIST>>ZWEI
tstFileListTSO */
if errOS() = 'TSO' then
call tst t, "tstFileListTSO"
else
call tst t, "tstFileList"
fi = file(tstFileName('FileList', 'r'))
call fileMkDir fi
fl = fileList(fi)
call tstOut t, 'empty dir'
call jWriteNow t, fl
call tstFileListMake t, fi, 2
call tstOut t, 'filled dir'
call jWriteNow t, fl
call tstOut t, 'filled dir recursive'
call jWriteNow t, fileList(fi, 'r')
call tstEnd t
return
endProcedure tstFileList
tstFileListMake: procedure expose m.
parse arg t, fi, lev
if \ fileIsDir(fi) then
call fileMkDir fi
call mAdd t'.TRANS', filePath(fi) || m.file.sep ,
'<<pref' lev right(filePath(fi),4)'>>'
call jCat fileChild(fi, 'eins','::F'),jBuf('zeile eins', 'eins' lev)
call jCat fileChild(fi, 'zwei','::F'),jBuf('zeile zwei', 'zwei' lev)
call jCat fileChild(fi, 'drei','::F'),jBuf('zeile drei', 'drei' lev)
if lev > 1 then
call tstFileListMake t, fileChild(fi, 'vier'), lev-1
return
endProcedure tstFileListMake
tstFmt: procedure expose m.
/*<<tstFmt
### start tst tstFmt ##############################################
= a2i b3b d4 fl5 ex6
-11 -11 b3 d4-11+d4++++ -111.1000000 -1.11000E-12
-1 -10 b d4-10+d4+++ null1 null3
- -9 b3b-9 d4-9+d4+++ -11.0000000 -1.11900E-10
-8+ -8 b3b- d4-8+d4++ -18.0000000 -1.18000E010
-7 -7 b3b d4-7+d4+ -7.0000000 -1.70000E-07
- -6 b3 d4-6+d4 -0.1111160 -6.00000E006
-5+ -5 b d4-5+d null2 null2
-4 -4 b3b-4 d4-4+ -11114.0000000 -1.11140E008
- -3 b3b- d4-3 -0.1130000 -1.13000E-04
-2+ -2 b3b d4- -0.1200000 -1.20000E001
-1 -1 b3 d4 -0.1000000 -1.00000E-02
0 0 b d null1 null1
1+ 1 b3 d4 0.1000000 1.00000E-02
2++ 2 b3b d42 0.1200000 1.20000E001
3 3 b3b3 d43+ 0.1130000 1.13000E-04
4+ 4 b3b4+ d44+d 11114.0000000 1.11140E008
5++ 5 b d45+d4 null2 null2
6 6 b3 d46+d4+ 0.1111160 1.11116E005
7+ 7 b3b d47+d4++ 0.1111117 7.00000E-08
8++ 8 b3b8 d48+d4+++ 8.0000000 1.80000E009
9 9 b3b9+ d49+d4++++ 0.9000000 1.19000E-08
10 10 b d410+d4++++ null1 null3
11+ 11 b3 d411+d4+++++ 0.1110000 1.00000E-12
1 12 b3b d412+d4++++++ 11112.0000000 2.00000E012
13 13 b3b1 d 1111.3000000 1.13000E-12
14+ 14 b3b14 d4 111111.0000000 1.40000E013
1 15 b d41 null2 null1
16 16 b3 d416 6.0000000 1.16000E003
17+ 17 b3b d417+ 0.7000000 1.11170E-03
1 18 b3b1 d418+d 11.0000000 1.11800E003
19 19 b3b19 d419+d4 0.1190000 9.00000E-05
20+ 20 b d420+d4+ null1 null2
2 21 b3 d421+d4++ 11.1210000 1.11000E-05
22 22 b3b d422+d4+++ 11111.2000000 2.00000E007
23+ 23 b3b2 d423+d4++++ 0.1111123 1.11230E-09
c3L a2i drei d4 fl5 ex6
-11 -1.10E01 b3 d4-11+d -111.1000000 -1.11000E-12
-1 -1.00E01 b d4-10+d null1 null3
- -9.00E00 b3b-9 d4-9+d4 -11.0000000 -1.11900E-10
-8+ -8.00E00 b3b- d4-8+d4 -18.0000000 -1.18000E010
-7 -7.00E00 b3b d4-7+d4 -7.0000000 -1.70000E-07
- -6.00E00 b3 d4-6+d4 -0.1111160 -6.00000E006
-5+ -5.00E00 b d4-5+d null2 null2
-4 -4.00E00 b3b-4 d4-4+ -11114.0000000 -1.11140E008
- -3.00E00 b3b- d4-3 -0.1130000 -1.13000E-04
-2+ -2.00E00 b3b d4- -0.1200000 -1.20000E001
-1 -1.00E00 b3 d4 -0.1000000 -1.00000E-02
0 0.00E00 b d null1 null1
1+ 1.00E00 b3 d4 0.1000000 1.00000E-02
2++ 2.00E00 b3b d42 0.1200000 1.20000E001
3 3.00E00 b3b3 d43+ 0.1130000 1.13000E-04
4+ 4.00E00 b3b4+ d44+d 11114.0000000 1.11140E008
5++ 5.00E00 b d45+d4 null2 null2
6 6.00E00 b3 d46+d4+ 0.1111160 1.11116E005
7+ 7.00E00 b3b d47+d4+ 0.1111117 7.00000E-08
8++ 8.00E00 b3b8 d48+d4+ 8.0000000 1.80000E009
9 9.00E00 b3b9+ d49+d4+ 0.9000000 1.19000E-08
10 1.00E01 b d410+d4 null1 null3
11+ 1.10E01 b3 d411+d4 0.1110000 1.00000E-12
1 1.20E01 b3b d412+d4 11112.0000000 2.00000E012
13 1.30E01 b3b1 d 1111.3000000 1.13000E-12
14+ 1.40E01 b3b14 d4 111111.0000000 1.40000E013
1 1.50E01 b d41 null2 null1
16 1.60E01 b3 d416 6.0000000 1.16000E003
17+ 1.70E01 b3b d417+ 0.7000000 1.11170E-03
1 1.80E01 b3b1 d418+d 11.0000000 1.11800E003
19 1.90E01 b3b19 d419+d4 0.1190000 9.00000E-05
20+ 2.00E01 b d420+d4 null1 null2
2 2.10E01 b3 d421+d4 11.1210000 1.11000E-05
22 2.20E01 b3b d422+d4 11111.2000000 2.00000E007
23+ 2.30E01 b3b2 d423+d4 0.1111123 1.11230E-09
tstFmt */
call tst t, "tstFmt"
b = jBuf()
st = b'.BUF'
call envPush m.j.cWri || m.j.cObj b
call tstDataClassOut '. c3 a2i i b3b c5 d4 c13 fl5 f8n2 ex6 e9n3',
, -11, + 23
call envPop
call fmtFWriteAll fmtFreset(abc), m.j.cRead || m.j.cObj b
call fmtFAddFlds fmtFReset(abc), oFlds(st'.'1)
m.abc.1.tit = 'c3L'
m.abc.2.fmt = 'e'
m.abc.3.tit = 'drei'
m.abc.4.fmt = 'l7'
call fmtFWriteAll abc, m.j.cRead || m.j.cObj b
call tstEnd t
/*<<tstFmtCSV
### start tst tstFmtCSV ###########################################
, a2i, b3b, d4, fl5, ex6
-5+, -5, b, d4-5+d, null2, null2
-4, -4, b3b-4, d4-4+, -11114, -11114e4
-, -3, b3b-, d4-3, -.113, -.113e-3
-2+, -2, b3b, d4-, -.12, -.12e2
-1, -1, b3, d4, -.1, -.1e-1
0, 0, b, d, null1, null1
1+, 1, b3, d4, .1, .1e-1
2++, 2, b3b, d42, .12, .12e2
3, 3, b3b3, d43+, .113, .113e-3
4+, 4, b3b4+, d44+d, 11114, 11114e4
5++, 5, b, d45+d4, null2, null2
6, 6, b3, d46+d4+, .111116, .111116e6
7+, 7, b3b, d47+d4++, .1111117, .7e-7
tstFmtCSV */
call tst t, 'tstFmtCSV'
call envBarBegin
call tstDataClassOut '. c3 a2i i b3b c5 d4 c13 fl5 f8n2 ex6 e9n3',
, -5, + 7
call envBarLast
call fmtFCsvAll
call envBarEnd
call tstEnd t
return
endProcedure tstFmt
tstScan: procedure expose m.
/*<<tstScan.1
### start tst tstScan.1 ###########################################
scan src a034,Und hr123sdfER"st1" 'str2''mit''apo''s' .
scan n tok 4: a034 key val .
scan , tok 1: , key val .
scan n tok 3: Und key val .
scan v tok 1: key val .
scan n tok 10: hr123sdfER key val .
scan q tok 5: "st1" key val st1
scan v tok 1: key val st1
scan a tok 19: 'str2''mit''apo''s' key val str2'mit'apo's
scan v tok 1: key val str2'mit'apo's
tstScan.1 */
call tst t, 'tstScan.1'
call tstScan1 ,'l"litEins"l"litZwei"ndv" "aq1' ,
,"a034,Und hr123sdfER""st1"" 'str2''mit''apo''s' "
call tstEnd t
/*<<tstScan.2
### start tst tstScan.2 ###########################################
scan src a034,Und hr123sdfER"st1" 'str2''mit''apo''s' .
scan n tok 4: a034 key val .
scan , tok 1: , key val .
scan n tok 3: Und key val .
scan b tok 0: key val .
scan n tok 10: hr123sdfER key val .
scan " tok 5: "st1" key val st1
scan b tok 0: key val st1
scan ' tok 19: 'str2''mit''apo''s' key val str2'mit'apo's
scan b tok 0: key val str2'mit'apo's
tstScan.2 */
call tst t, 'tstScan.2'
call tstScan1 , 'ndsb1' ,
,"a034,Und hr123sdfER""st1"" 'str2''mit''apo''s' "
call tstEnd t
/*<<tstScan.3
### start tst tstScan.3 ###########################################
scan src a034,'wie 789abc
scan n tok 4: a034 key val .
scan , tok 1: , key val .
*** err: scanErr ending Apostroph(') missing
. e 1: last token scanPosition 'wie 789abc
. e 2: pos 6 in string a034,'wie 789abc
scan ' tok 1: ' key val .
scan n tok 3: wie key val .
scan s tok 0: key val .
*** err: scanErr illegal number end after 789
. e 1: last token 789 scanPosition abc
. e 2: pos 14 in string a034,'wie 789abc
scan d tok 3: 789 key val .
scan n tok 3: abc key val .
tstScan.3 */
call tst t, 'tstScan.3'
call tstScan1 , 'nds1' ,
,"a034,'wie 789abc"
call tstEnd t
/*<<tstScan.4
### start tst tstScan.4 ###########################################
scan src litEinsefr 23 sdfER'str1'litZwei "str2""mit quo"s .
scan l tok 7: litEins key val .
scan n tok 3: efr key val .
scan b tok 0: key val .
scan d tok 2: 23 key val .
scan b tok 0: key val .
scan n tok 5: sdfER key val .
scan a tok 6: 'str1' key val str1
scan l tok 7: litZwei key val str1
scan b tok 0: key val str1
scan q tok 15: "str2""mit quo" key val str2"mit quo
scan n tok 1: s key val str2"mit quo
scan b tok 0: key val str2"mit quo
tstScan.4 */
call tst t, 'tstScan.4'
call tstScan1 , 'l"litEins"l"litZwei"ndbaq1' ,
,"litEinsefr 23 sdfER'str1'litZwei ""str2""""mit quo""s "
call tstEnd t
/*<<tstScan.5
### start tst tstScan.5 ###########################################
scan src aha;+-=f ab=cdEf eF='strIng' .
scan b tok 0: key val .
scan k tok 4: no= key aha val def
scan ; tok 1: ; key aha val def
scan + tok 1: + key aha val def
scan - tok 1: - key aha val def
scan = tok 1: = key aha val def
scan k tok 4: no= key f val def
scan k tok 4: cdEf key ab val cdEf
scan b tok 4: cdEf key ab val cdEf
scan k tok 8: 'strIng' key eF val strIng
scan b tok 8: 'strIng' key eF val strIng
tstScan.5 */
call tst t, 'tstScan.5'
call tstScan1 , 'bk1'," aha;+-=f ab=cdEf eF='strIng' "
call tstEnd t
return
endProcedure tstScan
tstScanRead: procedure expose m.
/*<<tstScanRead
### start tst tstScanRead #########################################
name erste
space
name Zeile
space
nextLine
nextLine
space
name dritte
space
name Zeile
space
name schluss
space
tstScanRead */
call tst t, 'tstScanRead'
b = jBuf('erste Zeile ',,' dritte Zeile schluss ')
s = jOpen(scanRead(b))
do while \scanAtEnd(s)
if scanName(s) then call tstOut t, 'name' m.s.tok
else if scanVerify(s, ' ') then call tstOut t, 'space'
else if scanReadNL(s) then call tstOut t, 'nextLine'
else if \scanAtEnd(s) then call scanErr s, 'cannot scan'
end
call jClose s
call tstEnd t
/*<<tstScanReadMitSpaceLn
### start tst tstScanReadMitSpaceLn ###############################
name erste
spaceLn
name Zeile
spaceLn
name dritte
spaceLn
name Zeile
spaceLn
name schluss
spaceLn
tstScanReadMitSpaceLn */
call tst t, 'tstScanReadMitSpaceLn'
s = jOpen(scanRead(b))
do forever
if scanName(s) then call jOut 'name' m.s.tok
else if scanSpaceNL(s) then call jOut 'spaceLn'
else if \scanAtEnd(s) then call scanErr s, 'cannot scan'
else leave
end
call jClose s
call tstEnd t
/*<<tstScanJRead
### start tst tstScanJRead ########################################
1 jRead n tok erste val .
2 jRead s tok val .
3 jRead n tok Zeile val .
4 jRead s tok val .
5 jRead n tok dritte val .
6 jRead s tok val .
7 jRead n tok Zeile val .
8 jRead s tok val .
9 jRead n tok schluss val .
10 jRead s tok val .
11 jRead 0 tok 1 val 1
12 jRead s tok val 1
13 jRead + tok + val 1
14 jRead s tok val 1
15 jRead 0 tok 2. val 2..
16 jRead s tok val 2..
17 jRead + tok + val 2..
18 jRead . tok . val 2..
19 jRead s tok val 2..
20 jRead 0 tok +.3 val +.3
21 jRead 0 tok -45e-3 val -45E-3
22 jRead s tok val -45E-3
23 jRead " tok "a""b" val a"b
24 jRead s tok val a"b
25 jRead ' tok 'c''d' val c'd
className 1: Scan 18: Scan
tstScanJRead */
call tst t, 'tstScanJRead'
call jWrite jOpen(b,'>>'), '1 + 2. +. +.3-45e-3 "a""b"' "'c''d'"
s = jOpen(scanRead(jClose(b)))
do x=1 while jRead(s, v.x)
call jOut x 'jRead' m.v.x.type 'tok' m.v.x.tok 'val' m.v.x.val
end
call jClose s
call jOut 'className 1:' className(objClass(v.1)),
'18:' className(objClass(v.18))
call tstEnd t
return
endProcedure tstScanRead
tstScanWin: procedure expose m.
/*<<tstScanWin
### start tst tstScanWin ##########################################
info 0: last token scanPosition erste Zeile dr+
itteZe\npos 1 in line 1: erste Zeile
name erste
spaceNL
name Zeile
spaceNL
name dritteZeeeile
info 5: last token dritteZeeeile scanPosition zeile4 +
. fuenfueberSechs\npos 1 in line 4: zeile4
spaceNL
name zeile4
spaceNL
name fuenfueberSechsUnddSiebenUNDundUndUAcht
spaceNL
info 10: last token scanPosition undZehnueberElfundNochWeiterZwoel+
fundim1\npos 9 in line 10: undZehn
name undZehnueberElfundNochWeiterZwoelfundim13
spaceNL
name Punkt
infoE 14: last token Punkt scanPosition \natEnd after line 13: im13+
. Punkt
tstScanWin */
call scanWinIni
call tst t, 'tstScanWin'
b = jBuf('?erste Zeile?',,'? dritteZeeeile?', '? zeile4 ',
,'? fuenf?', '?ueberSechsUnddS?', '?iebenUNDundUndU?',
,'?Acht ?', '? ?', '? undZehn?',
,'?ueberElfundNoch?', '?WeiterZwoelfund?', '?im13 Punkt?')
s = jOpen(scanWin(b, , , 2, 15))
call tstOut t, 'info 0:' scanInfo(s)
do sx=1 while \scanAtEnd(s)
if scanName(s) then call tstOut t, 'name' m.s.tok
else if scanSpaceNL(s) then call tstOut t, 'spaceNL'
else if \scanAtEnd(s) then call scanErr s, 'cannot scan'
if sx // 5 = 0 then
call tstOut t, 'info' sx':' scanInfo(s)
end
call tstOut t, 'infoE' sx':' scanInfo(s)
call tstEnd t
/*<<tstScanWinRead
### start tst tstScanWinRead ######################################
info 0: last token scanPosition erste Zeile z3 +
com Ze\npos 1 in line 1: erste Zeile
name erste
spaceNL
name Zeile
spaceNL
name z3
info 5: last token z3 scanPosition com Zeeeile z4 come4 f+
uenf\npos 4 in line 3: z3 com Zeeeile
spaceNL
name z4
spaceNL
name fuenf
spaceNL
info 10: last token scanPosition com Sechs com sieben comAc+
ht com\npos 15 in line 5: fuenf c
name com
spaceNL
tstScanWinRead */
call tst t, 'tstScanWinRead'
call mAdd t.cmp,
, "name Sechs",
, "spaceNL",
, "name com",
, "info 15: last token com scanPosition sieben comAcht c",
|| "om com com\npos 2 in line 7: m sieben com" ,
, "spaceNL",
, "name sieben",
, "spaceNL",
, "name Acht",
, "spaceNL",
, "info 20: last token scanPosition ueberElfundNochWeit com ",
|| "elfundim13\npos 1 in line 11: ueberElfundNoch",
, "name ueberElfundNochWeit",
, "spaceNL",
, "name im13",
, "spaceNL",
, "name Punkt",
, "info 25: last token Punkt scanPosition \natEnd after line ",
|| "13: im13 Punkt",
, "infoE 26: last token Punkt scanPosition \natEnd after line",
|| " 13: im13 Punkt"
b = jBuf('?erste Zeile?',,'? z3 com Zeeeile?', '? z4 come4 ',
,'? fuenf c?', '?om Sechs co?', '?m sieben com?',
,'?Acht com com ?', '? com ?', '? com undZehn?',
,'?ueberElfundNoch?', '?Weit com elfund?', '?im13 Punkt?')
s = scanWin(b, , , 2, 15)
call scanOpts s, , , 'com'
call tstOut t, 'info 0:' scanInfo(jOpen(s))
do sx=1 while \scanAtEnd(s)
if scanName(s) then call tstOut t, 'name' m.s.tok
else if scanSpaceNL(s) then call tstOut t, 'spaceNL'
else if \scanAtEnd(s) then call scanErr s, 'cannot scan'
if sx // 5 = 0 then
call tstOut t, 'info' sx':' scanInfo(s)
end
call tstOut t, 'infoE' sx':' scanInfo(s)
call tstEnd t
return
endProcedure tstScanWin
tstScanSql: procedure expose m.
call scanWinIni
/*<<tstScanSqlId
### start tst tstScanSqlId ########################################
sqlId ABC
spaceNL
sqlId AB__345EF
spaceNL
tstScanSqlId */
call tst t, 'tstScanSqlId'
b = jBuf('abc -- kommentar', right('ab_', 72), '_345ef-- kom')
s = jOpen(scanSql(b))
do sx=1 while \scanAtEnd(s)
if scanSqlID(s) then call tstOut t, 'sqlId' m.s.val
else if scanSpaceNL(s) then call tstOut t, 'spaceNL'
else call scanErr s, 'cannot scan'
end
call tstEnd t
/*<<tstScanSqlDelimited
### start tst tstScanSqlDelimited #################################
sqlDeId ABC
spaceNL
sqlDeId AB_3F
spaceNL
sqlDeId abc
spaceNL
sqlDeId ab_Ef
spaceNL
tstScanSqlDelimited */
call tst t, 'tstScanSqlDelimited'
b = jBuf('abc -- kommentar',,' -- ',,right('ab_', 72),'3F-- kom',
, '"abc" -- ko', ' -- ',,right('"ab_', 72),'Ef"-- kom')
s = jOpen(scanSql(b))
do sx=1 while \scanAtEnd(s)
if scanSqlDeID(s) then call tstOut t, 'sqlDeId' m.s.val
else if scanSpaceNL(s) then call tstOut t, 'spaceNL'
else call scanErr s, 'cannot scan'
end
call tstEnd t
/*<<tstScanSqlQualified
### start tst tstScanSqlQualified #################################
sqlQuId ABC 1 ABC
sqlQuId AB_3F 1 AB_3F
sqlQuId abc 1 abc
sqlQuId ab_Ef 1 ab_Ef
sqlQuId EINS.Zwei.DREI 3 EINS
sqlQuId vi er.fu enf 2 vi er
tstScanSqlQualified */
call tst t, 'tstScanSqlQualified'
b = jBuf('abc -- kommentar',,' -- ',,right('ab_', 72),'3F-- kom',
, '"abc" -- ko', ' -- ',right('"ab_', 72),'Ef"-- kom',
, 'eins."Zwei', '" -- com', ' . -- com', ' -- com',
, 'drei -- ko', '"vi er"."fu enf " -- co')
s = jOpen(scanSql(b))
do sx=1 while \scanAtEnd(s)
if scanSqlQuID(s) then
call tstOut t, 'sqlQuId' m.s.val m.s.val.0 m.s.val.1
else if scanSpaceNL(s) then call tstOut t, 'spaceNL'
else call scanErr s, 'cannot scan'
end
call tstEnd t
/*<<tstScanSqlNum
### start tst tstScanSqlNum #######################################
sqlNum 1
spaceNL
sqlNum 2..
spaceNL
sqlNum .3
spaceNL
sqlNum 4.5
spaceNL
sqlNum +6
spaceNL
sqlNum +7.03
spaceNL
sqlNum -8
spaceNL
sqlNum -.9
spaceNL
sqlNum 1E2
spaceNL
sqlNum -2.E-2
spaceNL
sqlNum +.3E+3
spaceNL
tstScanSqlNum */
call tst t, 'tstScanSqlNum'
b = jBuf('1 2. .3 4.5 +6 + --kom', , ' -- com ', , ' 7.03 -8 - .9',
'1e2 - 2.e-2 + .3e+3')
s = jOpen(scanSql(b))
do sx=1 while \scanAtEnd(s)
if scanSqlNum(s) then
call tstOut t, 'sqlNum' m.s.val
else if scanSpaceNL(s) then call tstOut t, 'spaceNL'
else call scanErr s, 'cannot scan'
end
call tstEnd t
/*<<tstScanSqlNumUnit
### start tst tstScanSqlNumUnit ###################################
sqlNumUnit 1 KB
spaceNL
sqlNumUnit .3 MB
sqlNumUnit .5
sqlNumUnit +6.E-5 B
spaceNL
sqlNumUnit -7
char *
spaceNL
sqlNumUnit -.8
char T
char B
spaceNL
*** err: scanErr scanSqlNumUnit after +9. bad unit TB
. e 1: last token Tb scanPosition .
. e 2: pos 41 in line 1: 1 kb .3mB.5 + 6.e-5B -7* -.8 TB + 9.T+
b
sqlNumUnit +9..
spaceNL
tstScanSqlNumUnit */
call tst t, 'tstScanSqlNumUnit'
b = jBuf('1 kb .3mB.5 + 6.e-5B -7* -.8 TB + 9.Tb')
s = jOpen(scanSql(b))
do sx=1 while \scanAtEnd(s)
if scanSqlNumUnit(s, 0, 'B KB MB') then
call tstOut t, 'sqlNumUnit' m.s.val
else if scanSpaceNL(s) then call tstOut t, 'spaceNL'
else if scanChar(s ,1) then call tstOut t, 'char' m.s.tok
else call scanErr s, 'cannot scan'
end
call tstEnd t
return
endProcedure tstScanSql
/*--- one single test scan with lines to scan in stem ln -------------*/
tstScan1:
parse arg sc, classs, ln
if sc == '' then do
call tstOut t, 'scan src' ln
call scanSrc scanReset(s), ln
end
else do
call tstOut t, 'scan scanner' sc
s = sc
end
do forever
x = tstScanType(s, classs)
if x == '' then
leave
call tstOut t, 'scan' x 'tok' length(m.s.tok)':' m.s.tok ,
'key' m.s.key 'val' m.s.val
end
return
endProcedure tstScan1
tstScanType: procedure expose m.
parse arg s, opt
cx = 1
a2 = ''
res = 0
do while cx <= length(opt)
f = substr(opt, cx, 1)
cx = cx + 1
if pos(substr(opt, cx, 1), "'""") > 0 then do
m.tstScanType.src = opt
m.tstScanType.pos = cx
call scanString tstScanType
a2 = m.tstScanType.val
cx = m.tstScanType.pos
end
if f == 'a' then
res = scanString(s, "'")
else if f == 'b' then
res = scanSpaceNl(s)
else if f == 'c' then
res = scanChar(s, a2)
else if f == 'd' then
res = scanNat(s, a2)
else if f == 'k' then
res = scanKeyValue(s, 'def')
else if f == 'l' then
res = scanLit(s, a2)
else if f == 'q' then
res = scanString(s, '"')
else if f == 'v' then
res = scanVerify(s, a2)
else if f == 'w' then
res = scanWord(s)
else if f == 'y' then
res = scanVerify(s, a2, 'm')
if res then
return f
end
return scanType(s)
endProcedure tstScanType
/* copx tstBase end *************************************************/
/* copx tst begin ****************************************************
test infrastructure
***********************************************************************/
/*--- migrate all compares to new ones:
tstCI input compare
tstCO ouptut migrated compares
tstCIO inpunt and output -------------------------------------*/
tstCI: procedure expose m.
parse arg m, nm
m.m.CIO = 0
signal tstCIwork
tstCIO: procedure expose m.
parse arg m, nm
m.m.CIO = 1
tstCIwork:
m.m.name = nm
m.m.cmp.1 = left('### start tst' nm '', 67, '#')
do ix=2 to arg()-1
m.m.cmp.ix = arg(ix+1)
end
m.m.cmp.0 = ix-1
if m.m.CIO then
call tstCO m
return
tstCO: procedure expose m.
parse arg m
call tst2dpSay m.m.name, m'.CMP', 68
return
/*--- initialise m as tester with name nm
use inline input nm as compare lines -----------------------*/
tst: procedure expose m.
parse arg m, nm, cmpSt
call tstIni
m.m.name = nm
m.m.inIx = 0
m.m.out.0 = 0
m.m.err = 0
m.tst.act = m
m.tst.tests = m.tst.tests+1
m.m.trans.0 = 0
if cmpSt == '' then do
cmpSt = mCut(t'.CMP', 0)
call tst4dp cmpSt, mapInline(nm)
end
m.m.cmp = cmpSt
call mAdd mCut(m'.IN', 0), 'tst in line 1 eins ,' ,
, 'tst in line 2 zwei ; ' ,
, 'tst in line 3 drei .schluss.'
call tstOut m, left('### start tst' nm '', 67, '#')
call errReset 'h', 'return tstErrHandler(ggTxt)'
if m.tst.ini.j \== 1 then do
call outDest 'i', 'call tstOut' quote(m)', msg'
end
else do
call oMutate m, 'Tst'
m.m.jReading = 1
m.m.jWriting = 1
if m.tst.ini.e \== 1 then do
m.m.oldJin = m.j.jIn
m.m.oldJOut = m.j.jOut
m.j.jIn = m
m.j.jOut = m
end
else do
if m.env.0 <> 1 then
call tstErr m, 'm.env.0' m.env.0 '<> 1'
call envPush '<-%' m, '>-%' m
end
end
return m
endProcedure tst
tstEnd: procedure expose m.
parse arg m, opt
cmp = m.m.cmp
m.m.jReading = 0
m.m.jWriting = 0
m.tst.act = ''
if m.tst.ini.j == 1 then do
m.m.jReading = 0
m.m.jWriting = 0
if m.tst.ini.e \== 1 then do
m.j.jIn = m.m.oldJin
m.j.jOut = m.m.oldJOut
end
else do
if m.j.jIn \== m | m.j.jOut \== m then
call tstErr m, m.j.jIn '\==' m '|' m.j.jOut '\==' m
call envPop
if m.env.0 <> 1 then
call tstErr m, 'm.env.0' m.env.0 '<> 1'
end
end
if m.m.out.0 \= m.cmp.0 then do
call tstErr m, 'old' m.cmp.0 'lines \= new' m.m.out.0
do nx = m.m.out.0 + 1 to min(m.m.out.0+10, m.cmp.0)
say 'old - ' m.cmp.nx
end
end
call errReset 'h'
if m.m.err > 0 then do
say 'new lines:' (m.m.out.0 - 1)
call tst2dpSay m.m.name, m'.OUT', 68
end
say left('###' m.m.name 'end with' m.m.err 'errors ', 67, '#')
return
endProcedure tstEnd
tst2dp: procedure expose m.
parse arg st, dp, ml
dx = m.dp.0
do sx=1 to m.st.0
li = m.st.sx
cx = 1
do until cx > length(li)
c = substr(li, cx, 1)
ou = left('.', strip(c) == '' | pos(c, '.+') > 0)
ex = min(length(li),cx+ml-length(ou)-2)
ou = ou || substr(li, cx, ex+1-cx)
dx = dx + 1
c = right(ou, 1)
if ex < length(li) then
m.dp.dx = ou || '+'
else if strip(c) == '' | pos(c, '.+') > 0 then
m.dp.dx = ou || '.'
else
m.dp.dx = ou
cx = ex +1
end
end
m.dp.0 = dx
return
endProcedure tst2dp
tst2dpSay: procedure expose m.
parse arg name, st, ml
say '/*<<'name
call tst2dp st, mCut('TST.TMP', 0), 68
do nx=1 to m.tst.tmp.0
say ' ' m.tst.tmp.nx
end
say name '*/'
return tst2dpSay
tst4dp: procedure expose m.
parse arg st, dp
sx = m.st.0
inData = 0
data = ''
do dx=1 to m.dp.0
li = strip(m.dp.dx)
if pos(left(li, 1), '.+') > 0 then
li = substr(li, 2)
if right(li, 1) == '+' then do
inData = 1
data = data || left(li, length(li)-1)
iterate
end
if right(li, 1) == '.' then
li = left(li, length(li)-1)
sx = sx + 1
m.st.sx = data || li
inData = 0
data = ''
end
m.st.0 = sx
if inData then
call err 'end inData'
return
endProcedure tst4dp
/*--- write to test: say lines and compare them ----------------------*/
tstWrite: procedure expose m.
parse arg m, arg
call tstOut m, 'jOut:' arg
return
endProcedure tstWrite
tstOut: procedure expose m.
parse arg m, arg
do tx=m.m.trans.0 by -1 to 1
arg = repAll(arg, word(m.m.trans.tx, 1), subword(m.m.trans.tx, 2))
end
call mAdd m'.OUT', arg
nx = m.m.out.0
cmp = m.m.cmp
c = m.cmp.nx
if nx > m.cmp.0 then do
if nx = m.cmp.0+1 then
call tstErr m, 'more new Lines' nx
end
else if c \== arg then do
do cx=1 to min(length(c), length(arg)) ,
while substr(c, cx, 1) == substr(arg, cx, 1)
end
msg = 'old line' nx '<> new overnext, firstDiff' cx',',
'len old' length(c)', new' length(arg)
if cx > 10 then
msg = overlay('|', msg, cx-10)
call tstErr m, msg
say c
end
say arg
return 0
endProcedure tstOut
tstWriteR: procedure expose m.
parse arg m, var
if symbol('m.class.o2c.var') \== 'VAR' then
call tstOut t, m.var
else do
oo = outDest('=')
call outDest 'i', 'call tstOut "'m'", msg'
call classOut , var, 'tstR: '
call outDest 'i', oo
end
return
endProcedure tstWriteR
tstRead: procedure expose m.
parse arg m, arg
ix = m.m.inIx + 1
m.m.inIx = ix
if ix <= m.m.in.0 then do
m.arg = m.m.in.ix
drop m.class.o2c.arg
call tstOut m, '#jIn' ix'#' m.arg
return 1
end
call tstOut m, '#jIn eof' ix'#'
return 0
endProcedure tstRead
tstFilename: procedure
parse arg suf, opt
os = errOS()
if os == 'TSO' then do
dsn = dsn2jcl('~tmp.tst.'suf)
if opt = 'r' then do
if sysDsn("'"dsn"'") \== 'DATASET NOT FOUND' then
call adrTso "delete '"dsn"'"
end
call csiOpen 'TST.CSI', dsn'.**'
do while csiNext('TST.CSI', 'TST.FINA')
say 'deleting csiNext' m.tst.fina
call adrTso "delete '"m.tst.fina"'"
end
end
return dsn
end
else if os == 'LINUX' then do
if abbrev(suf, '/') then
fn = suf
else
fn = .Stream$mc$new('~/tmp/tst/'suf)$mc$qualify /* full path */
if opt \= 'r' then
nop
else if sysIsFile(fn) then
call sysFileDelete fn
else if sysIsFileDirectory(fn) then
call adrSh 'rm -r' fn
return fn
end
else
call err 'tstFilename does not implement os' os
endProcedure tstFilename
/*--- say total errors and fail if not zero --------------------------*/
tstTotal: procedure expose m.
say '######'
say '######'
say '######' m.tst.tests 'tests with' ,
m.tst.err 'errors in' m.tst.errNames
say '######'
say '######'
if m.tst.err \== 0 then
call err m.tst.err 'errors total'
return
endProcedure tstTotal
/*--- test err: message, count it and continue -----------------------*/
tstErr: procedure expose m.
parse arg m, msg
say '### error' msg
m.m.err = m.m.err + 1
m.tst.err = m.tst.err + 1
nm = m.m.name
if wordPos(nm, m.tst.errNames) < 1 then
m.tst.errNames = m.tst.errNames nm
return
endProcedure tstErr
/*--- tstErrHandler: intercept errors --------------------------------*/
tstErrHandler: procedure expose m.
parse arg ggTxt
if m.tst.act == '' then
call err ggTxt
m.tstErrHandler.0 = 0
oo = outDest('=')
call outDest 's', tstErrHandler
call errSay ggTxt
call outDest 'i', oo
call tstOut m.tst.act, '*** err:' m.tstErrHandler.1
do x=2 to m.tstErrHandler.0
call tstOut m.tst.act, ' e' (x-1)':' m.tstErrHandler.x
end
return 0
endSubroutine tstErrHandler
/*--- tstIni: global initialization ----------------------------------*/
tstIni: procedure expose m.
if m.tst.ini \== 1 then do
m.tst.ini = 1
call mapIni
m.tst.err = 0
m.tst.errNames = ''
m.tst.tests = 0
m.tst.act = ''
end
if m.tst.ini.j \== 1 & m.j.ini == 1 then do
m.tst.ini.j = 1
call classNew 'n Tst u JRW', 'm',
, "jRead return tstRead(m, var)",
, "jWrite call tstOut m, line",
, "jWriteR call tstWriteR m, var"
end
if m.tst.ini.e \== 1 & m.env.ini == 1 then do
m.tst.ini.e = 1
end
return
endProcedure tstIni
/* copx tst end **************************************************/
/* copx tstData begin *************************************************/
tstData: procedure expose m.
parse arg ty 2 le 'n' nu, l, r, num
abs = abs(num)
if nu \== '' then do
if abs // 5 = 0 then
return 'null' || (abs % 5 // nu + 1)
end
if ty = 'c' then do
if le = '' then
le = 8
le = abs // le + 1
if r = '' then
r = '+'
return left(l || num || r, le, right(r, 1))
end
if pos(ty, 'ief') < 1 then
call err 'bad type' ty
nn = abs
if abbrev(num, '-') | abbrev(num, '+') then
parse var num si 2 nn
else
si = ''
if ty == 'e' then
ex = 'e' || left('-', abs // 2) || (abs // 15)
else
ex = ''
if le \== '' then
nn = right(nn, abs // max(1, le - length(si||ex)) + 1, 1)
if ty \== 'i' & (abs // 4) \= 0 & length(nn) > 1 then
nn = overlay('.', nn, length(nn) - abs // length(nn))
return si || nn || ex
endProcedure tstData
tstDataClassFo: procedure expose m.
parse arg flds
ty = ''
do fx=1 by 2 to words(flds)
if word(flds, fx) = '.' then
ty = ty', v'
else
ty = ty', f' word(flds, fx) 'v,'
end
t = classNew('n tstData* u' substr(ty, 2))
fo = oNew(m.t.name)
fs = oFlds(fo)
do fx=1 to m.fs.0
f = fo || m.fs.fx
m.f = word(flds, 2*fx)
end
return fo
endProcedure tstDataClassFo
tstDataClassOut: procedure expose m.
parse arg flds, f, t
fo = tstDataClassFo(flds)
fs = oFlds(fo)
do x=f to t
o = oCopyNew(fo)
do fx=1 to m.fs.0
na = substr(m.fs.fx, 2)
f = o || m.fs.fx
m.f = tstData(m.f, na, '+'na'+', x)
end
call jOuR o
end
return
endProcedure tstDataClassOut
/* copx tstData end ***************************************************/
/* copy tstAll end **************************************************/
/* copy fmt begin **************************************************/
/*--- format the first arg by the format in the second ---------------*/
fmt: procedure
parse arg v, f 2 l
/* say 'fmt' v',' f l */
if abbrev('-', f) then
return v
else if f == 'l' then
return left(v, l)
else if f == 'r' then
return right(v, l)
else if f == 'f' then do
parse value l'.0.0.' with b '.' a '.' e '.'
return format(v, b, a, e, 0)
end
else if f == 'e' then do
parse var l b '.' a '.' e '.'
if b == '' then b = 2
if a == '' then a = 2
if e == '' then e = 2
res = format(v, b, a, e, 0)
y = length(res)-e-1
if substr(res, y) = '' then
return left(res, y-1)left('E', e+1, 0)
else if substr(res, y+1, 1) == '+' then
return left(res, y)substr(res, y+2)
else if substr(res, y+2, 1) == '0' then
return left(res, y+1)substr(res, y+3)
else
call err 'formatoverflow' f || l 'for' v '-->' res
end
else if f = 's' then
if l == '' then
return strip(v, 't')
else
return strip(v, l)
else if f == 'w' then do
parse var l st ',' le
return substr(v, st, le)
end
else
call err 'bad format' f l 'for' v
endProcedure fmt
/*--- format special (title, null Value also for numbers) ------------*/
fmtS: procedure expose m.
parse arg v, ty 2 l
if ty == 'f' then do
if \ dataType(v, 'n') then do
parse value l'.0.0.' with b '.' a '.' e '.'
return right(v, b + a + (a \== 0) + e + 2 * (e > 0))
end
end
else if ty == 'e' then do
if \ dataType(v, 'n') then do
parse var l b '.' a '.' e '.'
if b == '' then b = 2
if a == '' then a = 2
if e == '' then e = 2
return right(v, b + a + (a \== 0) + e + (e > 0))
end
end
return fmt(v, ty || l)
endProcedure fmtS
/* copy fmt end **************************************************/
/* copy fmtF begin **************************************************/
fmtFCsvAll: procedure expose m.
parse arg fSep
if fSep = '' then
fSep = ','
if \ jIn(i) then
return
f = oFlds(i)
li = ''
do fx=1 to m.f.0
li = li',' substr(m.f.fx, 2)
end
call jout substr(li, 3)
do until \ jIn(i)
li = ''
do fx=1 to m.f.0
if m.f.fx = '' then do
li = li',' m.i
end
else do
fld = substr(m.f.fx, 2)
li = li',' m.i.fld
end
end
call jout substr(li, 3)
end
return
endProcedure fmtFCsvAll
fmtFAdd: procedure expose m.
parse arg m
fx = m.m.0
do ax=2 to arg()
fx = fx + 1
parse value arg(ax) with m.m.fx.fld m.m.fx.fmt m.m.fx.tit
end
m.m.0 = fx
return m
endProcedure fmtFAdd
fmtFAddFlds: procedure expose m.
parse arg m, st
fx = m.m.0
do sx=1 to m.st.0
fx = fx + 1
parse value m.st.sx with m.m.fx.fld m.m.fx.fmt m.m.fx.tit
end
m.m.0 = fx
return m
endProcedure fmtFAddFlds
fmtF: procedure expose m.
parse arg m, st
if arg() >= 3 then
mid = arg(3)
else
mid = ' '
li = ''
do fx=1 to m.m.0
f = st || m.m.fx.fld
li = li || mid || fmtS(m.f, m.m.fx.fmt)
end
return substr(li, 1 + length(mid))
endProcedure fmtF
fmtFReset: procedure expose m.
parse arg m
m.m.0 = 0
return m
endProcedure fmtFReset
fmtFWriteAll: procedure expose m.
parse arg m, optRdr, wiTi
b = env2buf(optRdr)
st = b'.BUF'
if m.st.0 < 1 then
return
if m.m.0 < 1 then
call fmtFAddFlds m, oFlds(st'.1')
call fmtFDetect m, st
if wiTi \== 0 then
call jOut fmtFTitle(m)
do sx=1 to m.st.0
call jOut fmtF(m, st'.'sx)
end
return
fmtFWriteAll
fmtFTitle: procedure expose m.
parse arg m
if arg() >= 2 then
mid = arg(2)
else
mid = ' '
li = ''
do fx=1 to m.m.0
if m.m.fx.tit \= '' then
t = m.m.fx.tit
else if m.m.fx.fld = '' then
t = '='
else
t = substr(m.m.fx.fld, 1+abbrev(m.m.fx.fld, '.'))
li = li || mid || fmtS(t, m.m.fx.fmt)
end
return substr(li, 1 + length(mid))
res = ''
fs = m.form.FLDS
do ix=1 to m.fs.0
res = res fmtS(m.fs.ix, m.form.ix)
end
return substr(res, 2)
endProcedure fmtFldTitle
fmtFldTitle: procedure expose m.
parse arg form
res = ''
fs = m.form.FLDS
do ix=1 to m.fs.0
res = res fmtS(m.fs.ix, m.form.ix)
end
return substr(res, 2)
endProcedure fmtFldTitle
fmtFld: procedure expose m.
parse arg form, st
res = ''
fs = m.form.FLDS
do ix=1 to m.fs.0
f = m.fs.ix
res = res fmt(m.st.f, m.form.ix)
end
return substr(res, 2)
endProcedure fmtData
fmtFldSquash: procedure expose m.
parse arg newFo, class, src
fs = oFlds(class)
do fx = 1 to m.fs.0
fd = m.fs.fx
lMi = 9e9
lMa = 0
rMi = 9e9
rMa = 0
len = 0
do sx = 1 to m.src.0
x = verify(m.src.sx.fd, ' ', 'n')
if x < 1 then
iterate
lMi = min(lMi, x)
lMa = max(lMa, x)
x = length(strip(m.src.sx.fd, 't'))
rMi = min(rMi, x)
rMa = max(rMa, x)
end
if rMa = 0 then
m.newFo.fx = 'w1,1'len
else
m.newFo.fx = 'w'lMi',' || (rMa+1-lMi)
end
m.newFo.0 = m.fs.0
m.newFo.flds = fs
return newFo
endProcedure fmtFldSquash
fmtFDetect: procedure expose m.
parse arg m, st
do fx=1 to m.m.0
if m.m.fx.fmt = '' then
m.m.fx.fmt = fmtFDetect1(st, m.m.fx.fld)
end
return m
endProcedure fmtDetect
fmtFDetect1: procedure expose m.
parse arg st, suf
aMa = -1
aCnt = 0
aDiv = 0
nCnt = 0
nMi = ''
nMa = ''
nDi = -1
nBe = -1
nAf = -1
eMi = ''
eMa = ''
do sx=1 to m.st.0
f = st'.'sx || suf
v = m.f
aMa = max(aMa, length(v))
if \ dataType(v, 'n') then do
aCnt = aCnt + 1
if aDiv <=3 then
if aDiv.v \== 1 then do
aDiv.v = 1
aDiv = aDiv + 1
end
iterate
end
nCnt = nCnt + 1
if nMi == '' then
nMi = v
else
nMi = min(nMi, v)
if nMa == '' then
nMa = v
else
nMa = max(nMa, v)
parse upper var v man 'E' exp
if exp \== '' then do
en = substr(format(v, 2, 2, 9, 0), 7)
if en = '' then
en = exp
if eMi == '' then
eMi = en
else
eMi = min(eMi, en)
if eMa == '' then
eMa = en
else
eMa = max(eMa, en)
end
parse upper var man be '.' af
nBe = max(nBe, length(be))
nAf = max(nAf, length(af))
nDi = max(nDi, length(be || af))
end
/* say 'suf' suf aCnt 'a len' aMa 'div' aDiv
say ' ' nCnt 'n' nMi'-'nMa 'be' nBe 'af' nAf 'di' nDi 'ex' eMi'-'eMa
*/ if nCnt = 0 | aDiv > 3 then
newFo = 'l'max(0, aMa)
else if eMi \== '' then do
eMa = max(eMa, substr(format(nMa, 2, 2, 9, 0), 7))
newFo = 'e' || (1+(eMi < 0)) || '.' || (max(0, nDi-1))'.' ,
|| max(length(eMa+0), length(eMi+0))
end
else if nAf > 0 then
newFo ='f'nBe'.'nAf
else
newFo ='f'nBe'.0'
/* say ' ' newFo
*/ return newFo
endProcedure fmtFDetect1
fmtFldRW: procedure expose m.
parse arg fo
ty = oGetClassPara(m.j.jIn)
call assert 'oFlds(ty) == m.fo.flds', 'fo different flds than class'
call jOut fmtFldTitle(fo)
do while jIn(ii)
call jOut fmtFld(fo, ii)
end
return
endProcedure fmtClassRW
fmtFldSquashRW: procedure expose m.
parse arg in, opCl
if in = '' then
in = m.j.jIn
if opCl == 'opCl' then
call jOpen in, 'r'
ty = oGetClassPara(in)
flds = oFlds(ty)
st = 'FMT.CLASSAD'
do ix=1 while jRead(in, st'.'ix)
end
m.st.0 = ix - 1
fo = fmtFldSquash(sqFo, ty, st)
call jOut fmtFldTitle(fo)
do ix = 1 to m.st.0
call jOut fmtFld(fo, st'.'ix)
end
if opCl == 'opCl' then
call jClose in
return
endProcedure fmtFldSquashRW
/* copy fmtF end * **************************************************/
/* copy sort begin ****************************************************/
sort: procedure expose m.
parse arg i, o, cmp
if cmp == '' then
m.sort.comparator = "cmp = m.l.l0 <<= m.r.r0"
else if length(cmp) < 6 then
m.sort.comparator = "cmp = m.l.l0" cmp "m.r.r0"
else if pos(';', cmp) < 1 then
m.sort.comparator = "aLe = l'.'l0; aRi = r'.'r0; cmp =" cmp
else
m.sort.comparator = "aLe = l'.'l0; aRi = r'.'r0;" cmp
call sort1 i, 1, m.i.0, o, 1, sort.work, 1
m.o.0 = m.i.0
return
endProcedure sort
sort1: procedure expose m.
parse arg i, i0, le, o, o0, w, w0
if le <= 3 then do
if le = 3 then do
call sortMerge i, i0, i0+1, i, i0+1, i0+2, w, w0
call sortMerge i, i0+2, i0+3, w, w0, w0+2, o, o0
end
else if le = 2 then
call sortMerge i, i0, i0+1, i, i0+1, i0+2, o, o0
else if le = 1 then
m.o.o0 = m.i.i0
return
end
h = (le + 1) % 2
call sort1 i, i0, h, o, o0+le-h, w, w0
call sort1 i, i0+h, le-h, w, w0, o, o0
call sortMerge o, o0+le-h, o0+le, w, w0, w0+le-h, o, o0
return
endProcedure sort1
sortMerge: procedure expose m.
parse arg l, l0, le, r, r0, re, o, o0
do while l0 < le & r0 < re
interpret m.sort.comparator
if cmp then do
m.o.o0 = m.l.l0
l0 = l0 + 1
end
else do
m.o.o0 = m.r.r0
r0 = r0 + 1
end
o0 = o0 + 1
end
do while l0 < le
m.o.o0 = m.l.l0
l0 = l0 + 1
o0 = o0 + 1
end
do while r0 < re
m.o.o0 = m.r.r0
r0 = r0 + 1
o0 = o0 + 1
end
return
endProcedure sortMerge
/* copy sort end ****************************************************/
/* copy match begin ***************************************************/
/************************************* begin copy match ******/
/*--- wildCard matching with the following wildchars:
* 0-n chars
? 1 char
fill matched expressions instem st if st is non empty
return 1 if mask matches wert ----------------------------------*/
match: procedure expose m.
parse arg wert, mask, st
if st == '' then
return matchRO(wert, mask)
m.st.0 = -9
return matchSt(wert, mask, st, 0)
endProcedure match
/*--- return the fixed prefix of maskt -------------------------------*/
matchPref: procedure
arg mask, suff
ix = verify(mask, '*?', 'm')
if ix = 0 then
return mask
else
return left(mask, ix-1)suff
endProcedure matchPref
/*--- return true if mask matches wert -------------------------------*/
matchRO: procedure
arg wert, mask
ix = verify(mask, '*?', 'm')
if ix < 1 then return (mask == wert)
if length(wert) < ix-1 then return 0
if left(mask, ix-1) \== left(wert, ix-1) then return 0
if substr(mask, ix, 1) == '?' then do
if length(wert) < ix then return 0
return matchRO(substr(wert, ix+1), substr(mask, ix+1))
end
mask = substr(mask, ix+1) /* * 0 - n Chars */
do ex = 1+length(wert) to ix by -1
if matchRO(substr(wert, ex), mask) then return 1
end
return 0
endProcedure matchRO
/*--- wildCard matching: fill matched expressions instem st
return 1 if mask matches wert ----------------------------------*/
matchSt: procedure expose m.
parse arg wert, mask, st, sx
ix = verify(mask, '*?', 'm')
if ix < 1 then do
if mask \== wert then
return 0
m.st.0 = sx
return 1
end
if \ abbrev(wert, left(mask, ix-1)) then
return 0
reMa = substr(mask, ix+1)
sx = sx + 1
if substr(mask, ix, 1) == '?' then do /* ? 1 Character */
if length(wert) < ix then
return 0
m.st.sx = substr(wert, ix, 1)
return matchSt(substr(wert, ix+1), reMa, st, sx)
end
do lx = 1+length(wert) to ix by -1 /* greedy: from all to empty */
if matchSt(substr(wert, lx), reMa, st, sx) then do
m.st.sx = substr(wert, ix, lx-ix)
return 1
end
end
return 0
endProcedure matchSt
matchTrans: procedure expose m.
parse arg mask, st
r = ''
ox = 1
sx = 0
ix = verify(mask, '*?', 'm')
do sx=1 to m.st.0 while ix > 0
if sx > m.st.0 then
call err 'matchTrans('mask',' st') has only' ,
m.st.0 'variables'
r = r || substr(mask, ox, ix-ox)m.st.sx
ox = ix+1
ix = verify(mask, '*?', 'm', ox)
end
if ix > 0 then
call err 'matchTrans('mask',' st') has only' ,
m.st.0 'variables'
return r || substr(mask, ox)
endProcedure matchTrans
/* copy match end *****************************************************/
/* copy comp begin *****************************************************
the shell compiler
syntax and semantics of the shell language see javaDoc
***********************************************************************/
/*--- module initialisation ------------------------------------------*/
compIni: procedure expose m.
if m.compIni = 1 then
return
m.compIni = 1
call envIni
call scanReadIni
cc = classNew('n Compiler u')
return
endProcedure compIni
/*--- constructor of Compiler ----------------------------------------*/
comp: procedure expose m.
parse arg src
nn = oNew('Compiler')
m.nn.scan = jOpen(scanRead(src))
return compReset(nn, src)
endProcedure comp
compReset: procedure expose m.
parse arg m, src
call scanReadReset m.m.scan, src, , ,'$*'
m.m.chDol = '$'
m.m.chSpa = ' '
m.m.chNotWord = '${}=%:' || m.m.chSpa
m.m.stack = 0
return m
endProceduere compReset
/*--- push an empty stem on the stack --------------------------------*/
compPushStem: procedure expose m.
parse arg m
m.m.stack = m.m.stack + 1
pp = m'.STACK'm.m.stack
m.pp.0 = 0
return pp
endProcedure compPushStem
/*--- push a stem from the stack -------------------------------------*/
compPop: procedure expose m.
parse arg m, pp
if pp \== m'.STACK'm.m.stack then
call err 'compPop pp' pp 'mismatch to' m'.STACK'm.m.stack
m.m.stack = m.m.stack - 1
return m
endProcedure compPop
/*--- compile the source and return an oRunner with the code ---------*/
compile: procedure expose m.
parse arg m, type
if type == 's' then do
what = "shell"
expec = "pipe or $;";
call compSpNlComment m
src = compShell(m)
end
else if type == 'd' then do
what = "data";
expec = "sExpression or block";
src = compData(m, 0)
end
else do
call err "bad type" type
end
if \ scanAtEnd(m.m.scan) then
call scanErr m.m.scan, expec "expected: compile" what ,
" stopped before end of input"
call jClose m.m.scan
r = oRunner(src)
return r
endProcedure compile
/*--- compile data lines return stmts or expr ------------------------*/
compData: procedure expose m.
parse arg m, makeExpr
s = m.m.scan
exprs = compPushStem(m)
do forever
aftEol = 0
do forever
text = "";
do forever
if scanVerify(s, m.m.chDol, 'm') then
text = text || m.s.tok
if \ compComment(m) then
leave
end
nd = compExpr(m, 'd')
befEol = scanReadNL(s)
if nd <> '' | (aftEol & befEol) ,
| verify(text, m.m.chSpa) > 0 then do
if text \== '' then
text = quote(text)
if text \== '' & nd \= '' then
text = text '|| '
call mAdd exprs, 'e' compNull2EE(text || nd)
end
if \ befEol then
leave
aftEol = 1
end
one = compStmt(m)
if one == '' then
one = compRedirIO(m, 0)
if one == '' then
leave
call mAdd exprs, 's' one
end
if m.exprs.0 < 1 then do
if makeExpr then
res = '""'
else
res = ';'
end
else do
do x=1 to m.exprs.0 while left(m.exprs.x, 1) = 'e'
end
res = ''
if makeExpr & x > m.exprs.0 then do
res = substr(m.exprs.1, 3)
do x=2 to m.exprs.0
res = res substr(m.exprs.x, 3)
end
end
else do
do x=1 to m.exprs.0
if left(m.exprs.x, 1) = 'e' then
res = res 'call jOut'
res = res substr(m.exprs.x, 3)';'
end
if makeExpr then
res = "mCat("compStmts2ExprBuf(res)"'.BUF', ' ')"
end
end
call compPop m, exprs
return res
endProcedure compData
/*--- compile shell and return code ----------------------------------*/
compShell: procedure expose m.
parse arg m
res = ''
do forever
one = compPipe(m)
if one \== '' then
res = res one
if \ scanLit(m.m.scan, '$;') then
return strip(res)
call compSpNlComment m
end
endProcedure compShell
/*--- compile an expression, type d=data, w=word, s=strip ------------*/
compExpr: procedure expose m.
parse arg m, type
res = ''
if type == 'w' then
charsNot = m.m.chNotWord
else
charsNot = m.m.chDol
s = m.m.scan
if pos(type, 'sw') > 0 then
call compSpComment m
do forever
txt = ''
do forever
if scanVerify(s, charsNot, 'm') then
txt = txt || m.s.tok
if \ compComment(m) then
leave
end
pr = compPrimary(m)
if pr = '' & pos(type, 'sw') > 0 then
txt = strip(txt, 't')
if txt \== '' then
res = res '||' quote(txt)
if pr = '' then do
if pos(type, 'sw') > 0 then
call compSpComment m
if res == '' then
return ''
return substr(res, 5)
end
res = res '||' pr
end
return ''
endProcedure compExpr
/*--- push an empty stem on the stack --------------------------------*/
compPushStem: procedure expose m.
parse arg m
m.m.stack = m.m.stack + 1
pp = m'.STACK'm.m.stack
m.pp.0 = 0
return pp
endProcedure compPushStem
/*--- push a stem from the stack -------------------------------------*/
compPop: procedure expose m.
parse arg m, pp
if pp \== m'.STACK'm.m.stack then
call err 'compPop pp' pp 'mismatch to' m'.STACK'm.m.stack
m.m.stack = m.m.stack - 1
return m
endProcedure compPop
/*--- compile a primary and return code ------------------------------*/
compPrimary: procedure expose m.
parse arg m
s = m.m.scan
if \ scanLit(s, '$') then
return ''
if scanString(s) then
return m.s.tok
if scanLit(s, '(') then do
one = compCheckNN(m, compLang(m, 0), 'rexx expexted after $(')
if \ scanLit(s, '$)') then
call scanErr s, 'closing $) missing after $(...'
return '('one')'
end
if scanLit(s, '-¢') then do
res = compData(m, 1)
if \scanLit(s, '$!') then
call scanErr s, 'closing $! missing after $-¢ data'
return res
end
if scanLit(s, '-{') then do
res = compShell(m)
if \scanLit(s, '$}') then
call scanErr s, 'closing $} missing after $-{ shell'
return "mCat("compStmts2ExprBuf(res)"'.BUF', ' ')"
end
if scanLit(s, '-cmpShell', '-cmpData') then do
return 'compile(comp(env2Buf()),' ,
'"'substr('ds', 1+(m.s.tok == '-cmpShell'), 1)'")'
end
if scanLit(s, '{') then do
if scanLit(s, '?') then
f = 'envIsDefined'
else if scanLit(s, '>') then
f = 'envRead'
else
f = 'envGet'
nm = compExpr(m, 'w')
if \scanLit(s, '}') then
call scanErr s, 'closing } missing after ${'
return f'('nm')'
end
if scanName(s) then
return 'envGet('quote(m.s.tok)')'
call scanBack s, '$'
return ''
endProcedure compPrimary
/*--- compile a pipe and return code ---------------------------------*/
compPipe: procedure expose m.
parse arg m
s = m.m.scan
ios = ''
stmts = ''
stmtLast = ''
do forever
io1 = compRedirIO(m, 1)
if io1 \== '' then do
ios = ios',' io1
call compSpNlComment m
end
else do
if stmtLast \== '' then do
if \ scanLit(s, '$|') then
leave
call compSpNlComment m
end
one = compStmts(m)
if one == '' then do
if stmtLast \== '' then
call scanErr s, 'stmts expected afte $|'
if ios == '' then
return ''
leave
end
if stmtLast \== '' then
stmts = stmts 'call envBar;' stmtLast
stmtLast = one
end
end
if stmts \== '' then
stmtLast = insert('Begin', stmts, pos('envBar;', stmts)+5) ,
'call envBarLast;' stmtLast 'call envBarEnd;'
if ios \== '' then do
if stmtLast == '' then
stmtLast = 'call envWriteAll;'
stmtLast = 'call envPush 'substr(ios, 3)';' stmtLast ,
'call envPop;'
end
return stmtLast
endProcedure compPipe
/*--- compile an io redirection, return
if makeExpr then "option", expr
else code write inut to standard out -------------*/
compRedirIO: procedure expose m.
parse arg m, makeExpr
s = m.m.scan
if \ scanLit(s, '$&', '$<<', '$<', '$>>', '$>') then
return ''
opt = substr(m.s.tok, 2)
call scanVerify s, '+-%#¢{'
opt = opt || m.s.tok
/* ???? call compSpComment m */
if left(opt, 2) \== '<<' then do
if verify(opt, '¢{', 'm') > 0 ,
| (left(opt, 1) == '&' & pos('%', opt) > 0) then
call scanErr s, 'inconsistent io redirection option' opt
ex = compCheckNN(m, compExpr(m, 's'),
, 'expression expected after $'opt)
end
else do
if verify(opt, '-%#', 'm') > 0 then
call scanErr s, 'inconsistent io redirection option' opt
if \ scanName(s) then
call scanErr s, 'stopper expected in heredata after $'opt
stopper = m.s.tok
call scanVerify s, m.m.chSpa
if \ scanReadNl(s) then
call scanErr s,
, 'space nl expected in heredata after $'opt||stopper
buf = jOpen(jBuf(), m.j.cWri)
do while \ scanLit(s, stopper)
call jWrite buf, m.s.src
if \ scanReadNl(s, 1) then
call scanErr s, 'eof in heredata after $'opt||stopper
end
call jClose buf
if verify(opt, '¢{', 'm') > 0 then do
if pos('¢', opt) > 0 then
ex = compile(comp(buf), 'd')
else
ex = compile(comp(buf), 's')
if makeExpr then
return "'<%' envRun("quote(ex)")"
else
return "call oRun" quote(ex)";"
end
opt = '<%'
ex = quote(buf)
end
if makeExpr then
return "'"opt"'" ex
else if left(opt, 1) = '>' then
call scanErr s, 'cannot write ioRedir $'opt
else
return "call envWriteAll '"opt"'" ex
endProcedure compRedirIO
/*--- compile stmts (stmt or java) -----------------------------------*/
compStmts: procedure expose m.
parse arg m
res = ''
do forever
one = compStmt(m)
if one == '' then
one = compLang(m, 1)
if one == '' then
return res
res = res strip(one)
call compSpNlComment m
end
endProcedure compStmts
/*--- compile a single statement -------------------------------------*/
compStmt: procedure expose m.
parse arg m
s = m.m.scan
if scanLit(s, "$=") then do
nm = compCheckNN(m, compExpr(m, 'w'), "variable name")
if scanLit(s, "=") then
vl = compExpr(m, 's')
else if scanLit(s, "%") then
vl = compCheckNN(m, compLang(m, 0),
, 'java expression after $= .. %')
else
call scanErr s, '= or % expected after $= name'
return 'call envPut' nm',' vl';'
end
else if scanLit(s, '$@{') then do
call compSpNlComment m
one = compShell(m)
if \ scanLit(s, "$}") then
call scanErr s, "closing $} missing for $@{ shell"
return "do;" one "end;"
end
else if scanLit(s, '$@¢') then do
call compSpNlComment m
one = compData(m, 0)
if \ scanLit(s, "$!") then
call scanErr s, "closing $! missing for $@! data"
return "do;" one "end;"
end
else if scanLit(s, '$$') then do
return 'call jOut' compExpr(m, 's')';'
end
else if scanLit(s, '$%') then do
return 'call jOut' compCheckNN(m, compLang(m, 0),
, 'language expression after $%')';'
end
else if scanLit(s, '$@for') then do
v = compCheckNN(m, compExpr(m, 'w') ,
, "variable name after $@for")
call compSpNlComment m
return 'do while envRead('v');',
compCheckNN(m, compStmt(m),
, "statement after $@for variable") 'end;'
end
else if scanLit(s, '$@run') then do
return 'call oRun' compCheckNN(m, compExpr(m, 's'),
, 'expression after $@run') ';'
end
return ''
endProcedure compStmt
/*--- compile a language clause
multi=0 a single line for a rexx expression
multi=1 mulitple lines for rexx statements
(with rexx line contiunation) -----------------------*/
compLang: procedure expose m.
parse arg m, multi
s = m.m.scan
res = ''
do forever
if scanVerify(s, m.m.chDol, 'm') then do
res = res || m.s.tok
end
else do
one = compPrimary(m)
if one \== '' then
res = res || one
else if compComment(m) then
res = res || ' '
else if \multi then
return res
else if \ scanReadNl(s) then do
if res == '' then
return res
else
return strip(res)';'
end
else do
res = strip(res)
if right(res, 1) = ',' then
res = strip(left(res, length(res)-1))
else
res = res';'
end
end
end
endProcedure compLang
/*--- convert stmts to an expression yielding the output ------------*/
compStmts2ExprBuf: procedure expose m.
parse arg stmts
rr = oRunner(stmts)
return "envRun('"rr"')"
endProcedure compStmts2ExprBuf
/*--- convert '' to an empty expression ------------------------------*/
compNull2EE: procedure
parse arg e
if e = '' then
return '""'
return e
endProcedure compNull2EE
/*--- if va == '' then issue an error with msg -----------------------*/
compCheckNN: procedure expose m.
parse arg m, va, msg
if va == '' then
call scanErr m.m.scan, msg 'expected'
return va
endProcedure compCheckNN
/*--- skip a comment. return 0 if there is none ----------------------*/
compComment: procedure expose m.
parse arg m
s = m.m.scan
if scanLit(s, '$**') then
m.s.pos = 1 + length(m.s.src) /* before next nl */
else if scanLit(s, '$*+') then
call scanReadNl s, 1
else if scanLit(s, '$*(') then do
do forever
if scanVerify(s, m.m.chDol, 'm') then iterate
if scanReadNl(s) then iterate
if compComment(m) then iterate
if \ scanLit(s, '$') then
call scanErr s, 'source end in comment'
if scanLit(s, '*)') then
return 1
if scanLit(s, '$') then iterate
if scanString(s) then iterate
end
end
else
return 0
return 1
endProcedure compComment
/*--- skip spaces and comments ---------------------------------------*/
compSpComment: procedure expose m.
parse arg m
found = 0
do forever
if scanVerify(m.m.scan, m.m.chSpa) then
found = 1
else if compComment(m) then
found = 1
else
return found
end
endProcedure compSpComment
/*--- skip spaces, NLs and comments ----------------------------------*/
compSpNlComment: procedure expose m.
parse arg m
found = 0
do forever
if compSpComment(m) then
found = 1
else if scanReadNl(m.m.scan) then
found = 1
else
return found
end
endProcedure compSpComment
/* copy comp end ******************************************************/
/* copy scan begin ****************************************************
Scan: scan an input:
scanLine(m,ln) : begin scanning a single line (string)
scanRead??(m,ln): begin scanning all lines of an opened reader
scanAtEnd(m) : returns whether we reached end of input
scanLit(m,lit) : scan Literal lit if present or return 0
scanChar(m,n) : scan next n characters
scanName(m) : scan a name
ScanNat(m) : scan a natural number (without sign)
scanString(m,q): scan a String with quote q. (with doubble = 1)
scanVerify(m,c,o): verify(...,c,o,...)
scanKeyValue(m): scan a key = value clause (with spaces)
scanWord(m,u) : scan a space delimited word or a string,
if u=1 then uppercase non-strings
scanErr(m, txt): error with current scan location
m is an adress, to store our state
if a scan function succeeds, the scan posititon is moved
returns: true if scanned, false otherwise
m.m.tok ==> last token
m.m.val ==> last value for scanString/Word/KeyValue
m.key ==> key for scanKeyValue
m.m.pos ==> scan position
m.m.src ==> scan source
***********************************************************************/
scanIni: procedure expose m.
if m.scan.ini == 1 then
return
m.scan.ini = 1
m.scan.alfLC = 'abcdefghijklmnopqrstuvwxyz'
m.scan.alfUC = translate(m.scan.alfLC)
m.scan.alfa = m.scan.alfLC || m.scan.alfUC
m.scan.alfNum = m.scan.alfa || '0123456789'
return
endProcedure scanIni
scanReset: procedure expose m.
parse arg m, n1, np, co
m.m.rdr = ''
m.m.jReading = 0 /* if called without jReset */
m.m.jWriting = 0
return scanOpts(m, n1, np, co)
endProcedure scanReset
scanOpts: procedure expose m.
parse arg m, m.m.scanName1, namePlus, m.m.scanComment
if m.m.scanName1 == '' then
m.m.scanName1 = m.scan.alfa
if namePlus == '' then
m.m.scanNameR = m.m.scanName1 || '0123456789'
else
m.m.scanNameR = m.m.scanName1 || namePlus
return m
endProcedure scanOpts
/*--- begin scanning a single line -----------------------------------*/
scanSrc: procedure expose m.
parse arg m, m.m.src
return scanOpen(m)
endProcedure scanSrc
scanOpen: procedure expose m.
parse arg m
m.m.tok = ''
m.m.val = ''
m.m.key = ''
m.m.pos = 1
m.m.atEnd = m.m.rdr == ''
m.m.jReading = 1
return m
endProcedure scanOpen
/*--- return the next len characters ---------------------------------*/
scanLook: procedure expose m.
parse arg m, len
if len == '' then
return substr(m.m.src, m.m.pos)
else
return substr(m.m.src, m.m.pos,
, min(len, 1 + length(m.m.src) - m.m.pos))
endProcedure scanLook
/*--- scan the literal lit ------------------------------------------*/
scanLit: procedure expose m.
parse arg m
do ax=2 to arg()
if abbrev(substr(m.m.src, m.m.pos), arg(ax)) then do
m.m.tok = arg(ax)
m.m.pos = m.m.pos + length(arg(ax))
return 1
end
end
m.m.tok = ''
return 0
endProcedure scanLit
/*--- scan the next len characters -----------------------------------*/
scanChar: procedure expose m.
parse arg m, len
nx = 1 + length(m.m.src)
if len \= '' then
nx = min(m.m.pos + len, nx)
m.m.tok = substr(m.m.src, m.m.pos, nx - m.m.pos)
m.m.pos = nx
return m.m.tok \== ''
endProcedure scanChar
/*--- scan a string with quote char qu -------------------------------*/
scanString: procedure expose m.
parse arg m, prefs
m.m.tok = ''
bx = m.m.pos
if prefs = '' then do
qu = substr(m.m.src, bx, 1)
if pos(qu, "'""") < 1 then
return 0
ax = bx + 1
end
else do
do px=1 until abbrev(substr(m.m.src, bx), p1)
p1 = word(prefs, px)
if p1 = '' then
return 0
end
qu = right(p1, 1)
ax = bx + length(p1)
end
m.m.val = ''
do forever
qx = pos(qu, m.m.src, ax)
if qx < 1 then
return scanErr(m, 'ending Apostroph('qu') missing')
m.m.val = m.m.val || substr(m.m.src, ax, qx-ax)
if qx >= length(m.m.src) then
leave
else if substr(m.m.src, qx+1, 1) <> qu then
leave
ax = qx+2
m.m.val = m.m.val || qu
end
m.m.tok = substr(m.m.src, bx, qx+1-bx)
m.m.pos = qx+1
return 1
endProcedure scanString
/*--- scan a Name, first char in *.scanName1, rest in *.scanNameR ----*/
scanName: procedure expose m.
parse arg m
if pos(substr(m.m.src, m.m.pos, 1),
, m.m.scanName1) <= 0 then do
m.m.tok = ''
return 0
end
return scanVerify(m, m.m.scanNameR)
endProcedure scanName
/*--- scan with verify, vOpt is passed to verify ---------------------*/
scanVerify: procedure expose m.
parse arg m, alpha, vOpt, onlyIfMatch
if vOpt == '' then /* empty string does not take default */
nx = verify(m.m.src, alpha, , m.m.pos)
else
nx = verify(m.m.src, alpha, vOpt, m.m.pos)
if nx = 0 then
if onlyIfMatch == 1 then
nx = m.m.pos
else
nx = length(m.m.src) + 1
m.m.tok = substr(m.m.src, m.m.pos, nx - m.m.pos)
m.m.pos = nx
return m.m.tok \== ''
endProcedure scanVerify
/*--- scan a natural number (no sign, decpoint ...) ------------------*/
scanNat: procedure expose m.
parse arg m, chEn
if \ scanVerify(m, '0123456789') then
return 0
if chEn \== 0 then
if pos(scanLook(m , 1), m.m.scanNameR) > 0 then
call scanErr m, 'illegal number end after' m.m.tok
return 1
endProcedure ScanNat
/*--- scan an integer (optional sign, no decpoint ...) ---------------*/
scanInt: procedure expose m.
parse arg m, chEn
call scanLit m, '+', '-'
si = m.m.tok
if \ scanNat(m, chEn) then do
m.m.pos = m.m.pos - si
return 0
end
m.m.tok = si || m.m.tok
return 1
endProcedure scanInt
/*--- scan a number (optional sign, decpoint, exponent) ------------*/
scanNum: procedure expose m.
parse arg m, chEn
sx = m.m.pos
call scanLit m, '+', '-'
po = scanLit(m, '.')
if \ scanNat(m, 0) then do
m.m.pos = sx
return 0
end
if \ po then
if scanLit(m, '.') then
call scanNat m, 0
if scanLit(m, 'e', 'E') then
if \ scanInt(m, 0) then
call scanErr 'exponent expected after' ,
substr(m.m.src, sx, m.m.pos-sx)
m.m.tok = substr(m.m.src, sx, m.m.pos-sx)
m.m.val = translate(m.m.tok)
if chEn \== 0 then
if pos(scanLook(m , 1), m.m.scanNameR) > 0 then
call scanErr m, 'illegal number end after' m.m.tok
return 1
endProcedure scanNum
/*--- scan a word and put value into *.val
a word is either delimited by space or stopper
or a string (with single or double quotes -------*/
scanWord: procedure expose m.
parse arg m, stopper
if scanString(m) then return 1
if \scanVerify(m, ' 'stopper, 'm') then return 0
m.m.val = m.m.tok
return 1
endProcedure scanWord
scanType: procedure expose m.
parse arg m, opt
m.m.tok = ''
if scanName(m) then
m.m.type = 'n'
else if scanNum(m) then
m.m.type = 0
else if scanString(m) then
m.m.type = left(m.m.tok, 1)
else if scanSpaceNl(m) then
m.m.type = 's'
else do
call scanChar m, 1
m.m.type = m.m.tok
end
return m.m.type
endProcedure scanType
scanBack: procedure expose m.
parse arg m, tok
if m.m.pos <= length(tok) then
call scanErr sc, 'cannot back "'tok'" length'
cx = m.m.pos - length(tok)
if substr(m.m.src, cx, length(tok)) \== tok then
call scanErr sc, 'cannot back "'tok'" value'
m.m.pos = cx
return
endProcedure scanBack
/*--- scan a key = word phrase
put key into m.key and word into m.m.val -------*/
scanKeyValue: procedure expose m.
parse arg m, def
if \ scanName(m) then
return 0
m.m.key = m.m.tok
if \ scanLit(scanSkip(m), '=') then do
m.m.val = def
m.m.tok = ' no='
end
else if \scanWord(scanSkip(m)) then
return scanErr(m, 'word expected after' m.m.key '=')
return 1
endProcedure scanKeyValue
/*--- return true/false whether we are at the end of input ----------*/
scanAtEnd: procedure expose m.
parse arg m
return m.m.atEnd & m.m.pos > length(m.m.src)
endProcedure scanAtEnd
/*--- skip over spaces, nl and comments (if option set) --------------*/
scanSpaceNL: procedure expose m.
parse arg m
lastTok = m.m.tok
if m.m.rdr \== '' then
interpret 'res = ' objMet(m, 'scanSpaceNl')
else
res = scanSpaceCom(m)
m.m.tok = lastTok
return res
endProcedure scanSpaceNL
scanSpaceCom: procedure expose m.
parse arg m
res = scanVerify(m, ' ')
if m.m.scanComment \== '' then
if abbrev(substr(m.m.src, m.m.pos), m.m.scanComment) then do
m.m.pos = 1 + length(m.m.src)
return 1
end
return res
endProcedure scanSpaceCom
/*--- skip over space, nl and comments and return m -----------------*/
scanSkip: procedure expose m.
parse arg m
call scanSpaceNl m
return m
endProcedure scanSkip
/*--- emit an error with current scan pos ----------------------------*/
scanErr: procedure expose m.
parse arg m, txt
m.m.err.0 = 0
call err 'scanErr' txt'\n'scanInfo(m, m'.ERR')
return 0
endProcedure scanErr
scanPos: procedure expose m.
parse arg m
if m.m.rdr \== '' then
interpret 'return' objMet(m, 'scanPos')
else if scanAtEnd(m) then
return E
else
return 1 m.m.pos
endProcedure scanPos
scanInfo: procedure expose m.
parse arg m
msg = 'last token' m.m.tok 'scanPosition' ,
strip(left(substr(m.m.src, m.m.pos), 40), 't')
if m.m.rdr == '' then
return msg'\npos' m.m.Pos 'in string' strip(m.m.src, 't')
else
interpret 'return msg ||' objMet(m, 'scanInfo')
endProcedure scanInfo
/* copy scan end ****************************************************/
/* copy scanRead begin ************************************************/
scanReadIni: procedure expose m.
if m.scanRead.ini = 1 then
return
m.scanRead.ini = 1
call scanIni
call jIni
ts = classNew('n Scan u f TOK v, f VAL v, f KEY v, f TYPE v')
call classNew 'n ScanRead u JRW', 'm',
, 'jReset call scanReadReset m, arg, arg2, arg3',
, 'jOpen call scanReadOpen m',
, 'jClose call jClose m.m.rdr',
, 'jRead call scanType m; call oClaCopy "'ts'", m, var;' ,
'return m.m.type \== ""',
, 'scanReadNl return scanReadNlImpl(m, unCond)',
, 'scanSpaceNl scanReadSpaceNl(m)',
, 'scanInfo scanReadInfo(m)',
, 'scanPos scanReadPos(m)'
return
endProcedure scanReadIni
/*--- begin scanning the lines of a reader ---------------------------*/
scanRead: procedure expose m.
parse arg rdr, n1, np, co
return scanOpts(oNew('ScanRead', rdr), n1, np, co)
scanReadReset: procedure expose m.
parse arg m, r, n1, np, co
call scanReset m, n1, np, co
m.m.rdr = r
return m
endProcedure scanReadReset
scanReadOpen: procedure expose m.
parse arg m, r, n1, np, co
call scanOpen m
m.m.atEnd = 0
m.m.lineX = 0
call jOpen m.m.rdr, m.j.cRead
call scanReadNl m, 1
return m
endProcedure scanReadOpen
/*--- scan over next newLine
if unCond \== 1 only if we are already at endOfLine
return true if we scanned a NL ------------------------------*/
scanReadNl: procedure expose m.
parse arg m, unCond
interpret objMet(m, 'scanReadNl')
endProcedure scanReadNl
/*--- implementation of scanReadNl ----------------------------------*/
scanReadNLimpl: procedure expose m.
parse arg m, unCond
if unCond \== 1 then
if m.m.pos <= length(m.m.src) then
return 0
if m.m.atEnd then
return 0
m.m.atEnd = \ jRead(m.m.rdr, m'.SRC')
if m.m.atEnd then do
m.m.pos = 1 + length(m.m.src)
end
else do
m.m.pos = 1
m.m.lineX = m.m.lineX + 1
end
return \ m.m.atEnd
endProcedure scanReadNLimpl
scanReadSpaceNl: procedure expose m.
parse arg m
fnd = 0
do forever
if scanSpaceCom(m) then
fnd = 1
if \ scanReadNl(m) then
return fnd
fnd = 1
end
endProcedure scanReadSpaceNl
scanReadPos: procedure expose m.
parse arg m, msg
if scanAtEnd(m) then
return E
else
return m.m.lineX m.m.pos
endProcedure scanReadPos
scanReadInfo: procedure expose m.
parse arg m, msg
if scanAtEnd(m) then
msg = msg'\natEnd after'
else
msg = msg'\npos' m.m.pos 'in'
return msg 'line' m.m.lineX':' strip(m.m.src, 't')
endProcedure scanReadInfo
/* copy scanRead end **************************************************/
/* copy scanWin begin *************************************************
scan the the concatenation of the lines of a reader
any token my be split over several line
except the end-of-line-comment-token
***********************************************************************/
scanWinIni: procedure expose m.
if m.scanWin.ini = 1 then
return
m.scanWin.ini = 1
call scanIni
call jIni
call classNew 'n ScanWin u JRW', 'm',
, 'jReset call scanWinReset m, arg, arg2, arg3',
, 'jOpen call scanWinOpen m ',
, 'jClose call scanWinClose m ',
, 'scanReadNl return scanWinNl(m, unCond)',
, 'scanSpaceNl scanWinSpaceNl(m)',
, 'scanInfo scanWinInfo(m)',
, 'scanPos scanWinPos(m)'
return
endProcedure scanReadIni
/*--- instanciate a new window scanner, open rdr ---------------------*/
scanWin: procedure expose m.
parse arg rdr, wiSz, wiBa, cuPo, cuLe
return scanWinOpts(oNew('ScanWin', rdr), wiSz, wiBa, cuPo, cuLe)
/*--- set the reader and attributes of window scanner m -------------*/
scanWinReset: procedure expose m.
parse arg m, r, wiSz, wiGa, cuPo, cuLe
call scanReset m
m.m.rdr = r
m.m.atEnd = 'still closed'
return scanWinOpts(m, wiSz, wiGa, cuPo, cuLe)
endProcedure scanWinReset
/*--- set the attributes of window scanner m ------------------------*/
scanWinOpts: procedure expose m.
parse arg m, wiSz, wiGa, cuPo, cuLe
wiSz = word(wiSz 5, 1)
wiGa = word(wiGa 1, 1)
m.m.cutPos = word(cuPo 1, 1)
m.m.cutLen = word(cuLe 72, 1)
m.m.winTot = (wiSz * 2 + wiGa) * m.m.cutLen
m.m.posLim = (wiSz + wiGa) * m.m.cutLen
m.m.posOff = wiGa * m.m.cutLen
return m
endProcedure scanWinReset
/*--- open reader and start scanning --------------------------------*/
scanWinOpen: procedure expose m.
parse arg m, lx
call scanOpen m
m.m.atEnd = 0
if lx = '' then
m.m.lineX = 1
else
m.m.lineX = lx
m.m.pos = 1
m.m.src = ''
call jOpen m.m.rdr, m.j.cRead
call scanWinRead m
return m
endProcedure scanWinOpen
scanWinClose: procedure expose m.
m.m.atEnd = 'still closed'
call jClose m.m.rdr
return
endProcedure scanWinClose
/*--- move the source window: cut left side and append at right side
return number of characters cut at left ------------------------*/
scanWinRead: procedure expose m.
parse arg m
dlt = 0
if m.m.atEnd then
return 0
if m.m.pos >= m.m.posLim then do /* cut left side */
dlt = m.m.pos - (m.m.pos // m.m.cutLen + m.m.posOff)
m.m.src = substr(m.m.src, dlt+1)
m.m.pos = m.m.pos - dlt
m.m.lineX = m.m.lineX + dlt % m.m.cutLen
end
do while length(m.m.src) < m.m.winTot /* read and fill to len */
if \ jRead(m.m.rdr, m'.'one) then do
m.m.atEnd = 1
return dlt
end
m.m.src = m.m.src || substr(m.m.one, m.m.cutPos, m.m.cutLen)
end
call assert 'length(m.m.src) = m.m.winTot'
return dlt
endProcedure scanWinRead
/*--- return position of next line start -----------------------------*/
scanWinNLPos: procedure expose m.
parse arg m
return m.m.pos + m.m.cutLen - ((m.m.pos - 1) // m.m.cutLen)
/*--- scan over spaces and comments ----------------------------------*/
scanWinSpaceNL: procedure expose m.
parse arg m
res = 0
do forever
r1 = 0
if scanVerify(m, ' ') then do
r1 = 1
end
else if m.m.scanComment \== '' ,
& abbrev(substr(m.m.src, m.m.pos), m.m.scanComment) then do
np = scanWinNlPos(m)
r1 = length(m.m.scanComment) <= np - m.m.pos
if r1 then
m.m.pos = np
end
if r1 then
res = 1
else if scanWinRead(m) = 0 then
return res
end
endProcedure scanWinSpaceNl
/*--- return current position in input ------------------------------*/
scanWinPos: procedure expose m.
parse arg m
if scanAtEnd(m) then
return 'E'
else
ps = m.m.pos - 1
return (m.m.lineX + (ps % m.m.cutLen)) (ps // m.m.cutLen + 1)
endProcedure scanWinPos
/*--- return a description of the current scan position --------------*/
scanWinInfo: procedure expose m.
parse arg m
p = scanWinPos(m)
if p == 'E' then do
res = 'atEnd after'
p = m.m.lineX - 1 + length(m.m.src) % m.m.cutLen
end
else do
res = 'pos' word(p, 2) 'in'
p = word(p, 1)
end
return '\n'res 'line' p':' strip(substr(m.m.src,
, 1 + (p - m.m.lineX) * m.m.cutLen, m.m.cutLen), 't')
endProcedure scanWinInfo
/* copy scanWin end *************************************************/
/* copy scanSql begin *************************************************/
/*--- initialize with reader inRdr ----------------------------------*/
scanSql: procedure expose m.
parse arg inRdr
return scanSqlReset(scanWin(inRdr), inRdr)
scanSqlReset: procedure expose m.
parse arg m, r, scanWin
if scanWin \== 0 then
call scanWinOpts m, 5, 2, 1, 72
else
m.m.rdr = r
return scanOpts(m, , '0123456789_' , '--')
scanSqlSeekId: procedure expose m.
parse arg m, lx, cmd, opts
if opts = '' then
opts = word
if adrEdit("cursor =" max(trunc(lx), 1), 12) = 12 then
return -1
do while adrEdit("seek" cmd opts, 4) = 0 /* find each command*/
call adrEdit "(fx) = cursor"
if m.debug then do
call adrEdit "(LI) = LINE" fx
call debug 'scanSqlSeekId after' lx 'found' cmd 'at' fx li
end
call editReadReset m.m.rdr, fx
call scanWinOpen es, fx
do while word(scanPos(m), 1) <= fx & scanSqlClass(m)
if m.m.sqlClass = 'i' & m.m.val == cmd then
return fx
end
end
return -1
endProcedure scanSqlSeekId
/*--- scan a sql token put class in m.sqlclass:
'i': ordinary identifier e.g. Name
'd': delimited identifier e.g. "Delimited"
'q': qualified identifier e.g. abc."efg"
'u': integer units e.g. 8G
'n': number e.g. -234 or .2e3
's': string e.g. 'abc''ef'
'' : at end
: any other character e.g. ;
----------------------------------------------------------------*/
scanSqlClass: procedure expose m.
parse arg m, retSpace
m.m.val = ''
if scanSpaceNl(m) & retSpace = 1 then do
m.m.sqlClass = 'b'
return 1
end
c2 = scanLook(m ,2)
if scanString(m, "' x' X'") then do
m.m.sqlClass = 's'
if \abbrev(m.m.tok, "'") then
m.m.val = x2c(m.m.val)
end
else if scanSqlQuId(m) then do
if m.m.val.0 > 1 then
m.m.sqlClass = 'q'
else if abbrev(m.m.tok, '"') then
m.m.sqlClass = 'd'
else
m.m.sqlClass = 'i'
end
else if scanSqlNum(m, 0, 1) then
m.m.sqlClass = 'n'
else if scanChar(m, 1) then
m.m.sqlClass = m.m.tok
else if scanAtEnd(m) then do
m.m.sqlClass = ''
return 0
end
else
call scanErr m, 'cannot scan sql'
return 1
endProcedure scanSqlClass
scanSqlSkipBrackets: procedure expose m.
parse arg m, br
if br \== '' then
nop
else if scanLit(m, '(') then
br = 1
else
return 0
do while scanSqlClass(m) & m.m.sqlClass \== ';'
if m.m.sqlClass = '(' then br = br + 1
else if m.m.sqlClass \== ')' then iterate
else if br > 1 then br = br - 1
else return 1
end
call scanErr m, '; or eof, but' br 'closing ) expected'
endProcedure skipBrackets
/*--- scan an ordinary sql identifier e.g. abc, ef_12 ----------------*/
scanSqlId: procedure expose m.
parse arg m
if \ scanName(m) then
return 0
m.m.val = translate(m.m.tok)
return 1
endProcedure scanSqlId
/*--- scan a delimited or ordinay sql identifier ---------------------*/
scanSqlDeId: procedure expose m.
parse arg m
if scanSqlId(m) then
return 1
if \ scanString(m, '"') then
return 0
m.m.val = strip(m.m.val, 't')
return 1
endProcedure scanSqlDeId
/*--- scan a qualified sql identifier --------------------------------*/
scanSqlQuId: procedure expose m.
parse arg m
res = ''
rto = ''
do qx=1
if \ scanSqlDeId(m) then do
if qx <> 1 then
call scanErr m, 'id expected after .'
return 0
end
m.m.val.qx = m.m.val
res = res'.'m.m.val
rto = rto'.'m.m.tok
if \ scanLit(scanSkip(m), '.') then
leave
call scanSpaceNl m
end
m.m.val.0 = qx
m.m.val = substr(res, 2)
m.m.tok = substr(rto, 2)
return 1
endProcedure scanSqlQuId
/*--- scan a sql number ----------------------------------------------*/
scanSqlNum: procedure expose m.
parse arg m, checkEnd, noSp
si = ''
if noSp == 1 then
call err 'deimplement ???? wk'
if noSp \== 1 then do
if scanLit(m, '+', '-') then do
si = m.m.tok
call scanSpaceNl m
ch = scanLook(m, 2)
if left(ch, 1) == '.' then
ch = substr(ch, 2)
if pos(left(ch, 1), '0123456789') < 1 then do
call scanBack m, si
m.m.val = ''
return 0
end
end
end
res = scanNum(m, checkEnd)
m.m.val = si || m.m.val
return res
endProcedure scanSqlNum
/*--- scan a sql number with a unit which may follow without space ---*/
scanSqlNumUnit: procedure expose m.
parse arg m, both, units
if \ scanSqlNum(m, 0) then
return 0
nu = m.m.val
sp = scanSpaceNl(m)
if scanSqlId(m) then do
if units == '' | wordpos(m.m.val, units) > 0 then
nu = nu m.m.val
else if both | \ sp then
call scanErr m, 'scanSqlNumUnit after' nu 'bad unit' m.m.val
else
call scanBack m, m.m.tok
end
else if both then
call scanErr m, 'scanSqlNumUnit no unit after' nu
else if \sp & pos(scanLook(m, 1), m.m.scanNameR) > 0 then
call scanErr m, 'scanSqlNumUnit bad number end after' nu
m.m.val = nu
return 1
endProcedure scanSqlNumUnit
/* copy scanSql end *************************************************/
/* copy scanUtil begin *************************************************
scan db2 utility input statements using scan and a reader
**********************************************************************/
/*--- initialize with reader inRdr ----------------------------------*/
scanUtilReader: procedure expose m.
parse arg m, inRdr
call scanReader m, inRdr
call scanOptions sc, , , '--'
call scanUtilReset m
return m
endProcedure scanUtilReader
scanUtilSql: procedure expose m.
parse arg inRdr
m = scanSql(inRdr)
call scanUtilReset m
return m
endProcedure scanUtilReader
scanUtilReset: procedure expose m.
parse arg m
m.m.utilBrackets = 0
m.scanUtil = 'BACKUP CATENFM CATMAINT CHECK' ,
'COPY COPYTOCOPY DIAGNOSE EXEC LISTDEF LOAD' ,
'MERGECOPY MODIFY OPTIONS QUIESCE REBUILD' ,
'RECOVER REORG REPAIR REPORT RESTORE' ,
'RUNSTATS STOSPACE TEMPLATE UNLOAD'
return
endProcedure scanUtilReset
/*--- scan next token and put its class in m.sc.utilClass:
'u' a utility name
'n' a name
'"' a quoted name
"'" an apostroph'd string
'.' a .
',' a ,
'v' a value
'' at end
---------------------------------------------------------------*/
scanUtil: procedure expose m.
parse arg sc
m.sc.utilSpace = scanSpaceNl(sc)
ty = '?'
if scanLit(sc, '(') then do
m.sc.utilBrackets = m.sc.utilBrackets + 1
end
else if scanLIT(sc, ')') then do
m.sc.utilBrackets = m.sc.utilBrackets - 1
if m.sc.utilBrackets < 0 then
call scanErr sc, 'unmatched closing bracket )'
end
else if scanLit(sc, ',') then do
end
else if scanLit(sc, '.') then do
end
else if scanString(sc, "'") then do
end
else if scanString(sc, '"') then do
end
else if scanName(sc) then do
m.sc.val = translate(m.sc.tok)
if m.sc.utilBrackets > 0 then
ty = 'n'
else if 0 < wordPos(m.sc.val, m.scanUtil) then
ty = 'u'
else
ty = 'n'
end
else if scanVerify(sc, ' (),''"', 'm') then do
ty = 'v'
m.sc.val = translate(m.sc.tok)
end
else if \scanAtEnd(sc) then do
call scanErr sc, 'scanUtil stopped before end'
end
else do
/* say 'scanUtil return atEnd' */
ty = ''
m.sc.val = ''
end
if ty == '?' then
m.sc.utilClass = left(m.sc.tok, 1)
else
m.sc.utilClass = ty
return m.sc.utilClass
endProcedure scanUtil
/*--- scan a value or a bracketed list of values ---------------------*/
scanUtilValue: procedure expose m.
parse arg sc, remApo, nl
if remApo = '' | rempApo = 0 then
remApo = "nv"
else if rempApo = 1 then
remApo = "nv'"
if '(' \== scanUtil(sc) then
return scanUtilValueOne(sc, remApo)
v = ''
brx = m.sc.utilBrackets
oLine = word(scanPos(sc), 1)
do forever
call scanUtil sc
one = scanUtilValueOne(sc, remApo)
if one == '' then
call scanErr sc, 'eof in brackets'
else if brx > m.sc.utilBrackets then
return v
nLine = word(scanPos(sc), 1)
if \ m.sc.utilSpace then
v = v || one
else if nl \== '' & oLine <> nLine then
v = v || nl || one
else
v = v' 'one
oLine = nLine
end
endProcedure scanUtilValue
scanUtilValueOne: procedure expose m.
parse arg sc, valTy
if m.sc.utilClass == '' then
return ''
else if m.sc.utilClass == 'u' then
call scanErr sc, 'util in scanUtilValueOne'
if pos(m.sc.utilClass, valTy) > 0 then
return m.sc.val
else
return m.sc.tok
endProcedure scanUtilValueOne
/* copy scanUtil end **************************************************/
/* copy env begin ******************************************************
***********************************************************************/
env: procedure expose m.
m = oBasicNew("Env")
m.m.toClose = ''
m.m.in = ''
m.m.out = ''
m.m.ios.0 = 0
return m
endProcedure env
envClose: procedure expose m.
parse arg m, finishLazy
isLazy = m.m.out == 'ENV.lazyNoOut'
if finishLazy \== '' then do
if \ isLazy & finishLazy == 1 then
call err 'not lazy'
call oMutate m, 'Env'
m.e.out = 'ENV.wasLazy'
end
else if isLazy then
return m
do wx=1 to words(m.m.toClose)
call jClose word(m.m.toClose, wx)
end
m.m.toClose = ''
return m
endProcedure envClose
envAddIO: procedure expose m.
parse arg m, opt spec
opt = jOpt(opt)
k = left(opt, 1)
if k == m.j.cApp then
k = m.j.cWri
else if pos(k, m.j.cRead || m.j.cWri) < 1 then
call err 'envAddIO bad opt' opt
do kx=1 to m.m.ios.0 while m.m.ios.kx \== k
end
if kx > m.m.ios.0 then
call mCut mAdd(m'.IOS', k), 0
call mAdd m'.IOS.'kx, opt spec
return m
endProcedure envAddIO
envLazy: procedure expose m.
parse arg e
m.e.jReading = 0
m.e.jWriting = 0
m.e.lazyRdr = jClose(m.e.out)
m.e.out = 'ENV.lazyNoOut'
call oMutate e, 'EnvLazy'
return e
endProcedure envLazy
/*--- return openOption and reader for opt rdr or jIn ---------------*/
envOptRdr: procedure expose m.
parse arg opt rdr
if opt = '' then
return m.j.cRead || m.j.cNoOC || m.j.cObj m.j.jIn
else if rdr = '' then
return m.j.cRead catMake(m.j.cRead opt)
else
return opt catMake(opt rdr)
endProcedure envOptRdr
/*--- write all from rdr (rsp jIn) to jOut, possibly lazy -----------*/
envWriteAll: procedure expose m.
if arg() > 1 then call err '?????????'
parse arg optRdr
call jWriteAll m.j.jOut, envOptRdr(optRdr)
return
endProcedure envWriteAll
/*--- write all from rdr (rsp jIn) to jOut, not lazy ----------------*/
envWriteNow: procedure expose m.
if arg() > 1 then call err '?????????'
parse arg optRdr
call jWriteNow m.j.jOut, envOptRdr(optRdr)
return
endProcedure envWriteNow
envRead2Buf:
call err 'use env2Buf' /*???wkTest***/
/*--- write all from rdr (rsp jIn) to a new jBuf --------------------*/
env2Buf: procedure expose m.
parse arg optRdr
b = jOpen(jBuf(), m.j.cWri)
call jWriteNow b, envOptRdr(optRdr)
return jClose(b)
endProcedure env2Buf
envPreSuf: procedure expose m.
parse arg le, ri
do while jIn(v)
call jOut le || m.v || ri
end
return
endProcedure envPreSuf
envCatStr: procedure expose m.
parse arg mi, fo
res = ''
do while jIn(v)
res = res || mi || fmt(m.v)
end
return substr(res, length(mi))
endProcedure envCatStr
envIsDefined: procedure expose m.
parse arg na
return symbol('m.env.vars.na') == 'VAR'
endProcedure envIsDefined
envGet: procedure expose m.
parse arg na
return mapGet(env.vars, na)
envRead: procedure expose m.
parse arg na
return jIn('ENV.VARS.'na)
envHasKey: procedure expose m.
parse arg na
return mapHasKey(env.vars, na)
envVia: procedure expose m.
parse arg na
return mapVia(env.vars, na)
envPut: procedure expose m.
parse arg na, va
return mapPut(env.vars, na, va)
envRemove: procedure expose m.
parse arg na
return mapRemove(env.vars, na)
envIni: procedure expose m.
if m.env.ini == 1 then
return
m.env.ini = 1
call catIni
call classNew "n Env u JRW"
call classNew "n EnvLazy u Cat", "m",
, "jOpen call jOpen m.m.lazyRdr, opt; m.m.jReading = 1",
, "jRead call envPushEnv m;res = jRead(m.m.lazyRdr, var);",
"call envPop; return res",
, "jReset call envClose m, r",
, "jClose call envClose m, 1"
call mapReset env.vars
call jReset oMutate("ENV.lazyNoOut", "JRWErr")
m.env.0 = 0
call envPush /* by default pushes jIn and jOut */
return
endProcedure envIni
envPush: procedure expose m.
e = env()
do ax=1 to arg()
call envAddIo e, arg(ax)
end
do ix=1 to m.e.ios.0
if m.e.ios.ix.0 = 1 then do
rw = catMake(m.e.ios.ix.1)
opt = word(m.e.ios.ix.1, 1)
end
else do
rw = cat()
do fx=1 to m.e.ios.ix.0
call catWriteAll rw, m.e.ios.ix.fx
end
opt = m.e.ios.ix
end
if pos(m.j.cNoOC, opt) < 1 then do
call jOpen rw, opt
m.e.toClose = m.e.toClose rw
end
if m.e.ios.ix = m.j.cRead then
m.e.in = rw
else if m.e.ios.ix = m.j.cWri then
m.e.out = rw
else
call err 'envPush bad io' m.e.ios.ix 'for' m.e.ios.ix.1
end
return envPushEnv(e)
endProcedure envPush
envPushEnv: procedure expose m.
parse arg e
call mAdd env, e
if m.e.in == '' then
m.e.in = m.j.jIn
else
m.j.jIn = m.e.in
if m.e.out == '' then
m.e.out = m.j.jOut
else
m.j.jOut = m.e.out
return e
endProcedure envPushEnv
/*--- activate the last env from stack
and return outputbuffer from current env --------------------*/
envPop: procedure expose m.
ex = m.env.0
if ex <= 1 then
call err 'envPop on empty stack' ex
o = m.env.ex
oo = m.o.out
ex = ex - 1
m.env.0 = ex
e = m.env.ex
m.j.jIn = m.e.in
m.j.jOut = m.e.out
if objClass(oo, '') == class4Name('Cat') & m.oo.RWs.0 > 0 then
return envLazy(o)
call envClose o
return m.o.out
endProcedure envPop
envBarBegin: procedure expose m.
call envPush '>%' Cat()
return
endProcedure envBarBegin
envBar: procedure expose m.
call envPush '<%' envPop(), '>%' Cat()
return
endProcedure envBar
envBarLast: procedure expose m.
call envPush '<%' envPop()
return
endProcedure envBarLast
envBarEnd: procedure expose m.
call envPop
return
endProcedure envBarEnd
/*--- return the output buffer of oRunner m -------------------------*/
envRun: procedure expose m.
parse arg m
call envPush '>%' jBuf()
call oRun m
return envPop()
endProcedure envRun
/* copy env end *******************************************************/
/* copy cat begin ****************************************************
***********************************************************************/
/*--- create a reader or writer --------------------------------------*/
catMake: procedure expose m.
parse arg opt spec
if pos(m.j.cObj, opt) > 0 then
return spec
else if pos(m.j.cVar, opt) > 0 then do
if envhasKey(spec) then
return catMake(translate(opt, m.j.cObj, m.j.cVar) envGet(spec))
else
return envPut(spec, jBuf())
end
else if pos('&', opt) > 0 then
return file('&'spec)
else
return file(spec)
endProcedure catMake
/*--- create a new cat -----------------------------------------------*/
cat: procedure expose m.
m = oNew('Cat') /* calls catReset */
do ax=1 to arg()
call catWriteAll m, arg(ax)
end
return m
endProcedure cat
catReset: procedure expose m.
parse arg m
m.m.RWs.0 = 0
m.m.catWr = ''
m.m.catRd = ''
m.m.catIx = -9
return m
endProcedure catReset
catClose: procedure expose m.
parse arg m
if m.m.catIx == -9 then
return
if m.m.catWr \== '' then do
call jClose m.m.catWr
call mAdd m'.RWS', jOpt(m.j.cObj) m.m.catWr
m.m.catWr = ''
end
if m.m.catRd \== '' then do
ix = m.m.catIx
if pos(m.j.cNoOC, word(m.m.RWs.ix, 1)) < 1 then
call jClose m.m.catRd
m.m.catRd = ''
end
m.m.catIx = -9
return m
endProcedure catClose
catOpen: procedure expose m.
parse arg m, oo
if pos(m.j.cRead, oo) > 0 then do
m.m.catIx = 0
m.m.catRd = catNextRdr(m)
m.m.jReading = 1
end
else if abbrev(oo, m.j.cWri) | abbrev(oo, m.j.cApp) then do
if abbrev(oo, m.j.cWri) then
m.m.RWs.0 = 0
m.m.catIx = -7
m.m.jWriting = 1
end
else do
call err 'catOpen('m',' oo') bad opt'
end
return m
endProcedure catOpen
/*--- return and open next reader ------------------------------------*/
catNextRdr: procedure expose m.
parse arg m
cx = m.m.catIx
if cx > 0 & cx <= m.m.RWs.0 ,
& pos(m.j.cNoOC, word(m.m.RWs.cx, 1)) < 1 then
call jClose m.m.catRd
cx = cx + 1
m.m.catIx = cx
if cx > m.m.RWs.0 then
return ''
return jOpen(catMake(m.m.RWs.cx),
, m.j.cRead||substr(word(m.m.RWs.cx, 1), 2))
endProcedure catNextRdr
catRead: procedure expose m.
parse arg m, var
do while m.m.catRd \== ''
if jRead(m.m.catRd, var) then
return 1
m.m.catRd = catNextRdr(m)
end
return 0
endProcedure catRead
catWrite: procedure expose m.
parse arg m, line
if m.m.catWr == '' then
m.m.catWr = jOpen(jBuf(), m.j.cWri)
call jWrite m.m.catWr, line
return
endProcedure catWrite
catWriteR: procedure expose m.
parse arg m, var
if m.m.catWr == '' then
m.m.catWr = jOpen(jBuf(), m.j.cWri)
call jWriteR m.m.catWr, var
return
endProcedure catWriteR
/*--- write contents of a reader to cat
or keep it for later reading -------------------------------*/
catWriteAll: procedure expose m.
parse arg m
if m.m.catIx >= 0 then
call err 'catWriteAll('m',' arg(2)') but opened,',
'catIx='m.m.catIx
if m.m.catWr \== '' then do
call mAdd m'.RWS', jOpt(m.j.cObj) jClose(m.m.catWr)
m.m.catWr = ''
end
do ax=2 by 1 to arg()
if words(arg(ax)) = 1 then
call mAdd m'.RWS', jOpt() arg(ax)
else
call mAdd m'.RWS', jOpt(word(arg(ax),1)) subword(arg(ax),2)
end
return
endProcedure catWriteAll
/*--- create a reader/writer for an external file --------------------*/
file: procedure expose m.
parse arg sp
return oNew('File', sp)
endProcedure file
fileWriteR: procedure expose m.
parse arg m, var
if symbol('m.class.o2c.var') == 'VAR' then do
ty = m.class.o2c.var
if m.ty \== 'v' then
call err 'fileWriteR with var' var 'class' ty
end
call jWrite m, m.var
return
endProcedure fileWriteR
fileChild: procedure expose m.
parse arg m, name, opt
interpret objMet(m, 'fileChild')
endProcedure fileChild
fileRm: procedure expose m.
parse arg m
interpret objMet(m, 'fileRm')
return
endProcedure fileRm
filePath: procedure expose m.
parse arg m
interpret objMet(m, 'filePath')
endProcedure filePath
fileIsFile: procedure expose m.
parse arg m
interpret objMet(m, 'fileIsFile')
endProcedure fileIsFile
fileIsDir: procedure expose m.
parse arg m
interpret objMet(m, 'fileIsDir')
endProcedure fileIsDir
fileMkDir: procedure expose m.
parse arg m, opt
interpret objMet(m, 'fileMkDir')
return
endProcedure fileRm
fileRmDir: procedure expose m.
parse arg m, opt
interpret objMet(m, 'fileRmDir')
return
endProcedure fileRm
/*--- create a reader/writer for the filelist of a directory----------*/
fileList: procedure expose m.
parse arg m, opt
return oNew('FileList', filePath(m), opt)
endProcedure fileList
catIni: procedure expose m.
if m.cat.ini == 1 then
return
m.cat.ini = 1
call jIni
call classNew "n Cat u JRW", "m",
, "jOpen return catOpen(m, opt)",
, "jReset return catReset(m, arg)",
, "jClose call catClose m",
, "jRead return catRead(m, var)",
, "jWrite call catWrite m, line; return",
, "jWriteR call catWriteR m, var; return",
, "jWriteAll call catWriteAll m, optRdr; return"
os = errOS()
if os == 'TSO' then
call fileTsoIni
else if os == 'LINUX' then
call fileLinuxIni
else
call err 'file not implemented for os' os
return
endProcedure catIni
/* copy cat end ****************************************************/
/* copy fiLinux begin *************************************************/
/*--- send ggShCmd to shell bash,
fail if rc <> 0 or not listed in ggRet -----------------------*/
adrSh: procedure expose m. /* really no need for variables???? */
parse arg ggShCmd, ggRet
address 'bash' ggShCmd
if rc == 0 then return 0
else if ggRet == '*' then return rc
else if wordPos(rc, ggRet) > 0 then return rc
else
call err 'adrSh rc' rc 'for' ggShCmd
endProcedure adrSh
fileLinuxReset: procedure expose m.
parse arg m, nm
m.m.spec = nm
if abbrev(nm, '&') then do
if nm == '&in' then do
m.m.stream = .input
m.m.jReading = 1
end
else if nm == '&out' then do
m.m.stream = .output
m.m.jWriting = 1
end
else do
call err 'bad spec' nm
end
end
else do
m.m.stream = .Stream$mc$new(nm)
m.m.stream$mc$init(m.m.stream$mc$qualify)
end
return m
endProcedure fileLinuxReset
fileLinuxOpen: procedure expose m.
parse arg m, opt
if pos(m.j.cRead, opt) > 0 then do
res = m.m.stream$mc$open(read shareread)
m.m.jReading = 1
end
else do
if pos(opt, m.j.cApp) > 0 then
res = m.m.stream$mc$open(write append)
else if pos(opt, m.j.cWri) > 0 then
res = m.m.stream$mc$open(write replace)
else
call err 'fileLinuxOpen('m',' opt') with bad opt'
m.m.jWriting = 1
end
if res \== 'READY:' then
call err 'fileLinuxOpen fails' res':' opt m.m.stream$mc$qualify
return m
endProcedure fileLinuxOpen
fileLinuxClose:
parse arg m
res = m.m.stream$mc$close
if res \== 'READY:' then
call err 'fileLinuxClose' res':' m.m.stream$mc$qualify
return m
endProcedure fileLinuxClose
fileLinuxRead: procedure expose m.
parse arg m, var
res = m.m.stream$mc$lineIn
if res == '' then
if m.m.stream$mc$state \== 'READY' then
return 0
m.var = res
return 1
endProcedure fileLinuxRead
fileLinuxWrite: procedure expose m.
parse arg m, line
if m.m.stream$mc$lineOut(line) then
call err 'fileLinuxWrite'
return
endProcedure fileLinuxWrite
fileLinuxRmDir: procedure expose m.
parse arg m, opt
if opt == '' then
return adrSh('rmdir' m.m.spec)
else if opt == '-r' then
return adrSh('rm -r' m.m.spec)
else
call err 'bad opt' opt 'in fileLinuxRmDir'
endProcedure fileLInuxRmDir
fileLinuxListReset: procedure expose m.
parse arg m, m.m.spec, o
if o == 'r' then
m.m.opt = 'S'
else if o == '' then
m.m.opt = ''
else
call err 'bad opt' o 'in fileLinuxListReset'
m.m.rx = 'closed'
return m
endProcedure fileLinuxListReset
fileLinuxListOpen: procedure expose m.
parse arg m
if m.m \== value('m.'m) then
call err 'bad m for fileLinuxList:' m
if m.m.opt == '' then
rc = sysFileTree(m.m.spec'/*', 'm.'m'.LIST')
else
rc = sysFileTree(m.m.spec'/*', 'm.'m'.LIST', m.m.opt)
if rc \== 0 then
call err 'rc' rc 'in sysFileTree('m.m.spec', m.'m'.LIST)'
m.m.rx = 0
m.m.jReading = 1
return m
endProcedure fileLinuxListOpen
fileLinuxListRead: procedure expose m.
parse arg m, var
x = m.m.rx + 1
if x > m.m.list.0 then
return 0
m.var = substr(m.m.list.x, 43)
m.m.rx = x
return 1
endProcedure fileLinuxListRead
fileLinuxIni: procedure expose m.
if m.fileLinux.ini == 1 then
return
m.fileLinux.ini = 1
m.file.sep = '/'
call jIni
call classNew "n File u JRW", "m",
, "jReset return fileLinuxReset(m, arg)",
, "jOpen return fileLinuxOpen(m, opt)",
, "jClose call fileLinuxClose m",
, "jRead return fileLinuxRead(m, var)",
, "jWrite call fileLinuxWrite m, line",
, "jWriteR call fileWriteR m, var",
, "filePath return m.m.stream~qualify",
, "fileIsFile return sysIsFile(m.m.stream~qualify)" ,
, "fileIsDir return sysIsFileDirectory(m.m.stream~qualify)" ,
, "fileChild return file(m.m.stream~qualify'/'name)",
, "fileRm return adrSh(m.m.spec)",
, "fileMkDir return adrSh('mkdir' m.m.stream~qualify)" ,
, "fileRmDir return fileLinuxRmDir(m, opt)"
call classNew "n FileList u JRW", "m",
, "jReset return fileLinuxListReset(m, arg, arg2)",
, "jOpen return fileLinuxListOpen(m, opt)",
, "jClose m.m.rx = 'closed'",
, "jRead return fileLinuxListRead(m, var)"
return
endProcedure fileLinuxIni
/* copy fiLinux end *************************************************/
/* copy fileTso begin *************************************************/
fileTsoReset: procedure expose m.
parse arg m, sp
m.m.readIx = 'c'
if symbol('m.m.defDD') \== 'VAR' then do
ix = mInc('FILETSO.BUF')
m.m.defDD = 'CAT'ix
m.m.buf = 'FILETSO.BUF'ix
m.m.spec = sp
end
if sp \== '' then do
m.m.spec = dsnSpec(sp)
rr = translate(subword(m.m.spec, 4))
m.m.stripT = \ (pos(':V', rr) > 0 | pos('RECFM(V', rr) > 0)
end
return m
endProcedure fileTsoReset
fileTsoOpen: procedure expose m.
parse arg m, opt
buf = m.m.buf
if pos(m.j.cRead, opt) > 0 then do
aa = dsnAlloc(m.m.spec, 'SHR', m.m.defDD)
/* ???wkTest fehlermeld funktioniert so nicht, ist sie noetig?
if m.dsnAlloc.dsn <> '' then
if sysDsn("'"m.dsnAlloc.dsn"'") <> 'OK' then
call err 'cannot read' m.dsnAlloc.dsn':',
sysDsn("'"m.dsnAlloc.dsn"'") */
call readDDBegin word(aa, 1)
m.m.jReading = 1
m.buf.0 = -1
m.m.readIx = 0
end
else do
if pos(opt, m.j.cApp) > 0 then
aa = dsnAlloc(m.m.spec, 'MOD', m.m.defDD)
if pos(opt, m.j.cWri) > 0 then
aa = dsnAlloc(m.m.spec, 'OLD', m.m.defDD)
else
call err 'fileTsoOpen('m',' opt') with bad opt'
call writeDDbegin word(aa, 1)
m.m.jWriting = 1
m.buf.0 = 0
m.m.readIx = 'w'
end
m.m.dd = word(aa, 1)
m.m.free = subword(aa, 2)
return m
endProcedure fileTsoOpen
fileTsoClose:
parse arg m
buf = m.m.buf
if m.m.readIx \== 'c' then do
if m.m.readIx == 'w' then do
if m.buf.0 > 0 then
call writeDD m.m.dd, 'M.'BUF'.'
call writeDDend m.m.dd
end
else do
call readDDend m.m.dd
end
interpret m.m.free
end
m.buf.0 = 'closed'
m.m.readIx = 'c'
m.m.free = ''
m.m.dd = ''
return m
endProcedure fileTsoClose
fileTsoRead: procedure expose m.
parse arg m, var
ix = m.m.readIx + 1
buf = m.m.buf
if ix > m.buf.0 then do
res = readDD(m.m.dd, 'M.'buf'.')
if \ res then
return 0
ix = 1
end
m.m.readIx = ix
m.var = m.buf.ix
return 1
endProcedure fileTsoRead
fileTsoWrite: procedure expose m.
parse arg m, var
buf = m.m.buf
ix = m.buf.0 + 1
m.buf.0 = ix
if m.m.stripT then
m.buf.ix = strip(var, 't')
else
m.buf.ix = var
if ix > 99 then do
call writeDD m.m.dd, 'M.'buf'.'
m.buf.0 = 0
end
return
endProcedure fileTsoWrite
fileTsoWriteR: procedure expose m.
parse arg m, var
if objClass(var, m.class.classV) == m.class.classV then do
call fileTsoWrite m, m.var
return
end
call err 'fileTsoWriteR('m',' var') cannot write objects of class',
objClass(var)
endProcedure fileTsoWriteR
fileTsoIni: procedure expose m.
if m.fileTso.ini == 1 then
return
m.fileTso.ini = 1
m.file.sep = '.'
m.fileTso.buf = 0
call jIni
um = "call err 'for tso undefined method'"
call classNew "n File u JRW", "m",
, "jOpen return fileTsoOpen(m, opt)",
, "jReset return fileTsoReset(m, arg)",
, "jClose call fileTsoClose m",
, "jRead return fileTsoRead(m, var)",
, "jWrite call fileTsoWrite m, line",
, "jWriteR call fileTsoWriteR m, var",
, "filePath return word(m.m.spec, 1)" ,
, "fileIsFile" um "'fileIsFile'" ,
, "fileIsDir return 1" ,
, "fileChild return file(word(m.m.spec, 1)'.'name opt)",
, "fileRm" um "'fileRm'" ,
, "fileMkDir" ,
, "fileRmDir" um "'fileRmDir'"
/* , "filePath return m.m.stream~qualify",
, "fileIsFile return sysIsFile(m.m.stream~qualify)" ,
, "fileIsDir return sysIsFileDirectory(m.m.stream~qualify)" ,
, "fileChild return file(m.m.stream~qualify'/'name)",
, "fileRm return adrSh(m.m.spec)",
, "fileMkDir return adrSh('mkdir' m.m.stream~qualify)" ,
, "fileRmDir return fileLinuxRmDir(m, opt)" */
call classNew "n FileList u JRW", "m",
, "jReset if arg2 == 'r' then m.m.dsnMask=arg'.**';",
"else m.m.dsnMask=arg'.*';",
, "jOpen call csiOpen m, m.m.dsnMask; m.m.jReading=1; return",
, "jClose" ,
, "jRead return csiNext(m, var)"
return
endProcedure fileTsoIni
/* copy fileTso end *************************************************/
/* copy sqlO begin ***************************************************
sql interface mit o und j Anbindung
***********************************************************************/
sqlOini: procedure expose m.
if m.sqlO.ini == 1 then
return
m.sqlO.ini = 1
call sqlIni
call envIni
call oDecMethods oNewClass("SqlType", "JRW"),
, "jOpen call sqlOpen substr(m, 8); m.m.jReading = 1",
, "jClose call sqlClose substr(m, 8)",
, "jRead return sqlFetch(substr(m, 8), var)"
call oDecMethods oNewClass("SqlLn", "SqlType"),
, "jRead return sqlFetchLn(substr(m, 8), var)"
return
endProcedure sqlOini
/*--- fetch all rows into stem st
from sql src using type ty and format fmt -----------------*/
sql2St: procedure expose m.
parse arg st, src, ty, fmt
cx = 49
call sql2Cursor cx, src, ty, fmt
call sqlOpen cx
do ix=1 by 1 while sqlFetch(cx, st'.'ix)
end
m.st.0 = ix-1
call sqlClose cx
return ix-1
endProcedure sql2St
/*--- prepare statement 's'cx and declare cursor 'c'cx from sql src
use or generate type ty and format fo ---------------------*/
sql2Cursor: procedure expose m.
parse arg cx, src, ty, fo
call sqlPreDeclare cx, src, 1 /* with describe output */
call sqlGenType cx, ty
m.Sql.cx.FMT.0 = 0
m.Sql.cx.FMT = sqlGenFmt('SQL.'cx'.FMT', cx, fo)
call assert 'm.'m.sql.cx.fmt'.0 >= m.sql.cx.d.sqlD', 'too few fmt'
return
endProcedure sql2Cursor
/*--- return the type for sql cx -------------------------------------*/
sqlType: procedure expose m.
parse arg cx
return oGetTypePara('SQL.TY.'cx)
/*--- fetch cursor 'c'cx into destination dst
each column is formatted and assigned to m.dst.<colName> ---*/
sqlFetch: procedure expose m.
parse arg cx, dst
if ^ sqlFetchInto(cx, 'descriptor :M.SQL.'cx'.D') then
return 0
if dst == '' then
return 1
fi = oFlds(sqlType(cx))
fo = m.sql.cx.fmt
do ix=1 to m.sql.cx.d.SQLD
f = m.fi.ix
if m.sql.cx.d.ix.sqlInd = 0 then
m.dst.f = fmt(m.sql.cx.d.ix.sqlData, m.fo.ix)
else
m.dst.f = fmtS(m.sqlNull, m.fo.ix)
end
return 1
endProcedure sqlFetch
/*--- fetch cursor 'c'cx
put the formatted and concatenated columns into m.var
return 1 if a row fetched, 0 if not ------------------------*/
sqlFetchLn: procedure expose m.
parse arg cx, var
st = 'SQL.'cx'.FET'
if ^ sqlFetch(cx, st) then
return 0
m.var = oFldCat(sqlType(cx), st, m.sql.cx.fmt)
return 1
endProcedure sqlFetchLn
/*--- generate the type sql cx as specified in ty
use the information from the sqlDa -------------------------*/
sqlGenType: procedure expose m.
parse arg cx, ty
if ty == '*' | ty = '' then do
ff = ''
do ix=1 to m.sql.cx.d.sqlD
f1 = word(m.sql.cx.d.ix.sqlName, 1)
if f1 == '' then
f1 = 'COL'ix
ff = ff f1
end
ty = oFldOnly(ff, 'e')
end
call oSetTypePara 'SQL.TY.'cx, ty, 'noCall'
return ty
endProcedure sqlGenType
/*--- generate the format ff for a sql cx as specified in sp
use the information from the sqlDa -------------------------*/
sqlGenFmt: procedure expose m.
parse arg ff, cx, sp
if abbrev(sp, '=') then
return substr(sp, 2)
if sp = '' then
sp = '*st'
m.ff.0 = m.sql.cx.d.sqlD
m.ff.flds = oFlds(sqlType(cx))
if abbrev(sp, '*') then do
do ix=1 to m.ff.0
m.ff.ix = substr(sp, 2)
end
return ff
end
if abbrev(fmts, '=') then
m.Sql.cx.FMT = substr(fmts, 2)
defs = 'ir7 fr9 sl12 Tl26' sp
do wx = 1 to words(defs)
parse value word(defs, wx) with ty 2 fo
select
when ty = 'd' then t.384 = fo
when ty = 'f' then t.480 = fo'/f'
when ty = 'i' then t.496 = fo'/i'
when ty = 'n' then t.484 = fo'/n'
when ty = 's' then t.448 = fo
when ty = 't' then t.388 = fo
when ty = 'T' then t.392 = fo
otherwise call err 'bad type' ty 'for format' fo
end
end
if symbol('t.496') == 'VAR' then
t.500 = t.496
if symbol('t.448') == 'VAR' then do
t.452 = t.448
t.456 = t.448
t.464 = t.448
end
do wx = 1 to m.ff.0
ty = m.sql.cx.d.wx.sqlType
le = m.sql.cx.d.wx.sqlLen
withNulls = ty // 2
ty = ty - withNulls
if symbol('t.ty') <> 'VAR' then
call err 'sqlType' ty 'not supported'
parse var t.ty fo 2 fl '/' op
if op = 'i' then
if le = 2 then le = 6
else le = 12
else if op <> '' then
call err 'length for sqlType' ty 'op' op 'not implemented'
if fl = '=' then
fl = le
else if abbrev(fl, '<') then
fl = min(le, substr(fl, 2))
m.ff.wx = fo || fl
end
return ff
endProcedure sqlGenFmt
/*--- sql o interface ------------------------------------------------*/
/*--- return a reader for the givenn sql or std input ----------------*/
sql2Obj: procedure expose m.
parse arg cx, src, ty, fo
if ty = '' then
ty = '*'
if src == '' then
src = envCatStr(' ', 'sb')
call sql2Cursor cx, src, ty, substr(fo, 1+abbrev(fo, '~'))
call oMutate 'SQL.TY.'cx, 'SqlType'
return 'SQL.TY.'cx
endProcedure sql2obj
/*--- write to std output the result columns of
the sql given in src or std input --------------------------*/
sql: procedure expose m.
parse arg cx, src, ty, fo
call jWriteAll m.j.jOut, "r£", sql2Obj(cx, src, ty, fo)
return
endProcedure sql
/*--- write to std output the result lines of
the sql given in src or std input --------------------------*/
sqlLn: procedure expose m.
parse arg cx, src, ty, fo
if fo = '' then
fo = '~'
squash = abbrev(fo, '~')
if ^ abbrev(fo, '=') then
fo = left(fo, squash) 'sl=' substr(fo, squash+1)
t = sql2Obj(cx, src, ty, fo)
if squash then do
call fmtFldSquashRw t, 'opCl'
return
end
m = 'SQL.LN.'cx
call oMutate m, 'SqlLn'
call jWrite m.j.jOut, fmtFldTitle(m.sql.cx.fmt)
call jWriteAll m.j.jOut, "r£", m
return
endProcedure sqlLn
/* copy sqlO end **************************************************/
/* copy sql begin ***************************************************
sql interface
***********************************************************************/
sqlIni: procedure expose m.
m.sqlNull = '---'
return
endProcedure sqlIni
/*--- prepare statement 's'cx from sql src into descriptor desc ------*/
sqlPrepare: procedure expose m.
parse arg cx, src, descOut, descInp
s = ''
if descOut == 1 then
s = 'into :M.SQL.'cx'.D'
call sqlExec 'prepare s'cx s 'from :src'
if descInp == 1 | (descInp == '' & pos('?', src) > 0) then
call sqlExec 'describe input s'cx 'into :M.SQL.'cx'.I'
else
m.sql.cx.i.sqlD = 0
return
endProcedure
/*--- prepare and declare 'c'cx from sql src -------------------------*/
sqlPreDeclare: procedure expose m.
parse arg cx, src, descOut, descInp
call sqlPrepare cx, src, descOut, descInp
call sqlExec 'declare c'cx 'cursor for s'cx
return
endProcedure sqlPreDeclare
/*--- prepare, declare and open 'c'cx from sql src -------------------*/
sqlPreOpen: procedure expose m.
parse arg cx, src, descOut, descInp
call sqlPreDeclare cx, src, descOut, descInp
call sqlOpen cx
return
endProcedure sqlPreOpen
/*--- open cursor 'c'cx using arguments arg(2), arg(3)... ------------*/
sqlOpen: procedure expose m.
parse arg cx
do ix=1 to arg()-1
call sqlDataSet 'SQL.'cx'.I', ix, arg(ix+1)
end
call sqlExec 'open c'cx 'using descriptor :M.SQL.'cx'.I'
return
endProcedure sqlOpen
/*--- close cursor 'c'cx ---------------------------------------------*/
sqlClose: procedure expose m.
parse arg cx, src
return sqlExec('close c'cx)
endProcedure sqlClose
/*--- fetch cursor 'c'cx into variables ggVars -----------------------*/
sqlFetchInto:
parse arg ggCx, ggVars
if ggVars == '' then
ggVars = 'descriptor :M.SQL.'ggCX'.D'
/* accept sqlCodes > 0 except 100 */
return sqlExec('fetch c'ggCx 'into' ggVars, 0 100) <> 100
endProcedure sqlFetchInto
/*--- return sql variable list for stem st and fields the word in vars
if withInd == 1 then with sqlIndicator variables
sqlVars('S', 'A B') --> ':S.A, :S.B'
sqlVars('S', 'A B', 1) --> ':S.A :S.A.SQLIND, :S.B :S.B.SQLIND'
----------------------------------------------------------------------*/
sqlVars: procedure expose m.
parse arg st, vars, withInd
res = ''
if st ^== '' then
st = st'.'
do ix=1 to words(vars)
res = res', :'st || word(vars, ix)
if withInd == 1 then
res = res ':'st || word(vars, ix)'.SQLIND'
end
return substr(res, 3)
endProcedure sqlVars
sqlVarsNull: procedure expose m.
parse arg st, vars
hasNulls = 0
do ix = 1 to words(vars)
fld = word(vars, ix)
if m.st.fld.sqlInd < 0 then do
m.st.fld = m.sqlNull
hasNulls = 1
end
end
return hasNulls
endProcedure sqlVarsNull
sqlDescNull: procedure expose m.
parse arg cx
desc = 'SQL.'ggCX'.D',
hasNulls = 0
do ix=1 to m.desc.SQLD
if m.desc.ix.sqlInd < 0 then do
m.desc.ix.sqlData = m.sqlNull
hasNulls = 1
end
end
return hasNulls
endProcedure sqlDescNull
/*--- open cursor 'c'cx fetch all into variables vars and close
st = passed stem, sx = row number
return number of rows fetched ----------------------------------*/
sqlOpAllCl:
parse arg ggCx, st, ggVars
do ggAx=4 to arg()
call sqlDataSet 'SQL.'ggCx'.I', ggAx-3, arg(ggAx)
end
call sqlOpen ggCx
do sx = 1 while sqlFetchInto(ggCx, ggVars)
end
m.st.0 = sx - 1
call sqlClose ggCx
return m.st.0
endProcedure sqlOpAllCl
sqlDataSet: procedure expose m.
parse arg da, ix, val
m.da.ix.sqlData = val
m.da.ix.sqlInd = - (arg(ix+2) == m.sqlNull)
return
endProcedure sqlDataSet
/*--- prepare, declare open cursor 'c'cx, fetch all and close
return number of rows fetched ----------------------------------*/
sqlPreAllCl:
parse arg ggCx, ggSrc, st, ggVars
call sqlPreDeclare ggCx, ggSrc
return sqlOpAllCl(ggCx, st, ggVars)
endProcedure sqlPreAllCl
/*--- execute statement 's'cx using arguments arg(2), arg(3)... ------*/
sqlExecute:
parse arg ggCx
do ggAx=2 to arg()
call sqlDataSet 'SQL.'ggCx'.I', ggAx-1, arg(ggAx)
end
call sqlExec 'execute s'ggCx 'using descriptor :M.SQL.'ggCx'.I'
return
endProcedure
/*--- execute immediate the sql src ----------------------------------*/
sqlExImm:
parse arg ggSrc, ggRet
return sqlExec('execute immediate :ggSrc', ggRet)
endProcedure sqlExImm
sqlCommit: procedure expose m.
parse arg src
return sqlExec('commit')
endProcedure sqlCommit
/*--- execute sql thru the dsnRexx interface -------------------------*/
sqlExec: /* no procedure, to keep variables sql... */
parse arg ggSqlStmt, ggRet, ggNo
if ggNo <> '1' then
ggSqlStmt = 'execSql' ggSqlStmt
address dsnRexx ggSqlStmt
/* say 'sqlCode' sqlCode 'rc' rc 'for' ggSqlStmt ggNo */
if rc = 0 then
return 0
else if ggRet = '*' | wordPos(sqlCode, ggRet) > 0 then
return sqlCode
else if rc < 0 then
call err sqlmsg()
else if sqlWarn.0 ^== ' ' | sqlCode <> 0 then
call errSay sqlMsg(), ,'w'
return sqlCode
endSubroutine sqlExec
/*--- connect to the db2 subsystem ggSys -----------------------------*/
sqlConnect: procedure expose m.
parse arg ggSys, ggRetCon
call sqlIni
address tso "SUBCOM DSNREXX"
if rc <> 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
if ggSys = '-' then
return 0
return sqlExec("connect" ggSys, ggRetCon ,1)
endProcedure sqlConnect
/*--- diconnect from db2 ---------------------------------------------*/
sqlDisconnect: procedure expose m.
parse arg ggRet
call sqlExec "disconnect ", ggRet, 1
return
endProcedure sqlDisconnect
/*--- issue an sql error message -------------------------------------*/
sqlMsg: /* no procedure, to keep variables sql... */
signal on syntax name sqlMsgOnSyntax
ggRes = 'sqlCode' sqlCodeT(sqlCode, sqlErrMc, sqlwarn.0':' ,
|| sqlwarn.1||sqlwarn.2||sqlwarn.3||sqlwarn.4||sqlwarn.5',',
|| sqlwarn.6||sqlwarn.7||sqlwarn.8||sqlwarn.9||sqlwarn.10)
if 0 then
sqlMsgOnSyntax: do
ggRes = 'sqlCode' sqlCode translate(sqlErrMc, ',', 'ff'x),
'<<rexx sqlCodeT not found or syntax>>\nwarnings'
do ggX=0 to 10
if sqlWarn.ggx <> '' then
ggRes = ggRes ggx'='sqlWarn.ggx
end
end
signal off syntax
ggRes = ggRes'\nstate' sqlState'\nstmt = ' ggSqlStmt
ggPref = '\nwith'
ggXX = pos(':', ggSqlStmt)+1
do 12 while ggXX > 1
ggYY = verify(ggSqlStmt, ' ,:+-*/&%?|()¢!', 'm', ggXX)
if ggYY < 1 then
ggYY = length(ggSqlStmt) + 1
ggVar = substr(ggSqlStmt, ggXX, ggYY - ggXX)
if ggVar <> '' then do
ggRes = ggRes || ggPref ggVar '=' value(ggVar)
ggPref = '\n '
end
ggXX = pos(':', ggSqlStmt, ggYY+1) + 1
end
return ggRes
endSubroutine sqlMsg
/*--- send a command to db2 through the TSO dsn processor ------------*/
sqlDsn: procedure expose m.
parse arg st, sys, cmd, rcOk
x = outtrap('M.'st'.')
push 'END'
push cmd
address tso 'DSN SYSTEM('sys')'
rr = rc
x = outtrap(off)
if rr = 0 | rcOk = '*' | wordPos(rr, rcOk) > 0 then
return rr
fl = max(1, m.st.0 - 10)
em = 'rc' rr 'for DSN SYSTEM('sys') cmd' cmd,
'\nOuputlines' fl '-' m.st.0':'
do lx=fl to m.st.0
em = em '\n' strip(m.st.lx, 't')
end
call err em
endProcedure sqlDsn
/* copy sql end **************************************************/
/* copy csm begin ******************************************************
interface to csm,
it is integrate with adrTso, eg. dsnAlloc , 'RZ3/..' uses csm
***********************************************************************/
adrCsm:
return adrTso('csmExec' arg(1), arg(2))
endProcedure adrCsm
csmCopy: procedure expose m.
parse arg csnFr, csnTo, ggRet
if dsnGetMbr(csnTo) ^= '' ,
& dsnGetMbr(csnFr) <> dsnGetMbr(csnTo) then
call err 'member rename' csnFr 'to' csnTo
parse value csmSysDsn(csnFr) with sysFr '/' dsnFr
parse value csmSysDsn(csnTo) with sysTo '/' dsnTo
if sysFr = '*' & sysTo <> '*' then do
pdsTo = dsnSetMbr(dsnTo)
al = "SYSTEM("sysTo") DDNAME(COPYTo)",
"DATASET('"pdsTo"') DISP(SHR)"
alRes = dsnAlloc(systo'/'pdsTo, ,'COPYTO', '*')
if datatype(alRes, 'n') then do
/* wir müssen es selbst allozieren csmxUtil
vergisst management class ||||| */
say 'could not allocate' al
say 'trying to create'
rc = listDsi("'"dsnSetMbr(dsnFr)"' SMSINFO")
if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
al = left(al, length(al)-4)'CAT)'
if right(sysDsSms, 7) == 'LIBRARY' ,
| abbrev(sysDsSms, 'PDS') then
al = al 'DSNTYPE(LIBRARY)'
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
al = al "DSORG("sysDSorg") MGMTCLAS("sysMgmtClass")",
"RECFM("sysREcFM") LRECL("SYSLRECL")",
"blksize("sysBLkSIZE")",
"SPACE("sysPrimary"," sysSeconds")" sysUnits
call adrCsm "allocate" al
end
call adrTso 'free dd(copyTo)'
end
c = "'COPY" sysFr"/''"dsnFr"'' TO" ,
sysTo"/''"dsnSetMbr(dsnTo)"'' REPLACE'"
return adrTso("exec 'CSM.RZ1.P0.EXECall(CSRXUTIL)'" c , ggRet)
return
endProcedure csmCopy
csmAlloc: procedure expose m.
parse upper arg dd, disp, dsn, rest, nn, retRc
sys = ''
a2 = ''
parse value csmSysDsn(dsn) with sys '/' dsn
if disp = '' then
disp = 'shr'
al = "SYSTEM("sys") DDNAME("dd")"
if dsn <> '' then do
a2 = "DATASET('"dsnSetMbr(dsn)"')"
mbr = dsnGetMbr(dsn)
if mbr <> '' then
a2 = a2 'MEMBER('mbr')'
end
if abbrev(disp, 'SYSOUT(') then
a2 = a2 disp
else
a2 = a2 "DISP("disp")"
if retRc <> '' | nn = '' then do
alRc = adrCsm('allocate' al a2 rest, retRc)
if alRc <> 0 then
return alRc
return dd 'call adrTso "free dd('dd')";'
end
do retry=0 by 1
alRc = adrCsm('allocate' al a2 rest, '*')
if alRc = 0 then
return dd 'call adrTso "free dd('dd')";'
if retry > 0 | nn = '' | wordPos(disp, 'OLD SHR') < 1 then
return err('cmsAlloc rc' alRc 'for' al rest)
say 'csmAlloc rc' alRc 'for' al a2 rest '...trying to create'
nn = al 'disp(cat)' dsnCreateAtts(dsn, nn, 1)
call adrCsm 'allocate' nn
call adrTso 'free dd('dd')'
end
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
/* copy csm end *******************************************************/
/* copy sleep begin ***************************************************/
parse arg s
if s = '' then
call sleep 5
else
call sleep s
return
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
/* copy sleep end *****************************************************/
/* copy csi begin ***************************************************
csi interface: see dfs managing catalogs appendix c
returncode/reason see message IDC3009I
**********************************************************************/
/*--- specify dsn mask and fields to start a csi catalog search --------
arguments:
m objectPointer
dsnMask specifies the dsns with wildcards:
% 1 character
* 0 - n character in one level
** 0 - n levels
fields a (space separated) list of field names -------------*/
csiOpen: procedure expose m.
parse arg m, dsnMask, fields
m.m.fld.0 = words(fields)
ffix = d2c(m.m.fld.0, 2)
do x=1 to m.m.fld.0
m.m.fld.x = translate(word(fields, x))
ffix = ffix || left(m.m.fld.x, 8)
end
if dsnMask \== '' & pos('*', dsnMask) < 1 then
dsnMask = dsnMask'.**'
m.m.filt = left(dsnMask, 149) ,
|| left('Y', 3) , /* resume offset 149 */
|| ffix /* csiNumEn offset 152 */
WORKLEN = 1024 * 64
m.m.work = D2C(WORKLEN,4) || COPIES('00'X,WORKLEN-4)
m.m.pos = workLen + 1
return
endProcedure csiOpen
/*--- put the next dsn into m.o and m.o.* (for other fields)
return 1 if next dsn exists 0 otherwise ------------------------*/
csiNext: procedure expose m.
parse arg m, o
usedL = C2D(SUBSTR(m.m.work,9,4)) /* GET AMOUNT OF WORK AREA USED */
px = m.m.pos
do forever
if px > usedL then do
if substr(m.m.filt, 150, 1) \== 'Y' then do
m.m.pos = px
m.o = ''
return 0
end
reason = left('', 4)
ADDRESS LINKPGM 'IGGCSI00 reason m.'m'.filt m.'m'.work'
if rc == 0 & substr(reason, 3, 2) == '0000'x then
nop
else if rc == 4 & substr(reason, 3, 2) == '0464'x then
say 'data set entry with error'
else
call err 'call csi returns' rc,
'rc' c2d(substr(reason, 4,1)),
'reason' c2d(substr(reason, 3,1)),
'module' substr(reason, 1,2)
usedL = C2D(SUBSTR(m.m.work,9,4)) /* GET WORK AREA USED */
numFD = C2D(SUBSTR(m.m.work,13,2)) /* no flds + 1 */
if numFd <> m.m.fld.0 + 1 then
call err 'csiNumFd' numFd 'not' m.m.fld.0 '+' 1
px = 15
iterate
end
eType = substr(m.m.work, px+1, 1)
m.o = strip(substr(m.m.work, px+2, 44), 't')
flag = substr(m.m.work, px, 1)
/* say 'eType' eType m.o 'flag' c2x(flag) */
if eType == '0' then do
if flag \== '00'x & flag ^== '40'x then
call err 'flag' c2x(flag) 'for catalog' m.o
px = px + 50 /* length of catalog entry */
iterate
end
else do
if \ abbrev(x2b(c2x(flag)), '101') then
call err 'call csi entry flag' x2b(c2x(flag)),
'rc' c2d(substr(m.m.work, px+49,1)),
'reason' c2d(substr(m.m.work, px+48,1)),
'module' substr(m.m.work, px+46, 2),
'for entry' m.o,
'see qw IDC3009I'
py = px + 46
tl = c2d(substr(m.m.work, py, 2))
pl = py + 4
pf = py + m.m.fld.0 * 2 + 4
do fx = 1 to m.m.fld.0
fi = m.m.fld.fx
fl = c2d(substr(m.m.work, pl, 2))
m.o.fi = substr(m.m.work, pf, fl)
if fi = 'MGMTCLAS' then
m.o.fi = substr(m.o.fi, 3, c2d(left(m.o.fi ,2)))
else if wordPos(fi, 'COMUDSIZ NOBYTTRK') > 0 then
m.o.fi = c2d(m.o.fi)
pf = pf + fl
pl = pl + 2
end
if py + tl <> pf then
call err 'length mismatch for entry' m.o
m.m.pos = pf
return 1
end
end
endProcedure csiNext
/*--- if dsn is arcived return 'arcive'
if dsn is tape return 'tape'
otherwise return managment class ------------------------------*/
csiArcTape: procedure expose m.
parse arg vo, cl, dt, dsn
if vo = '' then
say err '||| no volume for dsn' dsn
else if vo = 'ARCIVE' then
res = 'arcive'
else if cl <> '' then
res = cl
else if abbrev(vo, 'SHR') then
res = 'SHR'
else
res = 'tape'
if res = 'arcive' then
return res
/*if abbrev(res, 'ar') \= abbrev(dt, '00'x) , */
if abbrev(res, 'ta') \= abbrev(c2x(left(dt, 1)), '7') ,
| (left(res, 1) >= 'A') ^= abbrev(dt, '30'x) then
say '||| mismatch cl' cl 'vo' vo 'dt' c2x(dt) 'dsn' dsn
return res
endProcedure csiArcTape
/* copy csi end ******************************************************/
/* copy adrIsp begin *************************************************/
/**********************************************************************
lmd: catalog read
call sequence: lmdBegin, lmdNext*, lmdEnd
mit lmd service (mit save in file und read,
weil list zu langsam und listcat abstürzt)
1. arg (grp) als group dataset für lmd save
und dd name für file read
***********************************************************************/
lmdBegin: procedure expose m.
parse arg grp, lev
call adrIsp 'lmdinit listid(lmdId) level('lev')'
res = adrIsp('lmdlist listid(&lmdId) option(save) group('grp')', 4)
call adrIsp 'lmdfree listid(&lmdId)'
if res = 0 then do
call trc timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') shr dsn('grp'.datasets)'
end
else do
call trc 'no datasets found' timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') dummy'
end
call readDDBegin grp
return /* end lmdBegin */
lmdNext:
parse arg ggGrp, ggSt, withVolume
if \ readDD(ggGrp, ggSt) then
return 0
if withVolume \== 1 then
do ggIx=1 to value(ggSt'0')
x = value(ggSt || ggIx, word(value(ggSt || ggIx), 1))
end
return 1
endSubroutin lmdNext
lmdEnd: procedure expose m.
parse arg grp
call readDDEnd grp
call adrTso 'free dd('grp')'
return /* end lmdEnd */
lmd: procedure expose m.
parse arg lev, withVol
call lmdBegin gg1, lev
do while lmdNext(gg1, q., withVol)
do x=1 to q.0
call jOut q.x
end
end
call lmdEnd gg1
return
endProcedure lmd
/**********************************************************************
member list of a pds:
call sequence x=lmmBegin(dsn) lmmNext(x) * lmmEnd(x)
***********************************************************************/
lmm: procedure expose m.
parse arg dsn
id = lmmBegin(dsn)
do ix=1 by 1
m = lmmNext(id)
if m = '' then
leave
call jOut m
end
call lmmEnd id
return
endProcedure lmm
lmmBegin: procedure expose m.
parse arg dsn
mbr = dsnGetMbr(dsn)
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET('"pds"') ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(INPUT) "
res = lmmId
if mbr <> '' then
res = res 'pattern('mbr')'
return res
endProcedure lmmBegin
lmmEnd: procedure expose m.
parse arg lmmId opt
call adrIsp "LMMLIST DATAID("lmmId") option(free)", 8
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
return
endProcedure lmmEnd
lmmNext: procedure expose m.
parse arg lmmId opt
if adrIsp("LMMLIST DATAID("lmmid")" ,
"OPTION(LIST) MEMBER(Mbr)" opt, 4 8) = 0 then
return strip(mbr)
else
return ''
endProcedure lmmNext
lmmRm: procedure expose m.
parse arg dsn, mbrs
mbrs = dsnGetMbr(dsn) mbrs
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET("pds") ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(OUTPUT) "
err = ''
do wx=1 to words(mbrs)
m1 = word(mbrs, wx)
rr = adrIsp("lmmDel dataid("lmmId") member("m1")", 0 8 12)
if rc = 0 then
say 'removed' m1 'from' pds
else if rc = 8 then
say 'not found' m1 'in' pds
else do
err = 'error deleting' m1 'in' pds 'rc' rr strip(zerrlm)
say err
leave
end
end
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
if err <> '' then
call err err
return
endProcedure lmmRm
/*--- address ispf with error checking -------------------------------*/
adrIsp:
parse arg ggIspCmd, ggRet
address ispexec ggIspCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr ispExec rc' rc 'in' ggIspCmd':' strip(zerrlm)
endSubroutine adrIsp
/*--- address editor with error checking -----------------------------*/
adrEdit:
parse arg ggEditCmd, ggRet
address isrEdit ggEditCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr isrEdit rc' rc 'for' ggEditCmd
endSubroutine adrEdit
/* copy adrIsp end *************************************************/
/* copy adrTso begin *************************************************/
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet ---*/
adrTso:
parse arg ggTsoCmd, ggRet
address tso ggTsoCmd
if rc == 0 then return 0
else if ggRet == '*' then return rc
else if wordPos(rc, ggRet) > 0 then return rc
else
call err 'adrTso rc' rc 'for' ggTsoCmd
return /* end adrTso */
/*--- format dsn from tso format to jcl format -----------------------*/
dsn2jcl: procedure expose m.
parse upper arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
cx = pos('~', dsn)
if cx < 1 & addPrefix == 1 then
return sp'.'dsn
do while cx ^== 0
le = left(dsn, cx-1)
ri = substr(dsn, cx+1)
if right(le, 1) == '.' | left(ri, 1) == '.' then
dsn = le || sp || ri
else
dsn = le || left('.', le ^== '') || sp ,
|| left('.', ri ^== '') || ri
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
parse arg dsn, mbr
bx = pos('(', dsn)
if bx > 0 then
dsn = strip(left(dsn, bx-1))
if mbr <> '' then
dsn = dsn'('strip(mbr)')'
return dsn
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn
lx = pos('(', dsn)
rx = pos(')', dsn, lx+1)
if lx < 1 then
return ''
else if lx < rx then
return substr(dsn, lx+1, rx-lx-1)
else
return strip(substr(dsn,lx+1))
endProcedure dsnGetMbr
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: readDDBegin, readDD*, readDDEnd
write: writeBegin, writeDD*, writeEnd
readDD returns true if data read, false at eof
***********************************************************************/
/*--- prepare reading from a DD --------------------------------------*/
readDDBegin: procedure expose m.
return /* end readDDBegin */
/*--- read from DD ggDD into ggSt, return false at eof ---------------*/
readDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskr' ggDD '(stem' ggSt')', 2
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- finish reading DD ggDD ----------------------------------------*/
readDDEnd: procedure expose m.
parse arg ggDD
call adrTso 'execio 0 diskr' ggDD '(finis)'
return /* end readDDEnd */
/*--- prepare writing to DD ggDD -------------------------------------*/
writeDDBegin: procedure expose m.
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 expose m.
parse arg ggDD
call adrTso 'execio 0 diskw' ggDD '(finis)'
return /* end writeDDEnd */
/*--- standardise a dsn spec
word1 dsName or -
word2 dd or -
word3 disp or -
word4 to first : attributes in tso format
after first : attributes for new allocation
----------------------------------------------------------------------*/
dsnSpec: procedure expose m.
parse upper arg spec
rr = '' /* put leading - in separate words */
do sx=1 while words(rr) < 3 & wx \= ''
wx = word(spec, sx)
do while abbrev(wx, '-') & words(rr) < 3
wx = substr(wx, 2)
rr = rr '-'
end
rr = rr wx
end
spec = rr subWord(spec, sx)
na = ''
dd = ''
di = ''
if left(spec, 1) = '&' then /* external spec is handled ok */
spec = strip(substr(spec, 2))
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, '.') | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
di = w
else if w = 'CATALOG' then
di = di'+'w
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
na = strip(substr(w, 5, length(w)-5))
else if na == '' then
na = dsn2jcl(w)
else if dd == '' then
dd = w
else if di == '' then
di = w
else
leave
end
if na == '' then na = '-'
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 or a dd
spec '-'<ddName>
datasetName? disposition? '.'? attributes? (':' newAtts)?
disp default disposition
dd default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc -----*/
dsnAlloc: procedure expose m.
parse upper arg spec, pDi, pDD, retRc
parse value dsnSpec(spec) with na dd di rest
if na = '-' then
m.dsnAlloc.dsn = ''
else
m.dsnAlloc.dsn = na
if na == '-' & dd \== '-' & di == '-' & rest = '' then
return dd
if dd == '-' & pDD \== '' then
dd = pDD
if dd == '-' then do
if symbol('m.adrTso.ddNum') = 'VAR' then
dd = m.adrTso.ddNum + 1
else
dd = 1
m.adrTso.ddNum = dd
dd = 'DD' || dd
end
if di = '-' & pDi ^== '' then
di = pDi
if di = '-' then
di = 'SHR'
else if pos('(', na) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if pos('/', ds) > 0 then
return csmAlloc(na dd di rest, retRc)
else
return tsoAlloc(na dd di rest, retRc)
endProcedure dsnAlloc
tsoAlloc: procedure expose m.
parse arg na dd disp rest ':' nn, retRc
c = 'alloc dd('dd')' disp
if na ^== '-' then
c = c "DSN('"na"')"
if retRc <> '' | nn == '' then do
alRc = adrTso(c rest, retRc)
if alRc <> 0 then
return ' ' alRc
return dd 'call adrTso "free dd('dd')";'
end
do retry=0 by 1
alRc = adrTso(c rest, '*')
if alRc = 0 then
return dd 'call adrTso "free dd('dd')";'
if retry > 0 | nn = '' | wordPos(disp, 'OLD SHR') < 1 ,
| sysDsn("'"m.dsnAlloc.dsn"'") ^== 'DATASET NOT FOUND' then
call err 'tsoAlloc rc' alRc 'for' c rest
say 'tsoAlloc rc' alRc 'for' c rest '...trying to create'
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
end
endProcedure tsoAlloc
dsnCreateAtts: procedure expose m.
parse arg dsn, atts, forCsm
bl = 32760
if abbrev(atts, ':') then do
rl = substr(atts, 3)
if abbrev(atts, ':F') then do
if rl = '' then
rl = 80
recfm='f b'
bl = bl - (bl // rl)
end
else do
if rl = '' then
rl = bl-4
recfm = substr(atts, 2, 1) 'B'
end
end
if pos('(', dsn) > 0 then
po = 'dsntype(library) dsorg(po)'
else
po = ''
dsn = dsnSetMbr(dsn)
if forCsm == 1 then
return "dataset('"dsn"')" po,
"recfm("space(recfm, 0)") lrecl("rl") blkSize("bl")" ,
"mgmtclas(COM#A091) space(10, 1000) cylinder"
else
return "dsn('"dsn"')" po,
"recfm("recfm") lrecl("rl") block("bl")" ,
"mgmtclas(COM#A091) space(10, 1000) cyl"
endProcedure dsnCreateAtts
/*--- read the dataset specified in ggDsnSpec to stem ggSt -----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
interpret subword(ggAlloc, 2)
return
endSubroutine readDsn
/*--- write the dataset specified in ggDsnSpec from stem ggSt
write ggCnt records if not empty otherwise ggst0
if ggSay 1 then say ... records written to ... -------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'open finis)'
interpret subword(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
copyDSN: procedure expose m.
parse arg frSpec, toSpec, ggSay
frDD = dsnAlloc(frSpec, 'SHR', 'FRDD')
toDD = dsnAlloc(toSpec, 'OLD', 'TODD')
call readDDBegin word(frDD, 1)
call writeDDBegin word(toDD, 1)
cnt = 0
do while readDD(word(frDD, 1), r.)
call writeDD word(toDD, 1), r.
cnt = cnt + r.0
end
call readDDEnd word(frDD, 1)
call writeDDEnd word(toDD, 1)
interpret ';' subword(frDD, 2) '; ; ;' subword(toDD, 2)
if ggSay == 1 | m.debug == 1 then
say cnt 'records copied from' frSpec 'to' to toSpec
return
endSubroutine writeDsn
/* copy adrTso end ****************************************************/
/* copy j begin *******************************************************
the j framework
jReset
jOpen
jClose
jRead
jWrite
***********************************************************************/
jRead: procedure expose m.
parse arg m, var
call objMetClaM m, 'jRead'
if m.m.jReading then
interpret ggCode
else
return err('jRead('m',' var') but not opened r')
endProcedure jRead
jWrite: procedure expose m.
parse arg m, line
call objMetClaM m, 'jWrite'
if \ m.m.jWriting then
return err('jWrite('m',' line') but not opened w')
interpret ggCode
return
endProcedure jWrite
jWriteR: procedure expose m.
parse arg m, var
call objMetClaM m, 'jWriteR'
if \ m.m.jWriting then
return err('jWriteR('m',' var') but not opened w')
interpret ggCode
return
endProcedure jWriteR
jWriteAll: procedure expose m.
parse arg m, optRdr
if words(optRdr) <= 1 then
optRdr = m.j.cRead optRdr
interpret objMet(m, 'jWriteAll')
return
endProcedure jWriteAll
jWriteNow: procedure expose m.
parse arg m, optRdr
if words(optRdr) <= 1 then
optRdr = m.j.cRead optRdr
interpret objMet(m, 'jWriteNow')
return
endProcedure jWriteNow
jCat: procedure expose m.
parse arg opt m
if m = '' then do
m = opt
opt = m.j.cWri
end
if pos(m.j.cNoOC, opt) < 1 then
call jOpen m, opt
do ax=2 to arg()
call jWriteAll m, arg(ax)
end
if pos(m.j.cNoOC, opt) < 1 then
call jClose m
return m
endProcedure jCat
jWriteNowImpl: procedure expose m.
parse arg m, opt rdr
if pos(m.j.cNoOC, opt) < 1 then
call jOpen rdr, jOpt(opt)
do while jRead(rdr, line)
call jWriteR m, line
end
if pos(m.j.cNoOC, opt) < 1 then
call jClose rdr
return
endProcedure jWriteNow
/*--- reset JRW: fail if open, initialise ---------------------------*/
jReset: procedure expose m.
parse arg m, arg, arg2, arg3
if m.m.jReading == 1 | m.m.jWriting == 1 then
call err 'still open jReset('m',' arg')' / 3
m.m.jReading = 0
m.m.jWriting = 0
interpret objMet(m, 'jReset')
return m
endProcedure jReset
jOpen: procedure expose m.
parse arg m, opt
if pos(m.j.cNoOC, opt) > 0 then
return m
call objMetClaM m, 'jOpen'
if m.m.jReading | m.m.jWriting then
return err('already opened jOpen('m',' opt')')
interpret ggCode
return m
endProcedure jOpen
jClose: procedure expose m.
parse arg m
call objMetClaM m, 'jClose'
if m.m.jReading | m.m.jWriting then
interpret ggCode
m.m.jReading = 0
m.m.jWriting = 0
return m
endProcedure jClose
/*--- analyze an option in oOpt and oVal -----------------------------*/
jOptWkTest: wkTest ??? deimplemented procedure expose m.
parse arg src, alone, val
m.j.oOpt = ''
if left(src, 1) \== '-' then do
m.j.oVal = src
return 0
end
sx = 2
if alone \== '' then do
sx = verify(src, alone, 'n', sx)
if sx = 0 then
sx = length(src)+1
end
if length(src) < sx then
m.j.oVal = ''
else if val == '' then
call err 'bad opt "'src'" should contain only "'alone'"'
else if pos(substr(src, sx, 1), val) < 1 then
call err 'bad opt "'src'" should contain only "'alone'"' ,
'and/or 1 of "'val'" with value'
else do
sx = sx + 1
m.j.oVal = substr(src, sx)
end
m.j.oOpt = substr(src, 2, sx-2)
return 1
endProcedure jOpt
jOpt: procedure expose m.
parse arg src .
if abbrev(src, '>>') then
return m.j.cApp || substr(src, 3)
else if pos(left(src, 1), m.j.cRead||m.j.cWri||m.j.cApp) < 1 then
return m.j.cDum || src
else
return src
endProcedure jOpt
jIni: procedure expose m.
if m.j.ini == 1 then
return
m.j.ini = 1
m.j.cRead = '<'
m.j.cWri = '>'
m.j.cApp = '}'
m.j.cObj = '%'
m.j.cVar = '#'
m.j.cDum = '/'
m.j.cNoOC = '-'
call oIni
am = "call err 'call of abstract method"
call classNew 'n JRW u f JREADING v, f JWRITING v', 'm',
, "new call jReset m, arg, arg2, arg3",
, "jRead" am "jRead('m',' arg')'" ,
, "jWrite" am "jWrite('m',' line')'" ,
, "jWriteR" am "jWriteR('m',' var')'" ,
, "jWriteAll call jWriteNowImpl m, optRdr",
, "jWriteNow call jWriteNowImpl m, optRdr",
, "jReset",
, "jOpen" am" jOpen('m',' opt')'" ,
, "jClose"
am = "call err 'call errObject"
call classNew 'n JRWErr u JRW', 'm',
, "jWriteAll" er "jWriteAll 'm', optRdr'",
, "jWriteNow" er "jWriteNow 'm', 'optRdr'",
, "jClose" er "jClose 'm'"
call classNew 'n JRWSay u JRW', 'm',
, "jWrite say line",
, "jWriteR call classOut , var, 'jOuR: '",
, "jOpen if pos('<', opt) > 0 then",
"call err 'can only write JRWSay.jOpen('m',' opt')';" ,
"else m.m.jWriting = 1"
call classNew 'n JRWEof u JRW', 'm',
, "jRead drop m.var; return 0",
, "jOpen if pos('>', opt) > 0 then",
"call err 'can only read JRWEof.jOpen('m',' opt')';" ,
"else m.m.jReading = 1"
m.j.jIn = oBasicNew('JRWEof')
m.j.jOut = jOpen(oNew('JRWSay'))
call outDest 'i', 'call jOut msg'
call classNew "n JBuf u JRW, f .BUF s r", "m",
, "jOpen return jBufOpen(m, opt)",
, "jReset return jBufReset(m, arg)",
, "jRead return jBufRead(m, var)",
, "jWrite a = mAdd(m'.BUF', line); drop m.class.o2c.a",
, "jWriteR call oCopy var, m'.BUF.'mInc(m'.BUF.0')"
return
endProcedure jIni
jIn: procedure expose m.
parse arg arg
return jRead(m.j.jIn, arg)
endProcedur jIn
jOut: procedure expose m.
parse arg line
call jWrite m.j.jOut, line
return
endProcedure jOut
jOuR: procedure expose m.
parse arg arg
call jWriteR m.j.jOut, arg
return
endProcedure jOut
/*--- jBuf: buffer read or write (supports datataypes) ---------------*/
jBuf: procedure expose m.
m = oNew('JBuf') /* calls jBufReset */
do ax=1 to arg()
m.m.buf.ax = arg(ax)
end
m.m.buf.0 = ax-1
return m
endProcedure jBuf
jBufReset: procedure expose m.
parse arg m
m.m.stem = m'.BUF'
do ax=1 to arg() - 1
m.m.buf.ax = arg(ax+1)
end
m.m.buf.0 = ax-1
return m
endProcedure jBufReset
jBufOpen: procedure expose m.
parse arg m, opt
opt = jOpt(opt)
if abbrev(opt, m.j.cRead) then do
m.m.readIx = 0
m.m.jReading = 1
return m
end
if abbrev(opt, m.j.cWri) then
m.m.buf.0 = 0
else if \ abbrev(opt, m.j.cApp) then
call err 'jBufOpen('m',' opt') with bad opt'
m.m.jWriting = 1
return m
endProcedure jBufOpen
jBufRead: procedure expose m.
parse arg m, var
nx = m.m.readIx + 1
if nx > m.m.buf.0 then
return 0
m.m.readIx = nx
call oCopy m'.BUF.'nx, var
return 1
endProcedure jBufRead
jBufWrite: procedure expose m.
parse arg m, line
call oCopy line, m'.BUF.'mInc(m'.BUF.0')
return 1
endProcedure jBufRead
/* copy j end *********************************************************/
/* copy o begin ******************************************************
an object has a class and may call its methods
***********************************************************************/
oIni: procedure expose m.
if m.o.ini = 1 then
return
m.o.ini = 1
call classIni
call oClassAdded m.class.classV
call mRegister 'Class', 'call oClassAdded arg'
call classNew 'n ORun u',
, 'm oRun call err "call of abstract method oRun"'
return
endProcedure oIni
/*--- when notified about a new class cl, build the redundancies ----*/
oClassAdded: procedure expose m.
parse arg cl
m.class.o2c.cl = m.class.class
m.cl.oAdr = 'O.'substr(cl, 7) /* object adresses */
m.cl.oCnt = 0
new = 'new'
m.cl.oMet.new = ''
call oAddMethod cl'.OMET', cl
call oAddFields mCut(cl'.FLDS', 0), cl
co = '' /* build code for copy */
do fx=1 to m.cl.flds.0
nm = m.cl.flds.fx
if translate(nm) == nm & \ abbrev(nm, 'GG') ,
& pos('.M.', nm'.') < 1 & pos('.T.', nm'.') < 1 then
co = co'm.t'nm '= m.m'nm';'
else
co = co 'f='quote(substr(nm, 2))';m.t.f = m.m.f;'
end
p = cl'.OMET.oCopy'
if symbol('m.p') \== VAR then
m.p = co
return
endProcedure oClassAdded
/*--- add the methods of class cl to the methodtable mt -------------*/
oAddMethod: procedure expose m.
parse arg mt, cl
if pos(m.cl, 'frsv') > 0 then
return
if m.cl = 'm' then do
nm = m.cl.name
m.mt.nm = m.cl.met
return
end
if m.cl.class \== '' then
call oAddMethod mt, m.cl.class
if m.cl.0 \== '' then
do x=1 to m.cl.0
call oAddMethod mt, m.cl.x
end
return
endProcedure oAddMethod
/*--- add the the fields of class cl to stem f ----------------------*/
oAddFields: procedure expose m.
parse arg f, cl, nm
if pos(m.cl, 'rv') > 0 then do
do fx=1 to m.f.0
if m.f.fx == nm then
return 0
end
if nm == '' then do
call mMove f, 1, 2
m.f.1 = ''
end
else do
call mAdd f, nm
end
return 0
end
if m.cl = 'f' then
return oAddFields(f, m.cl.class, nm'.'m.cl.name)
if m.cl.class \== '' then
return oAddFields(f, m.cl.class, nm)
if m.cl.0 = '' then
return 0
do tx=1 to m.cl.0
call oAddFields f, m.cl.tx, nm
end
return 0
endProcedure oAddFields
/*--- create an an object of the class className --------------------*/
oBasicNew: procedure expose m.
parse arg className
cl = class4Name(className)
m.cl.oCnt = m.cl.oCnt + 1
m = m.cl.oAdr'.'m.cl.oCnt
if cl == m.class.classV then
drop m.class.o2c.m
else
m.class.o2c.m = cl
return m
endProcedure oBasicNew
/*--- create an an object of the class className
and call it's new method ------------------------------------*/
oNew: procedure expose m.
parse arg className, arg, arg2, arg3
m = oBasicNew(className)
interpret classMet(className, 'new')
return m
endProcedure oNew
/*--- return the class of object obj --------------------------------*/
objClass: procedure expose m.
parse arg obj
if symbol('m.class.o2c.obj') == 'VAR' then
return m.class.o2c.obj
if abbrev(obj, 'CLASS.CAST.') then
return substr(obj, 12, pos(':', obj, 12)-12)
if arg() >= 2 then
return arg(2)
return err('no class found for object' obj)
endProcedure objClass
/*--- return the code of method me of the class with name na --------*/
classMet: procedure expose m.
parse arg na, me
if symbol('m.class.n2c.na') \== 'VAR' then
call err 'no class' na 'in classMet('na',' me')'
cl = m.class.n2c.na
if symbol('m.cl.oMet.me') \== 'VAR' then
call err 'no method in classMet('na',' me')'
return m.cl.oMet.me
endProcedure classMethod
/*--- set m, ggClass, ggCode to the address, class and code
of method me of object m ------------------------------------*/
objMetClaM: procedure expose m. m ggClass ggCode
parse arg m, me
if symbol('m.class.o2c.m') == 'VAR' then
ggClass = m.class.o2c.m
else if abbrev(m, 'CLASS.CAST.') then
parse var m 'CLASS.CAST.' ggClass ':' m
else
return err('no class found for object' m)
if symbol('m.ggClass.oMet.me') == 'VAR' then
ggCode = m.ggClass.oMet.me
else
call err 'no method' me 'in class' className(ggClass) 'of object' m
return
endProcedure objMetClaM
/*--- return the code of method me of object obj --------------------*/
objMet: procedure expose m.
parse arg obj, me
/* handle the easy and frequent case directly */
if symbol('m.class.o2c.obj') == 'VAR' then do
c = m.class.o2c.obj
if symbol('m.c.oMet.me') == 'VAR' then
return m.c.oMet.me
end
call objMetClaM obj, me
return 'M="'m'";'ggCode
endProcedure objMet
/*--- return the stem of fieldnames of object m ---------------------*/
oFlds: procedure expose m.
parse arg m
return objClass(m)'.FLDS'
endProcedure oFlds
/*--- mutate object m to the class named name -----------------------*/
oMutate: procedure expose m.
parse arg m, name
m.class.o2c.m = class4Name(name)
return m
endProcedure oMutate
/*--- return object obj cast'd to class named cl --------------------*/
oCast: procedure expose m.
parse arg obj, cl
if abbrev(obj, 'CLASS.CAST.') then
obj = substr(obj, 1 + pos(':', obj, 12))
return 'CLASS.CAST.'class4Name(cl)':'obj
endProcedure oCast
/*--- copy object m of class c to t ---------------------------------*/
oClaCopy: procedure expose m.
parse arg ggCla, m, t
ggCode = ggCla'.OMET.oCopy'
interpret m.ggCode
if ggCla == m.class.classV then
drop m.class.o2c.t
else
m.class.o2c.t = ggCla
return t
endProcedure oClaCopy
/*--- copy object m to t --------------------------------------------*/
oCopy: procedure expose m.
parse arg m, t
return oClaCopy(objClass(m, m.class.classV), m, t)
endProcedure oCopy
/*--- copy object to a newly created object -------------------------*/
oCopyNew: procedure expose m.
parse arg m
if symbol('m.o.o2c.m') == 'VAR' then
return oCopy(m, oBasicNew(m.o.o2c.m))
return oCopy(m, oBasicNew(m.class.classV))
endProcedure oCopyNew
/*--- return a new instance of a subclass of Run
with code code in method oRun -------------------------------*/
oRunner: procedure expose m.
parse arg code
t = classNew('n ORun* u', 'm oRun' code)
return oNew(m.t.name)
endProcedure oRunner
/*--- run method oRun of object m -----------------------------------*/
oRun: procedure expose m.
parse arg m, arg, arg2, arg3
interpret objMet(m, 'oRun')
return
endProcedure oRun
/* copy o end *******************************************************/
/* copy class begin *****************************************************
a class has fields and methods,
the class module handles only the metadata,
object handling (instanciation, methodcalls etc.)
is done in O, which, hower, extends the class definitions
meta
c choice name class
f field name class
m method name met
n name name class
r reference class
s stem class
u union stem
v value
class expression (ce) allow the following syntax
ce = name | 'v' | 'r' ce? | ('n' | 'f' | 'c') name ce
| 's' ce | 'm' name code | 'u' (ce (',' ce)*)?
'm' and 'u' extend to the end of whole ce
***********************************************************************/
classIni: procedure expose m.
if m.class.ini == 1 then
return
m.class.ini = 1
call mapIni
/* to notify other modules (e.g. O) on every new named class */
call mRegisterSubject 'Class',
, 'call classAddedListener subject, listener'
m.class.0 = 0
m.class.tmp.0 = 0
call mapReset 'CLASS.N2C' /* name to class */
/* meta meta data: description of the class datatypes */
m.class.classV = classNew('v')
m.class.classR = classNew('r')
m.class.class = classNew('n class u', '\')
call classNew 'class',
, 'c v v' ,
, 'c r f CLASS r class' ,
, 'c s f CLASS r class' ,
, 'c u s r class',
, 'c f' classNew('u f NAME v, f CLASS r class'),
, 'c n' classNew('u f NAME v, f CLASS r class'),
, 'c c' classNew('u f NAME v, f CLASS r class'),
, 'c m' classNew('u f NAME v, f MET v')
return
endProcedure classIni
/*--- to notify a new listener about already defined classes --------*/
classAddedListener: procedure expose m.
parse arg subject, listener
do y = 1 to m.class.0
if m.class.y == 'n' then
call mNotify1 'Class', listener, 'CLASS.'y
end
return
endProcedure classAddedListener
/*--- return the name of a class if it exists otherwise the class ---*/
className: procedure expose m.
parse arg cl
if m.cl = 'n' then
return m.cl.name
else
return cl
endProcedure class4Name
/*--- return class of given name or class ---------------------------*/
class4Name: procedure expose m.
parse arg nm
if symbol('m.class.n2c.nm') == 'VAR' then
return m.class.n2c.nm
if arg() > 1 then
return arg(2)
call err 'no class' nm
endProcedure class4Name
/*--- get or create a class from the given class expression
arg(2) may contain options
'\' do not search for existing class
'+' do not finish class
type (1 char) type of following args
the remaining args are type expressions and will
be added to the first union -----------------------------*/
classNew: procedure expose m.
parse arg clEx
if arg() <= 1 then
if mapHasKey(class.n2c, clEx) then
return mapGet(class.n2c, clEx)
oldTmp = m.class.tmp.0
ox = verify(arg(2), '\+')
if ox < 1 then
ox = length(arg(2)) + 1
opts = left(arg(2), ox-1)
pr = substr(arg(2), ox, (length(arg(2)) = ox) * 2)
t = classNewTmp(clEx)
if arg() > 1 then do
u = t
do while m.u \== 'u'
if m.u.class == '' then
call err 'no union found' clEx
u = m.u.class
end
do ax = 2 + (opts \== '' | pr \== '') to arg()
call mAdd u, classNew(pr || arg(ax))
end
end
p = classPermanent(t, pos('\', opts) < 1)
if arg() <= 1 then
call mapAdd class.n2c, clEx, p
if p == t & pos('+', opts) < 1 then
call mNotify 'Class', p
m.class.tmp.0 = oldTmp
return p
endProcedure classNew
/*--- create a temporary class
with type ty, name nm and class expression ce ---------------*/
classNewTmp: procedure expose m.
parse arg ty nm ce
if length(ty) > 1 then do
if nm \== '' then
call err 'class' ty 'should stand alone:' ty nm ce
return class4Name(ty)
end
t = mAdd(class.tmp, ty)
m.t.name = ''
m.t.class = ''
m.t.met = ''
m.t.0 = ''
if pos(ty, 'v') > 0 then do
if nm \== '' then
call err 'basicClass' ty 'end of Exp expected:' ty nm ce
end
else if ty = 'u' then do
fx = 0
m.t.0 = 0
ce = nm ce
ux = 0
do until fx = 0
tx = pos(',', ce, fx+1)
if tx > fx then
sub = strip(substr(ce, fx+1, tx-fx-1))
else
sub = strip(substr(ce, fx+1))
if sub \== '' then do
ux = ux + 1
m.t.ux = classNewTmp(sub)
end
fx = tx
end
m.t.0 = ux
end
else if nm == '' & ty \== 'r' then do
call err 'basicClass' ty 'name or class Exp expected:' ty nm ce
end
else do
if pos(ty, 'sr') > 0 then do
if nm \== '' then
m.t.class = classNewTmp(nm ce)
end
else do
if pos(ty, 'cfmn') < 1 then
call err 'unsupported basicClass' ty 'in' ty nm ce
m.t.name = nm
if ty = 'm' then
m.t.met = ce
else if ce = '' then
call err 'basicClass' ty 'class Exp expected:' ty nm ce
else
m.t.class = classNewTmp(ce)
end
end
return t
endProcedure classNewTmp
/*--- return the permanent class for the given temporary class
an existing one if possible otherwise a newly created -------*/
classPermanent: procedure expose m.
parse arg t, srch
if \ abbrev(t, 'CLASS.TMP.') then
return t
if m.t.class \== '' then
m.t.class = classPermanent(m.t.class, srch)
if m.t.0 \== '' then do
do tx=1 to m.t.0
m.t.tx = classPermanent(m.t.tx, srch)
end
end
/* search equal permanent class */
do vx=1 to m.class.0 * srch
p = class'.'vx
if m.p.search then
if classEqual(t, p, 1) then
return p
end
p = mAdd(class, m.t)
m.p.name = m.t.name
m.p.class = m.t.class
m.p.met = m.t.met
m.p.search = srch
if m.t.0 > 0 then
call mAddSt mCut(p, 0), t
else
m.p.0 = m.t.0
if mapHasKey(class.n2c, p) then
call err 'class' p 'already defined as className'
else
call mapAdd class.n2c, p, p
if m.p = 'n' then do
if right(m.p.name, 1) == '*' then
m.p.name = left(m.p.name, length(m.p.name)-1) ,
|| substr(p, length('class.x'))
if mapHasKey(class.n2c, m.p.name) then
call err 'class' m.p.name 'already defined'
else
call mapAdd class.n2c, m.p.name, p
if srch then
call mNotify 'Class', p
end
return p
endProcedure classPermanent
/*--- return true iff the two classes are equal
(up to the name pattern if lPat == 1) -----------------------*/
classEqual: procedure expose m.
parse arg l, r, lPat
if m.l \== m.r | m.l.class \== m.r.class | m.l.0 \= m.r.0,
| m.l.met \== m.r.met then
return 0
if m.l.name \== m.r.name then
if lPat \== 1 | right(m.l.name, 1) \== '*' ,
| \ abbrev(m.r.name,
, left(m.l.name, length(m.l.name)-1)) then
return 0
if m.l.0 == '' then
return 1
do sx=1 to m.l.0
if m.l.sx \== m.r.sx then
return 0
end
return 1
endProcedure classEqual
/*--- recursively ouput (with out:) the object a with class t -------*/
classOut: procedure expose m.
parse arg t, a, pr, p1
return classOutDone(t, a, pr, p1)
return x
endProcedure classOut
/*--- ouput object a with class t and stopper done ------------------*/
classOutDone: procedure expose m. done.
parse arg t, a, pr, p1
if p1 == '' then
p1 = pr
if right(p1, 1) \== ' ' then
p1 = p1' '
if done.ini \== 1 then do
done.ini = 1
t = class4Name(t, t)
p1 = p1'@'a' '
end
if done.t.a == 1 then
return out(p1'done :'className(t) '@'a)
done.t.a = 1
if t = '' then do
t = objClass(a, '')
if t = '' then
return out(p1'obj has no class @'m.a)
else
return classOutDone(t, a, pr, p1'isA')
end
if m.t == 'v' then
return out(p1'=' m.a)
if m.t == 'n' then
return classOutDone(m.t.class, a, pr, p1':'m.t.name)
if m.t == 'f' then
return classOutDone(m.t.class, a'.'m.t.name, pr, p1'.'m.t.name)
if m.t == 'r' then do
if m.a == '' then
call out p1'refTo :'className(m.t.class) '@null@'
else
return classOutDone(m.t.class, m.a, pr,
, p1'refTo @'m.a)
end
if m.t = 'u' then do
t1 = m.t.1
vv = m.t.0 > 0 & m.t1 == 'v'
call out p1'union' || copies(' =' m.a, vv)
do ux=1+vv to m.t.0
call classOutDone m.t.ux, a, pr' '
end
return 0
end
if m.t = 's' then do
call out p1'stem' m.a.0
do ux=1 to m.a.0
call classOutDone m.t.class, a'.'ux, pr' ', pr' .'ux
end
return 0
end
if m.t = 'c' then do
if m.t.name = m.a then
call classOutDone m.t.class, a, pr, p1'choice' m.a
return 0
end
if m.t = 'm' then
return 0
return err('bad class type' m.t)
endProcedure classOutDone
/* copy class end ****************************************************/
/* copy mapExp begin **************************************************/
mapVia: procedure expose m.
parse arg a, ky
sx = pos('*', ky)
if sx < 1 then
return mapGet(a, ky)
via = mapGet(a, left(ky, sx-1))
do while sx <= length(ky)
fx = sx+1
sx = pos('*', ky, fx)
if sx < 1 then
sx = length(ky) + 1
if sx = fx then do
if symbol('m.via') \== 'VAR' then
call err 'missing m.'via 'at' sx 'in mapVia('a',' ky')'
via = m.via
end
else do
f = substr(ky, fx, sx - fx)
if symbol('m.via.f') \== 'VAR' then
call err 'missing m.'via'.'f ,
'at' sx 'in mapVia('a',' ky')'
via = m.via.f
end
end
return via
endProcedure mapVia
mapExpAt: procedure expose m.
parse arg a, src, sx
m.map.ExpAt = 0
cx = pos('$', src, sx)
if cx < 1 then
return substr(src, sx)
res = substr(src, sx, cx-sx)
do forever
if substr(src, cx+1, 1) = '{' then do
ex = pos('}', src, cx+2)
if ex < 1 then
call err 'missing } after' substr(src, cx) 'in' src
res = res || mapVia(a, strip(substr(src, cx+2, ex-cx-2)))
ex = ex + 1
end
else do
ex = verify(src, m.mAlfDot, 'n', cx+1)
if ex < 1 then
return res || mapVia(a, substr(src, cx+1))
if ex = cx+1 then do
m.map.ExpAt = cx
return res
end
res = res || mapVia(a, substr(src, cx+1, ex-cx-1))
end
cx = pos('$', src, ex)
if cx < 1 then
return res || substr(src, ex)
res = res || substr(src, ex, cx-ex)
end
endProcedure mapExpAt
mapExp: procedure expose m.
parse arg a, src
res = mapExpAt(a, src, 1)
if m.map.ExpAt \== 0 then
call err 'mapExp stopped at' substr(src, map.ExpAt) 'in' src
return res
endProcedure mapExp
mapExpAllAt: procedure expose m.
parse arg a, dst, src, sx, cx
do while sx <= m.src.0
li = mapExpAt(a, m.src.sx, cx)
dx = m.map.ExpAt
if (cx=1 & dx = 0) | li \= '' then
call mAdd dst, li
if dx = 0 then do
cx = 1
sx = sx+1
end
else do
return sx dx
end
end
return ''
endProcedure mapExpAllAt
mapExpAll: procedure expose m.
parse arg a, dst, src
sto = mapExpAllAt(a, dst, src, 1, 1)
if sto == '' then
return
lx = word(sto, 1)
call err 'mapExpAll stopped at' sto':' m.src.lx
endProcedure mapExpAll
/* copy mapExp end ****************************************************/
/* copy map begin ******************************************************
a map stores values at keys
it may also maintain a list of keys
the basic ideas are similar to the java Interface java.util.Map
contrary to stems we also handle keys longer then 250 bytes
***********************************************************************/
/*--- initialize the module ------------------------------------------*/
mapIni: procedure expose m.
if m.map.ini = 1 then
return
m.map.ini = 1
call mIni
m.map.0 = 0
m.map.inlineSearch = 1
return
endProcedure mapIni
mapInline: procedure expose m.
parse arg pName
if mapHasKey(map.inlineName, pName) then
return mapGet(map.inlineName, pName)
if m.map.inlineSearch == 1 then
call mapReset map.inlineName, map.inline
inData = 0
name = ''
do lx=m.map.inlineSearch to sourceline()
if inData then do
if abbrev(sourceline(lx), stop) then do
inData = 0
if pName = name then
leave
end
else do
call mAdd act, strip(sourceline(lx), 't')
end
end
else if abbrev(sourceline(lx), '/*<<') then do
parse value sourceline(lx) with '/*<<' name '<<' stop
name = strip(name)
stop = strip(stop)
if stop == '' then
stop = name
if words(stop) <> 1 | words(name) <> 1 then
call err 'bad inline data' strip(sourceline(lx))
if mapHasKey(map.inline, name) then
call err 'duplicate inline data name' name ,
'line' lx strip(sourceline(lx), 't')
act = mapAdd(map.inlineName, name,
, mCut('MAP.INLINE.' || (m.map.inline.0 + 1), 0))
inData = 1
end
end
if inData then
call err 'inline Data' name 'at' m.map.inlineSearch,
'has no end before eof'
m.map.inlineSearch = lx + 1
if name = pName then
return act
if arg() > 1 then
return arg(2)
call err 'no inline data named' pName
endProcedure mapInline
/*--- create a new map ----------------------------------------------*/
mapNew: procedure expose m.
parse arg opt
return mapReset('MAP.'mInc('MAP.0') , opt)
endProcedure mapNew
/*--- make an empty map, if opt <> '' maintain stem of keys
('K' in map.keys, '=' in a else in opt) --------------*/
mapReset: procedure expose m.
parse arg a, opt
if symbol('m.map.keys.a') == 'VAR' then
call mapClear a
if opt = '=' then
st = a
else if translate(opt) = 'K' then
st = 'MAP.KEYS.'a
else
st = opt
m.map.keys.a = st
if st \== '' then
m.st.0 = 0
return a
endProcedure
/*--- add a new key value pair to the map ----------------------------*/
mapAdd: procedure expose m.
parse arg a, ky, val
vv = mapValAdr(a, ky, 'a')
m.vv = val
return val
endProcedure mapAdd
/*--- change the value at a key or add key value ---------------------*/
mapPut: procedure expose m.
parse arg a, ky, val
vv = mapValAdr(a, ky, 'p')
m.vv = val
return val
endProcedure mapPut
/*--- return 1 if key ky exists in map a, 0 otherwise ----------------*/
mapHasKey: procedure expose m.
parse arg a, ky
return mapValAdr(a, ky) \== ''
endProcedure mapHasKey
/*--- return the value of key ky in map a if it exists,
else if called with a third argument return third argument
else issue an error ----------------------------------------*/
mapGet: procedure expose m.
parse arg a, ky
vv = mapValAdr(a, ky)
if vv \== '' then
return m.vv
else if arg() > 2 then
return arg(3)
else
call err 'missing key in mapGet('a',' ky')'
endProcedure mapGet
/*--- return a stem of all keys --------------------------------------*/
mapKeys: procedure expose m.
parse arg a
if m.map.keys.a == '' then
call err 'mapKeys('a') with no keys'
return m.map.keys.a
endProcedure mapKeys
/*--- remove a key from the map, do nothing if it is missing ---------*/
mapRemove: procedure expose m.
parse arg a, ky
vv = mapValAdr(a, ky)
if vv == '' then
return ''
if m.map.keys.a \== '' then do
trace ?R /* not tested yet ???wkTest */
k = m.map.keys.a
mx = m.k.0
do i=1 to mx
if m.k.i == ky then do
m.k.i = m.k.mx
m.k.0 = mx - 1
return
end
end
end
val = m.a.vv
drop m.a.ky
return val
endProcedure mapRemove
/*--- remove all entries ---------------------------------------------*/
mapClear: procedure expose m.
parse arg a
st = mapKeys(a)
do kx=1 to m.st.0
k = m.st.kx
if length(k) > 200 then do
k = left(k, 201)
if symbol('m.a.k') == 'VAR' then/* ist noch hier */
call mapClear m.a.k
end
drop m.a.k m.st.kx
end
m.st.0 = 0
return a
endProcedure mapClear
/*--- return the value pointer for a key, '' if non existing
with fun = 'a' add a key, with 'p' put a key ------------*/
mapValAdr: procedure expose m.
parse arg pA, pKy, fun
a = pA
ky = pKy
do forever
if length(ky) <= 200 then do
if symbol('m.a.ky') \== 'VAR' then
leave
if fun == 'a' then
call err 'duplicate key' pKy 'in map' pA
return a'.'ky
end
k1 = left(ky, 201)
if symbol('m.a.k1') \== 'VAR' then
leave
a = m.a.k1
ky = substr(ky, 202)
end
if fun == '' then
return ''
opt = left('K', m.map.keys.pA \== '')
if opt == 'K' then
call mAdd m.map.Keys.pA, pKy
do while length(ky) > 200
k1 = left(ky, 201)
n = mapNew(opt)
m.a.k1 = n
if a \== pA & opt == 'K' then
call mAdd m.map.keys.a, ky
a = n
ky = substr(ky, 202)
end
return a'.'ky
endProcedure mapValAdr
/* copy map end *******************************************************/
/* copy m begin ********************************************************
we use variables as follows
m. stem m: all global data and object data that must survive
a procedure call (m for memory in Memoria of B5000)
m.<mbr>.** to avoid conflicts: every rexx Module (copy) should
only allocate addresses m.<mbr>.** with <mbr> the name of
the rexx module
we pass parameters around (e.g. a=address, m=memory, st=stem)
and the called function may use m.a or m.a.subField etc.
gg*: local variable in subroutines without procedure
everything else: temporary data within procedure
every subroutine is declared as procedure expose m.
(also if no m. variable is used, because e.g. of error handling)
the few subroutines that cannot use procedure, should use only
variables starting with gg
***********************************************************************/
/*--- increase m.a and return it (fail if undefined) -----------------*/
mInc: procedure expose m.
parse arg a
m.a = m.a + 1
return m.a
endProcedure mInc
/*--- cut stem a to length len ---------------------------------------*/
mCut: procedure expose m.
parse arg a, len
m.a.0 = len
return a
endProcedure mCut
/*--- add one or several arguments to stem m.a -----------------------*/
mAdd: procedure expose m.
parse arg a
ix = m.a.0
do ax = 2 to arg()
ix = ix + 1
m.a.ix = arg(ax)
end
m.a.0 = ix
return a'.'ix
endProcedure mAdd
/*--- pop last element from stem m.a ---------------------------------*/
mPop: procedure expose m.
parse arg a
ix = m.a.0
if ix < 1 then
call err 'pop from empty stem' a
m.a.0 = ix-1
return m.a.ix
endProcedure mPop
/*--- add to m.dst.* a (sub)sequence of m.src.* ----------------------*/
mAddSt: procedure expose m.
parse arg dst, src
dx = m.dst.0
do sx = 1 to m.src.0
dx = dx + 1
m.dst.dx = m.src.sx
end
m.dst.0 = dx
return
endProcedure mAddSt
/*--- move a part of a stem ------------------------------------------*/
mMove: procedure expose m.
parse arg m, sx, dx
if dx < sx then do
y = dx
do x=sx to m.m.0
m.m.y = m.m.x
y = y + 1
end
end
else if dx > sx then do
y = m.m.0 + dx - sx
do x=m.m.0 by -1 to sx
m.m.y = m.m.x
y = y - 1
end
end
m.m.0 = m.m.0 + dx - sx
return
endProcedure mMove
/*--- strip all elements of a stem -----------------------------------*/
mStrip: procedure expose m.
parse arg st, opt
if opt == '' then
opt = 'b'
do x=1 to m.st.0
m.st.x = strip(m.st.x, opt)
end
return st
endProcedure mStrip
/*--- cat all elements of a stem together ----------------------------*/
mCat: procedure expose m.
parse arg st, mid
if m.st.0 < 1 then
return ''
res = m.st.1
do x=2 to m.st.0
res = res || mid || m.st.x
end
return res
endProcedure mCat
/*--- notify all listeners of subject subj with argument arg --------*/
mNotify: procedure expose m.
parse arg subj, arg
if symbol('m.m.subLis.subj') \== 'VAR' then
call err 'subject' subj 'not registered'
do lx=1 to m.m.subLis.subj.0
call mNotify1 subj, lx, arg
end
return
endProcedure mNotify
/*--- notify the listener listener of subject subj with arg ---------*/
mNotify1: procedure expose m.
parse arg subject, listener, arg
interpret m.m.subLis.subject.listener
return
endProcedure mNotify1
/*--- notify subject subject about a newly registered listener
or a new subject about previously registered listener -------*/
mNotifySubject: procedure expose m.
parse arg subject, listener
interpret m.m.subLis.subject
return
endProcedure mNotifySubject
/*--- register a new subject with the code for mNotifySubject -------*/
mRegisterSubject: procedure expose m.
parse arg subj, addListener
if symbol('m.m.subLis.subj') == 'VAR' then
call err 'subject' subj 'already registered'
m.m.subLis.subj = addListener
if symbol('m.m.subLis.subj.0') \== 'VAR' then do
m.m.subLis.subj.0 = 0
end
else do lx=1 to m.m.subLis.subj.0
call mNotifySubject subj, lx
end
return
endProcedure registerSubject
/*--- register a listener to subject subj with the code for mNotify -*/
mRegister: procedure expose m.
parse arg subj, notify
if symbol('m.m.subLis.subj.0') \== 'VAR' then
m.m.subLis.subj.0 = 0
call mAdd 'M.SUBLIS.'subj, notify
if symbol('m.m.subLis.subj') == 'VAR' then
call mNotifySubject subj, m.m.subLis.subj.0
return
endProcedure mRegister
mIni: procedure expose m.
if m.m.ini = 1 then
return
m.m.ini = 1
m.mAlfLC = 'abcdefghijklmnopqrstuvwxyz'
m.mAlfUC = translate(m.mAlfLC)
m.mAlfa = m.mAlfLC || m.mAlfUC
m.mAlfNum = m.mAlfa || '0123456789'
m.mAlfDot = m.mAlfNum || '.'
return
endProcedure mIni
/* copy m end *********************************************************/
/* copy stringUt begin ***********************************************/
/*--- return the count of occurrences of needle in heyStack ----------*/
posCount: procedure
parse arg needle, hayStack, start, fin
if start = '' then
start = 1
if fin = '' then
fin = length(hayStack) + 1 - length(needle)
do cnt = 0 by 1
start = pos(needle, haystack, start)
if start < 1 | start > fin then
return cnt
start = start + length(needle)
end
endProcedure posCount
repAll: procedure expose m.
parse arg src, w, new
res = ''
cx = 1
do forever
nx = pos(w, src, cx)
if nx < 1 then
return res || substr(src, cx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAll
repAllWords: procedure expose m.
parse arg src, w, new
res = ''
wx = 0
cx = 1
do forever
wx = wordPos(w, src, wx+1)
if wx < 1 then
return res || substr(src, cx)
nx = wordindex(src, wx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAllWords
/* copy stringUt end ***********************************************/
/* copy err begin ******************************************************
messages, errorhandling,help
***********************************************************************/
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
parse arg m.err.opt, ha
if pos('I', translate(m.err.opt)) > 0 then
if sysVar('sysISPF') = 'ACTIVE' then
call adrIsp 'control errors return'
if ha == '' then
drop m.err.handler
else
m.err.handler = ha
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
drop err handler opt
if ggOpt == '' & symbol('m.err.handler') == 'VAR' then
interpret value('m.err.handler')
call outDest
call errSay ggTxt, 'e'
if ggOpt == '' & symbol('m.err.opt') == 'VAR' then
ggOpt = value('m.err.opt')
ggOpt = translate(ggOpt)
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 then do
call errSay 'divide by zero to show stackHistory', 'e'
x = 1 / 0
end
call errSay 'exit(12)', 'e'
exit errSetRc(12)
endSubroutine err
/*--- assert that the passed rexx expression evaluates to true -------*/
assert:
interpret 'assertRes =' arg(1)
if \ assertRes then
call err 'assert failed' arg(1)':' arg(2)
return
endProcedure assert
/*--- output an errorMessage msg with pref pref
split message in lines at '/n' ---------------------------*/
errSay: procedure expose m.
parse arg msg, pref
parse source . . ggS3 . /* current rexx */
if pref == 'e' then
msg = 'fatal error in' ggS3':' msg
else if pref == 'w' then
msg = 'warning in' ggS3':' msg
else if pref \== '' then
msg = pref':' msg
return outLn(msg)
endProcedure errSay
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg, op
call errSay msg, 'e'
call help
call err msg, op
endProcedure errHelp
/*--- return the Operating System we are running on: TSO or LINUX ---*/
errOS: procedure expose m.
parse source os .
return os
endProcedure errOS
/*--- set rc for ispf: -------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared varible 3IspfRc
back as return code
----------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- output a trace message if m.tr is set -----------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
call out 'debug' msg
return
endProcedure debug
/*--- return current time and cpu usage ------------------------------*/
timing: procedure expose m.
return time() time('E') sysvar('syscpu') /* sysvar('syssrv') */
/*--- display the first comment block of the source as help -----------*/
help: procedure expose m.
parse source . . s3 .
call out right(' help for rexx' s3, 79, '*')
do lx=1 by 1
if pos('/*', sourceLine(lx)) > 0 then
leave
else if lx > 10 then do
call out '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
call out li
end
call out right(' end help for rexx' s3, 79, '*')
return 4
endProcedure help
/*--- output a message to the current destination -------------------*/
out: procedure expose m.
parse arg msg
if symbol('m.err.out') \== 'VAR' then
call outDest
interpret m.err.out
return 0
endProcedure out
/*--- output all lines (separated by '\n') of all args --------------*/
outLn: procedure expose m.
do ax=1 to max(1, arg())
msg = arg(ax)
sx = 0
bx = -1
do lx=1 until bx >= length(msg)
ex = pos('\n', msg, bx+2)
if ex < 1 then
ex = length(msg)+1
call out substr(msg, bx+2, ex-bx-2)
bx = ex
end
end
return 0
endProcedure outLn
/*--- set and return some frequent destinations for out -------------*/
outDest: procedure expose m.
parse arg ty, a
if ty == '' | symbol('m.err.out') \== 'VAR' then
m.err.out = 'say msg'
if ty == 's' then
m.err.out = 'st='quote(a)';sx=m.st.0+1;m.st.0=sx;m.st.sx=msg'
else if ty == 'i' then
m.err.out = a
else if \ abbrev('=', ty) then
call err 'bad type in outDes('ty',' a')'
return m.err.out
endProcedure outDest
/*--- 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
/* copy err end *****************************************************/
}¢--- A540769.WK.REXX(TX) cre=2013-12-23 mod=2016-09-12-17.24.23 A540769 -------
/* rexx ****************************************************************
tx: testDriver
as editMacro: tx fun
from tso: tx pdsMbr fun
fun = empty execute unprocessed statements
r clear process flags and execute from beginning
c clear process flags
version v2.1 with ws3 from 3. 9.15
***********************************************************************/
call errReset 'hI'
call wshIni
m.sql_retOK = 'dne rod'
parse arg oArgs
args = oArgs
if 0 then
oArgs = 'L DSN.MAREC.DBZF.D090702.T175332.JOB101(STAALL)' ,
'001 YMRCO001 rebu wa'
m.dbConn = ''
m.tx_ini = 0
m.tx.isMacro = oArgs == '' & sysVar('sysISPF') = 'ACTIVE'
if m.tx.isMacro then
m.tx.isMacro = adrEdit('macro (oArgs)', '*') == 0
if m.tx.isMacro then do
call adrEdit '(pds) = dataset'
call adrEdit '(mbr) = member'
parse var oArgs o1 o2
if length(o1) > 8 then do
m.tx.isMacro = 0
end
else if length(o1) > 2 then do
args = pds'('o1')' o2
m.tx.isMacro = 0
end
else do
if mbr == '' then
call err 'edit a pds member not' pds
args = pds'('mbr')' oArgs
do sx=1
call adrEdit '(cha) = data_changed'
if sx > 3 then
call err 'cannot save member'
if cha = 'NO' then
leave
say '...saving member' pds'('mbr')'
call adrEdit 'save', '*'
end
end
end
if args = '' | pos('?', args) > 0 then
exit help()
parse var args dsn fun opts
dsn = dsn2jcl(dsn)
call vPut 'dsn', dsn
call vPut 'pds', dsnSetMbr(dsn)
mbr = dsnGetMbr(dsn)
if mbr = '' | length(mbr) > 7 then
call errHelp 'first arg word not a pds with member <=7:' args
call vPut 'mbr', mbr
call vPut 'mpr', if(length(mbr) <= 5, mbr, left(mbr, 5))
call vPut 'ini', dsnSetMbr(dsn, 'INI')
call vPut 'gen', ''
if abbrev(fun, '-') then do
opts = substr(fun, 2) opts
fun = ''
end
ib = jBuf()
m.tx.inp = ib
m.tx.iBuf = ib'.BUF'
call readDsn dsn, 'M.'m.tx.iBuf'.'
m.tx.comp = comp(ib)
m.tx.save = 0
m.tx.outAdd.0 = 0
if fun = '' then do
call txCont opts
end
else if fun = 'c' then do
call txReset m.tx.iBuf, opts
end
else if fun = 'r' then do
call txReset m.tx.iBuf, opts
call txSave
call readDsn dsn, 'M.'m.tx.iBuf'.'
call txCont opts
end
else
call errHelp 'bad fun' fun 'in args' oArgs
call txSave
call dbConn
exit
dbConn: procedure expose m.
parse arg sub
if m.dbConn = sub then
return
if m.dbConn \== '' then
call sqlDisconnect
if sub \== '' then
call sqlConnect sub
m.dbConn = sub
say 'connected to' sub
return
endProcedure dbConn
sqlProc: procedure expose m.
parse arg inp, pJ72
say sqlProc 'j72' pJ72
call sqlStmts inp, 100, if(pJ72==1, 's')
return
endProcedure sqlProc
txCmpRun: procedure expose m.
parse arg ki, inpDsn, outDsn
say 'txCmpRun' inpDsn '->' outDsn / 0
call compRun ki, file(inpDsn), file(outDsn)
say 'txCmpRun -> ended'
return
endProcedure txCmpRun
/*--- remove all history information from testcase,
so it will restart from scratch next time --------------------*/
txReset: procedure expose m.
parse arg i
z = 0
do y=1 to m.i.0
if pos(firstNE(m.i.y), '-+') > 0 then
iterate
z = z + 1
m.i.z = m.i.y
end
m.tx.save = z \= m.i.0
m.i.0 = z
return
endProcedure txReset
/*--- save testcase member if necessary ------------------------------*/
txSave: procedure expose m.
if m.tx.save = 0 then
return
ib = m.tx.iBuf
if m.tx.save = 1 then do
if \ m.tx.isMacro then do
call writeDsn vGet('dsn'), 'M.'ib'.', , 1
return
end
call adrEdit 'del .zf .zl'
do y=1 to m.ib.0
li = m.ib.y
call adrEdit 'line_after .zl = (li)'
end
call adrEdit 'save'
end
else if m.tx.save = 2 then do
ox = 0
ix = 0
if m.tx.isMacro then do
added = 0
do y=1 to m.tx.outAdd.0
parse var m.tx.outAdd.y ax li
call adrEdit 'line_after' (added+ax) '= (li)'
added = added + 1
end
call adrEdit 'save'
end
else do
do y=1 to m.tx.outAdd.0
parse var m.tx.outAdd.y ax li
do while ix < ax
ox = ox + 1
ix = ix + 1
oo.ox = m.ib.ix
end
ox = ox + 1
oo.ox = li
end
do while ix < m.ib.0
ox = ox + 1
ix = ix + 1
oo.ox = m.ib.ix
end
call writeDsn vGet('dsn'), 'OO.', ox, 1
end
end
else
call err 'implement save' m.tx.save
m.tx.save = 0
return
endProcedure txSave
/*--- return first non Space (Empty) char from str, '' if all spaces -*/
firstNE: procedure expose m.
parse arg str
c1 = verify(str, ' ')
if c1 > 0 then
return substr(str, c1, 1)
return ''
endProcedure firstNE
/*--- continue testcase
maximal cnt steps,
until testcase has to wait or is at end --------------------*/
txCont: procedure expose m.
parse arg cnt
cmp = m.tx.comp
call compBegin cmp
scn = m.cmp.scan
run = ''
one = ''
instr = ''
do forever
inst1 = ''
one = compile(cmp, ':')
if scanEnd(scn) then do
end
else if left(m.scn.src, m.scn.pos-1) <> '' then
call scanErr scn, 'bad text before tx instruction'
else if scanLit(scn, '+', '-') then do
if m.scn.tok == '+' then do
call scanName scanSkip(scn)
if translate(m.scn.tok) <> 'OK' then do
say m.scn.src
return
end
instr = ''
end
call scanNl scn, 1
end
else if scanName(scn) then do
fun = m.scn.tok
if wordPos(translate(fun), 'CREDB MANUAL NOP') < 1 then
call scanErr scn, fun 'is no tx instruction'
inst1 = word(scanPos(scn), 1) fun compExpr(cmp, 's', '=')
end
else
call scanErr scn, fun 'bad tx instruction'
if instr <> '' then do
do rx = 1 to words(run)
call oRun word(run, rx)
end
run = ''
call txIni
parse var instr m.tx.inPos fun rAst
cd = 'res = txFun'fun'('compAst2Rx(cmp, '-', rAst)')'
m.tx.outSta = 0
interpret cd
say 'res' res 'outSta' m.tx.outSta 'from' cd
if m.tx.outSta = 2 then
return
if m.tx.outsta \== 1 then
call err 'bad outSta' m.tx.outSta 'after' code
end
instr = inst1
run = run one
if instr = '' & scanEnd(scn) then
return
end
call err 'no paseran'
endProcedure txCont
txIni: procedure expose m.
if m.tx_ini then
return
call wshRun tx, ':', file(vGet('ini'))
m.tx_ini = 1
return
endProcedure txIni
/*--- output a status line -------------------------------------------*/
txOutSta: procedure expose m.
parse arg op fun, rest
if m.tx.save = 0 then
m.tx.save = 2
else if m.tx.save <> 2 then
call err 'txOutSta but save='m.tx.save
fun = strip(fun)
if op == '+' then do
m.tx.outSta = max(m.tx.outSta,
, 1 + (wordPos(translate(fun), 'RUN WAIT') > 0) )
end
else if op \== '-' then
call err 'bad op' op 'in txOutSta('op fun',' rest')'
call mAdd 'TX.OUTADD', m.tx.inPos op fun strip(rest)
say 'outSta' m.tx.outSta 'after' op fun strip(rest)
return
endProcedure txOutSta
/*--- do nothing and continue-----------------------------------------*/
txFunNop: procedure expose m.
parse arg opts
if vHasKey('nopCount') then
old = vGet('nopCount')
else
old = 0
call txOutSta '= nopCount', old+1
call txOutSta '+ ok', 'nop'
call txOutSta '- nop', 'opts =' opts
call txOutSta '- nop', 'opts =' opts
return 1
endProcedure txFunNop
/*--- Manual action required -----------------------------------------*/
txFunManual: procedure expose m.
parse arg opts
call txOutSta '+ wait', opts
say 'manual <'opts'>'
return 1
endProcedure txFunManual
/*--- creDb: sql creates, date etc. ----------------------------------*/
txFunCreDb: procedure expose m.
parse arg dst pha .
say 'txFunCreDb' dst pha 'ddl' vGet('ddl')
if wordPos(dst, 'src trg') < 1 then
call err 'creDb bad dest should be src or trg not' dst
if pha = '' | verify(pha, '0123456789') > 0 then
call err 'creDb not natural number but' pha
call vPut 'phase' , strip(pha)
call vPut 'env' , dst
call vPut 'dbSys' , vGet(dst'dbSys' )
call vPut 'db' , vGet(dst'db' )
call vPut 'creator', vGet(dst'creator')
call vPut 'cr', vGet(dst'creator')
gen = vGet('gen')
if gen \== '' then
gen = gen'('vGet('mpr')left(dst, 1)pha')'
call pipe '+F', file(gen '::f')
call wshRun tx, '=', file(vGet('ddl'))
call pipe '-'
/* call adrIsp "edit dataset('"gen"')", 4 */
call dbConn vGet('dbSys')
m.sq.ignore.drop = '-204'
j72 = 0
if vHasKey('j72') then
j72 = vGet('j72')
call sqlProc file(gen), j72
call txOutSta '+ ok', 'creDb' gen
return 1
endProcedure txCreDb
/* copy wsh ab hier ???????*/
/* rexx ***************************************************************
wsh: walter's rexx shell version 6.2
interfaces: 4. 8.16
edit macro: for adhoc evaluation or programming
either block selection: q or qq and b or a
oder mit Directives ($#...) im Text
wsh i: tso interpreter
wsh s: sql processor
batch: input in dd wsh
docu: http://chw20025641/host/db2wiki/pmwiki.php?n=Main.Wsh
syntax: http://chw20025641/host/db2wiki/pmwiki.php?n=Main.WshSyn
==> previous version under wsh4 <==
--- history -----------------------------------------------------------
4. 8.16 f recursive %( %, %), fTst B, I, Y, Z / comp table deimp
*********/ /*** end of help *******************************************
29. 7.16 log for s_users to dsn.wshLog else to tss.ska.db2.wshlog
allow dd out sysout, assume reclen 32755 / spell out truncat.
13. 7.16 sqlFTabAdd und fTabAddRCT ersetzt druch ftabAdd
6.16 neues sql, sqlWsh, wshMain etc., test to end
23.12.15 dsnList, dsnCopy und dsnDel
16. 1.15 f: get/put read/write in/out Object/Strings transparent weiter
17.11.14 f: iirz2p ==> plex Buchstaben
17.06.14 f: %tS %tT und %tN mit MicroSekunden
16.06.14 csmCopy auch für LoadModule usw.
30.05.14 fix sql4obj fuer rcm profex
14.04.14 class vor obj, mit lazy
19.03.14 ii = installation Info
9.01.14 walter: redesign formatting (fmt eliminiert), csm.div.p0.exec
3.12.13 walter: db2 interface radikal geputzt
3.10.13 walter: uCount fuer TSO <-> unitCount fuer Csm
23. 9.13 walter: ws2 syntax
6. 2.13 w.keller csmCopy aendert mgmtClas für neue lokale Files
23. 1.13 w.keller sqlErrHandler sowie sqlRx und sql
11. 6.12 w.keller sqlUpdComLoop
23. 5.12 w.keller fix sqlStmt: drop accepts -204
31. 3.12 w.keller sql Query interface incl. sql über CSM
10. 2.12 w.keller div catTb* und eLong
2. 6.11 w.keller sql error with current location and dsnTiar
2. 5.11 w.keller sqlStmt etc..
16. 3.11 w.keller basic new r '' ==> r m.class_O
28. 2.11 w.keller compFile by exprBlock, fix $@do forever, |
7. 2.11 w.keller cleanup block / with sqlPush....
2. 2.11 w.keller simplified syntax, ast for blocks, ? for help
19. 6.10 w.keller open/close stacked mit jUsers, framed eliminiert
19. 5.10 w.keller class wird direkt erzeugt ohne temporary
18. 4.10 w.keller scanUtilInto ==> testCase noch einbauen
17. 4.10 w.keller oMutate in fileTsoList eingebaut
14. 1.10 w.keller batch interface no longer dies on openIfNotYet
CSM.RZ1.P0.EXEC korrigiert
**********************************************************************/
/*--- main code wsh -------------------------------------------------*/
call errReset 'hI'
numeric digits 12 /* full int precision, but not bigInt | */
m.myLib = 'A540769.WK.REXX'
m.myWsh = 'WST'
m.myVers = 'v62 4.08.16'
call wshLog
parse arg spec
isEdit = 0
editDsn = ''
m.wsh.outLen = 157
if spec = '' & m.err_ispf then do /* z/OS edit macro */
isEdit = adrEdit('macro (spec) NOPROCESS', '*') == 0
if isEdit then do
call adrEdit '(d) = dataset'
call adrEdit '(m) = member'
editDsn = dsnSetMbr(d, m)
if abbrev(editDsn, 'A540769.WK.REXX(WS') ,
& length(dsnGetMbr(editDsn)) <= 4 then do
isEdit = 0
if spec = '' then
spec = 't'
end
end
end
spec = strip(spec)
if spec = '?' then
return help()
inp = ''
out = ''
call utIni
if m.err_os == 'TSO' then do
if isEdit then do
call pipeIni
parse value wshEditBegin(wsh) with inp out
end
else if sysvar('sysEnv') = 'FORE' then do
end
else do
call pipeIni
inp = file('dd(wsh)')
useOut = listDsi('OUT FILE')
if useOut = 0 then do
out = file('dd(out)')
m.wsh.outLen = sysLrecL - 4 * abbrev(sysRecFM, 'V')
end
else if (useOut = 16 & sysReason = 2) then do
end /* dd out not allocated, use say to sysTsPrt */
else if (useOut = 16 & sysReason = 3) then do
out = file('dd(out)') /* hope for sysout */
m.wsh.outLen = 32755 /* assume large maxRecL */
end
else if \ (useOut = 16 & sysReason = 2) then do
call err 'listDsi dd out cc='useOut',
, sysReason='sysReason 'm2='sysMsgLvl2', m1='sysMsgLvl1
end
end
end
else if m.err_os == 'LINUX' then do
inp = file('&in')
out = file('&out')
end
else
call err 'implement wsh for os' m.err_os
m.wsh.pipeOut = out \== ''
if m.wsh.pipeOut then do
call pipe '+F', out
call pipe '+F', jText(out, m.wsh.outLen)
end
m.wsh.exitCC = 0
call wshRun wsh, spec, inp
do m.wsh.pipeOut * 2
drop out q
q = m.j.out
call pipe '-'
end
if m.pipe_ini == 1 & m.pipe.0 \== 2 then
call err 'pipe.0='m.pipe.0 'at end'
if isEdit then
call wshEditEnd wsh
exit m.wsh.exitCC
/* end of main of wsh */
/*--- log user of wsh, to public ds to allow public usage -----------*/
wshLog: procedure expose m.
parse arg msg, st
if abbrev(userid(), 'S') then
lNm = 'dsn.wshlog' /* da duerfen S-Pids */
else
lNm = 'tss.ska.db2.wshlog' /* da duerfen alle User */
f1 = dsnAlloc('dd(log) mod' lNm '::f', , , '*')
if datatype(f1, 'n') then do
lN2 = lNm'.R' || ( random() // 19)
f1 = dsnAlloc('dd(log) old' lN2 '::f', , , '*')
if datatype(f1, 'n') then do
say 'could not allocate log' lNm lN2
return
end
end
parse source . . s3 .
o.1 = m.myLib'('s3')' word(m.myVers, 1) sysvar(sysnode) ,
'j='mvsvar('symdef', 'jobname') ,
'u='userid() date('s') time()
if msg <> '' then
o.2 = left(msg, 80)
ox = 1 + (msg <> '')
if st <> '' then do sx=1 to m.st.0
ox = ox+1
o.ox = left(m.st.sx, 80)
end
call writedd log, o., ox
call tsoClose log
call tsoFree log
return
endProcedure wshLog
/*--- hook for out format -------------------------------------------*/
wshHook_outFmt: procedure expose m.
parse arg m, rest
if m.pipe.0 \== 4 then
call err 'wshHook_outFmt but pipe.0='m.pipe.0
call pipe '-'
if rest = 'e' then
call pipe '+F', csvV2Frdr(csvExtRdr(m.j.out), m.m.outLen-4)
else
call err 'wshHook_outFmt unsupported fmt='rest
return ''
endProcedure wshHook_outFmt
/*--- i hook: interpret user input: rexx, expr, data or shell -------*/
wshHook_I: procedure expose m.
parse arg m, inp
mode = '*'
do forever
if pos(left(inp, 1), '/;:*@.-=') > 0 then
parse var inp mode 2 inp
if mode == '/' then
exit 0
mode = translate(mode, ';', ':')
if inp <> '' then do
say 'as' mode 'interpreting' inp
if mode = ';' then
interpret inp
else if mode = '*' then
interpret 'say' inp
else do
call wshIni
call errReset 'h', 'say "******* intercepting error";',
'call errSay ggTxt; return "";'
call oRun wshHookComp( ,mode, jBuf(inp))
call errReset 'h'
end
end
say 'enter' mode 'expression, / for end, ; or * for Rexx' ,
'@ . - = for wsh'
parse pull inp
end
endProcedure wshInter
/*--- find input ramge, destination and set errHandler
and return input and output files ----------------------------*/
wshEditBegin: procedure expose m.
parse arg m
pc = adrEdit("process dest range Q", 0 4 8 12 16)
call adrEdit "(zLa) = lineNum .zl"
if pc = 16 then
call err 'bad range must be q'
rFi = 1
rLa = zLa
if pc = 0 | pc = 8 then do
call adrEdit "(rFi) = lineNum .zFrange"
call adrEdit "(rLa) = lineNum .zLrange"
/* say 'range' rFi '-' rLa */
end
dst = ''
if pc = 0 | pc = 4 then do
call adrEdit "(dst) = lineNum .zDest"
/* say 'dest' dst */
end
call jReset oMutate(m'.EDITIN', m.class_JBuf)
b = m'.EDITIN.BUF'
bx = 0
do lx=rFi to rLa
call adrEdit "(li) = line" lx
if abbrev(li, '$#end') then do lx=lx+1 to rLa ,
until abbrev(li, '$#out')
end
if abbrev(li, '$#out') then do
if dst = '' then
dst = lx - 1
leave
end
bx = bx + 1
m.b.bx = li
end
m.b.0 = bx
m.m.editRFirst = rFi
m.m.editREnd = rFi + bx
m.m.editDst = dst
if dst == '' then do
m.m.editOut = ''
end
else do
call adrEdit '(recl) = LRECL'
m.m.outLen = recL
m.m.editOut = jOpen(jReset(oMutate(m'.EDITOUTF',
, m.class_JBuf)), '>')
call jWrite m.m.editOut, left('$#out', 50) date('s') time()
end
call errReset 'hso', "return wshEditErrH('"m"', ggTxt)"
return m'.EDITIN' m.m.editOut
endProcedure wshEditBegin
/*--- copy output to editArea ---------------------------------------*/
wshEditEnd: procedure expose m.
parse arg m
call errReset 'h'
if m.m.editOut == '' then
return 0
call jClose m.m.editOut
call wshEditInsertSt wshEditInsertCmd(m.m.editDst, 'wshDs'),
, , m.m.editOut'.BUF'
call wshEditLocate m.m.editDst, 1
return 1
endProcedure wshEditEnd
/*--- scroll such that given line is nicely visible -----------------*/
wshEditLocate: procedure
parse arg ln, top
call adrEdit 'down max'
call adrEdit '(fi, la) = display_lines'
if top then
lx = ln - 7
else
lx = ln - la + fi + 7
if fi <> 1 & lx < fi then
call adrEdit 'locate' max(1, lx)
return
endProcedure wshEditLocate
/*--- error handle for wsh in edit mode
mark location of wsh syntax error -----------------------------*/
wshEditErrH: procedure expose m.
parse arg m, ggTxt
call errReset 'hso'
ee = errSay(ggTxt'\nin wsh phase' m.m.info)
isScan = 0
if wordPos("pos", m.ee.3) > 0 ,
& pos(" in line ", m.ee.3) > 0 then do
parse var m.ee.3 "pos " pos . " in line " lin":"
if pos = '' then do
parse var m.ee.3 " line " lin":"
pos = 0
end
isScan = lin \== ''
end
call wshEditEnd m
if m.m.Info=='compile' & isScan then do
lx = m.m.editRFirst + lin - 1
cmd = wshEditInsertCmd(lx, 'wshEr')
if pos \= '' then
call wshEditInsert cmd, 'msgline', right('*',pos)
call wshEditInsertSt cmd, 'msgline', ee
call wshEditLocate lx, 0
end
call errCleanup
exit 8
exit
endSubroutine wshEditErrH
/*--- return editor insert cmd for after line afX -------------------*/
wshEditInsertCmd: procedure
parse arg afX, lb
call adrEdit "(zLa) = lineNum .zl"
if afX >= 1 & afX < zLa then do
call adrEdit 'label' (afX+1) '= .'lb
return 'line_before .'lb '='
end
else if afX = zLa then
return 'line_after .zl ='
else
call err 'dst='afX 'but .zl='zLa
endProcedure wshEditInsertCmd
/*--- insert lines, format msgLines ---------------------------------*/
wshEditInsert: procedure
parse arg cmd, type
do ax=3 to arg()
li = strip(arg(ax), 't')
if translate(type) = 'MSGLINE' then do while length(li) > 72
sx = lastPos(' ', li, 72)
if sx < 10 then
sx = 72
one = left(li, sx)
li = ' 'strip(substr(li, sx))
call adrEdit cmd type "(one)"
end
call adrEdit cmd type "(li)", 0 4
end
return
endProcedure wshEditInsert
/*--- insert all lines of stem st -----------------------------------*/
wshEditInsertSt: procedure expose m.
parse arg cmd, type, st
if cmd == '' then do
do ox=1 to m.st.0
say m.st.ox
end
return ''
end
do ax=1 to m.st.0
call wshEditInsert cmd, type, m.st.ax
end
return
endProcedure wshEditInsertSt
/*** end wsh, begin all copies ***************************************/
/* copy wshCopy begin ************************************************/
wshIni: procedure expose m.
call compIni
call sqlIni
call fTabIni
call csmIni
return
endProcedure wshIni
/*--- call hooks and/or compile wsh
finally execute any generated code ----------------------------*/
wshRun: procedure expose m.
parse arg m, spec, inp
m.m.info = 'compile'
r = wshHookComp(m, spec, inp)
m.m.info = 'run'
if r \== '' then
call oRun r
return
endProcedure wshRun
/*--- call hooks, handle $# clauses, compile wsh
return generated code as ORunner or ''-------------------------*/
wshHookComp: procedure expose m.
parse arg m, spec, inp
if m == '' then do
if symbol('m.wsh_new') \== 'VAR' then
m.wsh_new = 1
else
m.wsh_new = m.wsh_new + 1
m = 'wsh_new'm.wsh_new
end
m.m.in = inp
m.m.comp = ''
m.m.kind = '@'
m.m.out = ''
m.m.wshEnd = 0
run = ''
rest = strip(spec)
if abbrev(rest, '$#') then
rest = strip(substr(rest, 3))
do until m.m.comp \== '' | rest = ''
if pos(left(rest, 1), '<>') > 0 then
parse var rest s2 r2
else
parse var rest s2 '$#' r2
run = run wshHook(m, strip(s2), rest)
rest = strip(r2)
end
if m.m.comp \== '' then do
c = m.m.comp
s = m.c.scan
do while \ m.m.wshEnd
if \ scanLit(s, '$#') then
leave
call scanChar s
sp2 = m.s.tok
run = run wshHook(m, sp2, sp2)
end
call compEnd c, left(m.m.kind, \ m.m.wshEnd)
end
run = space(run, 1)
if words(run) <= 1 then
return run
else
return oRunner('call oRun' repAll(run, ' ', '; call oRun '))
endProcedure wshHookComp
/*--- compile wsh until eof or unknown syntax -----------------------*/
wshHook: procedure expose m.
parse arg m, spec, specAll
parse var spec sp1 spR
if pos(left(sp1, 1), '<>') > 0 then
return wshHookRedir(m, sp1 spR)
if verifId(sp1) > 0 | sp1 == '' then
return wshCompile(m, specAll)
if wordPos(sp1, 'out end version') <= 0 then do
cd = "return wshHook_"sp1"(m, '"strip(spR)"')"
/* say 'interpreting hook' cd */
interpret cd
end
c = m.m.comp
s = m.c.scan
if c == '' then
call err 'wshHook before compiler created:' spec
else if sp1 == 'out' then do
m.m.out = scanPos(s)
m.m.wshEnd = 1
end
else if sp1 == 'end' then
call scanNlUntil s, '$#out'
else if m.s.tok == 'version' then
call scanErr s, 'implement version'
return ''
endProcedure wshHook
/*--- initialize compiler if necessary and compile one unit ---------*/
wshCompile: procedure expose m.
parse arg m, spec
spec = strip(spec, 'l')
if m.m.comp == '' then
call wshIni
if pos(left(spec, 1), m.comp_chKind'*') > 0 then
parse var spec m.m.kind 2 spec
if m.m.comp == '' then do
c = comp(m.m.in)
m.m.comp = c
call compBegin c, spec
end
else do
c = m.m.comp
call scanBack m.c.scan, spec
end
return compile(c, m.m.kind)
endProcedure wshCompile
/*--- redirection hook ----------------------------------------------*/
wshHookRedir: procedure expose m.
parse upper arg m, op 2 dsn
call pipeIni
f = ''
if op == '<' then
call pipe '+f', , file(dsn)
else if op \== '>' then
call err 'bad op' op 'in wshHookRedir' op || dsn
else do
if pos('>', dsn) > 0 then
parse var dsn f '>' dsn
else if verify(dsn, '.~/', 'm') > 0 then
nop
else if abbrev(dsn, 'E') | abbrev(dsn, 'VV') ,
| abbrev(dsn, 'VF') then
parse var dsn f 2 dsn
else
f = 'E'
dsn = strip(dsn)
if dsn \== '' & verify(dsn, '.~/:', 'm') == 0 then
dsn = '::'dsn
if f <> '' then
call pipe '+F', fEdit(dsn, f)
else
call pipe '+F', file(dsn)
end
m.m.pipeCnt = m.m.pipeCnt + 1
return ''
endProcedure wshHookRedir
/* copy wshCopy end ************************************************/
/* copy time begin ****************************************************
timestamp format yz34-56-78-hi.mn.st.abcdef
11.12.14 wk: added lrsn2uniq
11.05.13 wk: numeric digits transparent: in jeder Procedure drin
time2jul, tst externalisiert
**********************************************************************/
/*--- timestamp to julian -------------------------------------------*/
time2jul: procedure expose m.
parse arg yyyy '-' mm '-' dd '-'
if yyyy < 1100 then
yyyy = 11 || right(yyyy, 2, 0)
/* date function cannot convert to julian, only from julian
use b (days since start of time epoch) instead */
return right(yyyy, 2) ,
|| right(date('b', yyyy || mm || dd, 's') ,
- date('b', yyyy-1 || '1231', 's') , 3, 0)
endProcedure time2jul
/*--- current timestamp ---------------------------------------------*/
timestampNow: procedure expose m.
parse value date('s') time('l') with y 5 m 7 d t
return y'-'m'-'d'-'translate(t, '.', ':')
/*--- timestamp expand: expand to timestamp of 26 chars -------------*/
timestampExp: procedure expose m.
parse arg tst .
if length(tst) < m.timeStamp_Len then
return overlay(tst, m.timeStamp_01)
else
return left(tst, timeStamp_Len)
endProcedure tiemstampExp
/*--- timestamp check return '' if correct or error text ------------*/
timestampcheck: procedure expose m.
parse arg tst
if length(tst) < m.timestamp_d0Len | \ abbrev(m.timestamp_11,
, translate(tst, '111111111', '023456789')) then
return 'bad timestamp' tst
parse arg yyyy '-' mo '-' dd '-' hh '.' mm '.' ss '.' u
if mo < 1 | mo > 12 then
return 'bad month in timestamp' tst
if dd < 1 | dd > 3 || substr('101010110101', mo, 1) then
return 'bad day in timestamp' tst
if mo = 2 then
if dd > date('d', yyyy'0301', 's') - 32 then
return 'bad day in timestamp' tst
if hh > 23 & \ abbrev(24 00 00 000000, hh mm ss u) then
return 'bad hour in timestamp' tst
if mm > 59 then
return 'bad minute in timestamp' tst
if ss > 59 then
return 'bad second in timestamp' tst
return ''
endProcedure timestampCheck
/*--- timestamp to days since 1.1.0001 ------------------------------*/
timestamp2days: procedure expose m.
parse arg yyyy '-' mo '-' dd '-' hh '.' mm '.' ss
numeric digits 20
return date('b', yyyy || mo || dd, 's') ,
+ (((hh * 60) + mm) * 60 + ss) / 86400
/*--- days since 1.1.0001 (with time+microsecs) to timestamp --------*/
timeDays2tst: procedure expose m.
parse arg d
numeric digits 20
r = min(format(d // 1 * 86400, 5, 6), 86399.999999)
s = trunc(r)
t = date('s', trunc(d), 'b')
return left(t, 4)'-'substr(t, 5, 2)'-'right(t, 2) ,
|| '-' || right((s % 3600), 2, 0) ,
|| '.' || right((s // 3600 % 60), 2, 0) ,
|| '.' || right((s // 60), 2, 0) ,
|| substr(r, 6)
endProcedure timeDays2tst
/*--- timestamp diff in days ----------------------------------------*/
timestampDiff: procedure expose m.
parse arg t1, t2
numeric digits 20
return timestamp2days(t1) - timestamp2Days(t2)
/*--- convert 2 digit year to 4 digit -------------------------------*/
timeYear24: procedure expose m.
parse arg s
y = left(date('S'), 4)
s4 = left(y, 2)right(s, 2, 0)
if s4 > y + 30 then
return (left(y, 2) - 1)substr(s4, 3)
else if s4 > y - 70 then
return s4
else
return (left(y, 2) + 1)substr(s4, 3)
endProcedure timeYear24
/*--- convert 2 or 4 digit year Y (A=0...Y=24) ----------------------*/
timeYear2Y: procedure expose m.
parse arg y
return substr(m.ut_uc25, (y // 25) + 1, 1)
/*--- convert 1 char year Y (A=0...y=24) to year --------------------*/
timeY2Year: procedure expose m.
parse arg i
j = pos(i, m.ut_uc25) - 1
if j < 0 then
call err 'timeY2Year bad input' i
y = left(date('S'), 4)
r = y - y // 25 + j
if r > y + 4 then
return r - 25
else if r > y - 21 then
return r
else
return r + 25
endProcedure timeY2Year
/*--- convert 2 or 4 digit year Y (A=10...T=29) ----------------------*/
timeYear2Z: procedure expose m.
parse arg y
return substr('ABCDEFGHIJKLMNOPQRST', ((y+10) // 20) + 1, 1)
/*--- convert 1 char year Z (A=10...T=29) to year --------------------*/
timeZ2Year: procedure expose m.
parse arg i
j = pos(i, 'ABCDEFGHIJKLMNOPQRST') - 1
if j < 0 then
call err 'timeZ2Year bad input' i
y = left(date('S'), 4)
r = y - y // 20 + j
if r > y + 4 then
return r - 20
else if r > y - 16 then
return r
else
return r + 20
endProcedure timeZ2Year
/*--- convert numeric month to M (Jan=B=1, dec=12=M) ----------------*/
timeMonth2M: procedure expose m.
parse arg m
return substr('BCDEFGHIJKLM', m, 1)
/*--- convert M to numeric Month (Jan=B=1, dec=12=M) ----------------*/
timeM2Month: procedure expose m.
parse arg m
p = pos(m, 'BCDEFGHIJKLM')
if p= 0 then
call err 'bad M month' m
return right(p, 2, 0)
/*--- read timeZoneOffset and leapSeconds registers
and set variables for uniq ----------------------------------*/
timeIni: procedure expose m.
parse arg debug
numeric digits 25
/* offsets documented in z/OS Data Areas Vol.1 */
cvtOH = '00000010' /* cvt control block Address */
cvtext2O = x2d('00000560') /* offset to extension 2 */
cvtldtoO = x2d('00000038') /* offset to timezone */
cvtlsoO = x2d('00000050') /* offset to leapSeconds */
/* CVT CB address + extention2 */
cvtExt2A = C2D(STORAGE(cvtOH,4)) + cvtext2O
/* cvtLdto timeZone address +offset */
m.time_Zone = c2d(STORAGE(d2x(cvtext2A+cvtldtoO, 8), 8))
m.time_StckUnit = 1e-6 / 256 / 16
/* cvtLso LeapSecs address +offset */
m.time_Leap = c2d(STORAGE(d2x(cvtext2A+cvtlsoO, 8), 8))
m.time_LZT_TAI10_us16 = (m.time_zone - m.time_leap) % 256
m.time_UQDigits = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ012345678'
/* find lrsn of day 0, 0 out last 6 bits */
m.time_UQZero = x2d(left(timeTAI102Lrsn( ,
'2004-12-31-00.00.22.000000'), 14)) % 64 * 64
m.timeStamp_01 = '0001-01-01-00.00.00.000000'
m.timeStamp_11 = '1111-11-11-11.11.11.111111'
m.timeStamp_99 = '9999-12-31-23.59.59.999999'
m.timeStamp_len = length(m.timestamp_11)
m.timeStamp_d0Llen = m.timestamp_len - 7
m.time_ini = 1
return
endSubroutine timeIni
/*--- TAI10 timestamp yyyy-mm.... -> stckE value char(16)
BLSUETID is described in z/OS MVS IPCS Customization -------*/
timeTAI102stckE: procedure expose m.
/* timestamp must include microSeconds |||*/
parse arg year'-'mo'-'da'-'hh'.'mm'.'secs
tDate = mo'/'da'/'year hh':'mm'.'secs
ACC=left('', 16, '00'x)
ADDRESS LINKPGM "BLSUETID TDATE ACC"
RETURN acc
endProcedure timeTAI102stckE
timeTAI102lrsn: procedure expose m.
parse arg tst
return c2x(left(timeTAI102StckE(tst), 10))
timeLZT2stckE: procedure expose m.
parse arg tst
numeric digits 23
s =timeTAI102StckE(tst)
return d2c(c2d(left(s, 8)) - m.time_lzt_TAI10_us16,8) ||substr(s,9)
endProcedure timeLZT2stckE
timeLZT2lrsn: procedure expose m.
parse arg tst
return c2x(left(timeLZT2StckE(tst), 10))
/*--- expand lrsn to 20 hexDigits -------------------------------*/
timeLrsnExp: procedure expose m.
parse arg s
return left(copies('00', length(s) <= 12 & \abbrev(s, 0))s, 20,0)
/*--- expand stcK(e) to 16 Byte ---------------------------------*/
timeStckExp: procedure expose m.
parse arg s
return left(copies('00'x, length(s) <= 8 & s >> '09'x)s, 16,'00'x)
/*--- conversion from StckE Clock Value to TAI10 Timestamp
BLSUETOD is described in z/OS MVS IPCS Customization --------*/
timeStckE2TAI10: PROCEDURE expose m.
parse arg stck /* must be 16 characters ||||| */
TDATE = left('' , 26)
ADDRESS LINKPGM "BLSUETOD stck TDATE"
/* return format : mo/dd/yyyy hh:mm:ss.uuuuuu */
/* Timestamp format: yyyy-mm-dd-hh.mm.ss.uuuuuu */
parse var TDATE mo '/' dd '/' yyyy hh ':' mm ':' secs
RETURN yyyy'-'mo'-'dd'-'hh'.'mm'.'secs
endProcedure timeStckE2TAI10
/*--- conversion from Lrsn Clock Value to TAI10 Timestamp ----------*/
timeLrsn2TAI10:
return timeStckE2TAI10(x2c(arg(1))'000000000000'x)
/*--- conversion from Lrsn Clock Value to LZT Local Zurich Time -----*/
timeStckE2LZT: procedure expose m.
parse arg s
numeric digits 23
return timeStckE2TAI10(d2c(c2d(left(s, 8)) ,
+ m.time_LZT_TAI10_us16, 8) || substr(s, 9))
endProcedure timeStckE2LZT
/*--- conversion from Lrsn Clock Value to LZT Local Zurich Time -----*/
timeLrsn2LZT: procedure expose m.
parse arg lrsn
return timeStckE2LZT(x2c(lrsn) || '000000000000'x)
/* convert a lrsn to the uniq variable *******************************/
timeLrsn2uniq: procedure expose m.
parse arg lrsn
/* unique are bits 0:41 of the TodClock value
minus 31.12.2004 represented
by base 35 by 'ABC...YZ01..8'
*/
lrsn = left(timeLrsnExp(lrsn), 14)
numeric digits 20
diff = x2d(lrsn) - m.time_UQZero
if diff < 0 then
return'< 2005'
return right(i2q(diff % 64, m.time_UQDigits), 8, 'A')
endProcedure timeLrsn2Uniq
/* convert a uniq variable to lrsn ***********************************/
timeUniq2lrsn: procedure expose m.
parse arg uniq
numeric digits 20
u1 = q2i(left(uniq, 8, 'A'), m.time_UQDigits) * 64
lrsn = '00'right(d2x(u1 + m.time_UQZero), 12, 0)'000000'
return lrsn
endProcedure uniq2lrsn
/*--- translate a number in q-system to decimal
arg digits givs the digits corresponding to 012.. in the q sysem
q = length(digits) -------------------------------------------*/
q2i: procedure expose m.
parse arg v, digits
b = length(digits)
i = 0
do x = 1 to length(v)
q = substr(v, x, 1)
r = pos(q, digits)
if r < 1 then
call err 'bad digit' q 'in' v 'valid digits' digits
i = i * b + r - 1
end
return i
endProcedure q2i
/*--- translate a decimal number to q-system - inverse of q2i -------*/
i2q: procedure expose m.
parse arg i, digits
if i = 0 then
return left(digits, 1)
b = length(digits)
v = ''
do while i > 0
v = substr(digits, 1 + (i // b), 1) || v
i = i % b
end
return v
endProcedure i2q
/* copy time end ----------------------------------------------------*/
/* copy sort begin ***************************************************/
sortComparator: procedure expose m.
parse arg cmp, le, ri
if cmp == '' then
cmp = '<<='
if length(cmp) < 6 then
m.sort_comparator = 'cmp =' le cmp ri
else if pos(';', cmp) < 1 then
m.sort_comparator = "aLe =" le"; aRi =" ri"; cmp =" cmp
else
m.sort_comparator = "aLe =" le "; aRi =" ri";" cmp
return
endProcedure sort
sortWords: procedure expose m.
parse arg wrds, cmp
if words(wrds) <= 1 then
return strip(wrds)
m.sort_ii.0 = words(wrds)
do sx=1 to m.sort_ii.0
m.sort_ii.sx = word(wrds, sx)
end
call sort sort_ii, sort_oo, cmp
r = m.sort_oo.1
do sx=2 to m.sort_oo.0
r = r m.sort_oo.sx
end
return r
endProcedure sortWords
sortWordsQ: procedure expose m.
parse arg wrds, cmp
call sortComparator cmp, 'word(le, lx)', 'word(ri, rx)'
return strip(sortWord1(wrds))
endProcedure sortWordsQ
sortWord1: procedure expose m.
parse arg wrds
if words(wrds) <= 1 then
return wrds
h = words(wrds) % 2
le = sortWord1(subWord(wrds, 1, h))
ri = sortWord1(subWord(wrds, h+1))
lx = 1
rx = 1
res = ''
do forever
interpret m.sort_comparator
if cmp then do
res = res word(le, lx)
if lx >= words(le) then
return res subword(ri, rx)
lx = lx + 1
end
else do
res = res word(ri, rx)
if rx >= words(ri) then
return res subword(le, lx)
rx = rx + 1
end
end
endProcedure sortWord1
sort: procedure expose m.
parse arg i, o, cmp
call sortComparator cmp, 'm.l.l0', 'm.r.r0'
call sort1 i, 1, m.i.0, o, 1, sort_work, 1
m.o.0 = m.i.0
return
endProcedure sort
sort1: procedure expose m.
parse arg i, i0, le, o, o0, w, w0
if le <= 3 then do
if le = 3 then do
call sortMerge i, i0, i0+1, i, i0+1, i0+2, w, w0
call sortMerge i, i0+2, i0+3, w, w0, w0+2, o, o0
end
else if le = 2 then
call sortMerge i, i0, i0+1, i, i0+1, i0+2, o, o0
else if le = 1 then
m.o.o0 = m.i.i0
return
end
h = (le + 1) % 2
call sort1 i, i0, h, o, o0+le-h, w, w0
call sort1 i, i0+h, le-h, w, w0, o, o0
call sortMerge o, o0+le-h, o0+le, w, w0, w0+le-h, o, o0
return
endProcedure sort1
sortMerge: procedure expose m.
parse arg l, l0, le, r, r0, re, o, o0
do while l0 < le & r0 < re
interpret m.sort_comparator
if cmp then do
m.o.o0 = m.l.l0
l0 = l0 + 1
end
else do
m.o.o0 = m.r.r0
r0 = r0 + 1
end
o0 = o0 + 1
end
do while l0 < le
m.o.o0 = m.l.l0
l0 = l0 + 1
o0 = o0 + 1
end
do while r0 < re
m.o.o0 = m.r.r0
r0 = r0 + 1
o0 = o0 + 1
end
return
endProcedure sortMerge
/* copy sort end ***************************************************/
/* copy match begin **************************************************/
/*--- wildCard matching with the following wildchars:
* 0-n chars
? 1 char
fill matched expressions instem st if st is non empty
return 1 if mask matches wert ---------------------------------*/
match: procedure expose m.
parse arg wert, mask
if symbol('m.match_m.mask') == 'VAR' then
interpret m.match_m.mask
else
interpret matchGen('MATCH_M.'mask, mask, 'm')
endProcedure match
matchGG: procedure expose m.
parse arg wert, cd, vars
interpret cd
endProcedure matchGG
matchVars: procedure expose m.
parse arg wert, mask, vars
if symbol('m.match_v.mask') == 'VAR' then
interpret m.match_v.mask
else
interpret matchGen('MATCH_V.'mask, mask, 'v')
endProcedure match
matchRep: procedure expose m.
parse arg wert, mask, mOut
vars = 'MATCH_VV'
mm = mask'\>'mOut
if symbol('m.match_r.mm') == 'VAR' then
interpret m.match_r.mm
else
interpret matchGen('MATCH_R.'mm, mask, 'r', mOut)
endProcedure matchRep
matchGen: procedure expose m.
parse arg m, mask, opt, mOut
a = matchScan(match_sM, mask)
if symbol('m.match_g') \== 'VAR' then
m.match_g = 0
if opt \== 'r' then do
r = matchgenMat(a, opt, 1, m.a.0, 0)
end
else do
m.match_g = m.match_g + 1
sub = 'MATCH_G'm.match_g
m.sub = matchgenMat(a, 'v', 1, m.a.0, 0)
o = matchScan(match_sO, mOut)
r = matchGenRep(o, m.a.wildC)
r = 'if matchGG(wert, m.'sub', vars) then return' r';' ,
'else return "";'
end
m.m = r
return r
endProcedure matchGen
matchScan: procedure expose m.
parse arg a, mask, opt
s = match_scan
call scanSrc s, mask
ax = 0
vx = 0
m.a.wildC = ''
do forever
if scanUntil(s, '*?&\') then do
if m.a.ax == 'c' then do
m.a.ax.val = m.a.ax.val || m.s.tok
end
else do
ax = ax + 1
m.a.ax = 'c'
m.a.ax.val = m.s.tok
end
end
else if scanChar(s, 1) then do
if pos(m.s.tok, '*?') > 0 then do
ax = ax + 1
vx = vx + 1
m.a.ax = m.s.tok
m.a.ax.ref = vx
m.a.wildC = m.a.wildC || m.s.tok
end
else if m.s.tok == '\' then do
call scanChar s, 1
if pos(m.s.tok, '\*?&') < 1 then
return scanErr(s, 'bad char after \')
if abbrev(m.a.ax, 'c') then
m.a.ax.val = m.a.ax.val || m.s.tok
else do
ax = ax + 1
m.a.ax = 'c'
m.a.ax.val = m.s.tok
end
end
else if m.s.tok == '&' then do
if opt \== 'r' then
call scanErr s, '& in input'
if \ scanChar(s,1) | pos(m.s.tok, 'ms123456789')<1 then
call scanErr s, 'bad & name' m.s.tok
ax = ax + 1
m.a.ax = '&'
m.a.ax.ref = m.s.tok
end
else
call scanErr s, 'bad char 1 after until'
end
else
leave
end
m.a.0 = ax
if vx \== length(m.a.wildC) then
call scanErr 'vars' m.a.wildC 'mismatches' vx
return a
endProcedure matchScan
matchGenMat: procedure expose m.
parse arg a, opt, fx, tx, minLL
ml = 0
if fx == 1 then do
do ax=1 to m.a.0
if m.a.ax == '?' then
ml = ml + 1
else if m.a.ax == 'c' then
ml = ml + length(m.a.ax.val)
m.a.minLen.ax = ml
end
end
r = ''
ret1 = ''
ret1After = ''
lO = 0
do fy=fx to tx
if m.a.fy == 'c' then do
r = r 'if substr(wert,' (1+lO)
if fy < m.a.0 then
r = r',' length(m.a.fy.val)
r = r') \==' quote(m.a.fy.val, "'") 'then return 0;'
lO = lO + length(m.a.fy.val)
end
else if m.a.fy == '?' then do
lO = lO + 1
if opt == 'v' then
ret1 = ret1 'm.vars.'m.a.fy.ref ,
'= substr(wert,' lO', 1);'
end
else if m.a.fy == '*' then
leave
else
call err 'bad match ast' a'.'fy m.a.fy
end
rO = 0
do ty=tx by -1 to fy
if m.a.ty == 'c' then do
rO = rO + length(m.a.ty.val)
r = r 'if substr(wert, length(wert) -' (rO - 1)',' ,
length(m.a.ty.val)')' ,
'\==' quote(m.a.ty.val, "'") 'then return 0;'
end
else if m.a.ty == '?' then do
rO = rO + 1
if opt == 'v' then
ret1 = ret1 'm.vars.'m.a.fy.ref ,
'= substr(wert, length(wert) -' (rO-1)', 1);'
end
else if m.a.ty == '*' then
leave
else
call err 'bad match ast' a'.'fy m.a.fy
end
if fy > ty then do /* every thing is handled with fix len */
if fx = tx & abbrev(m.a.fx, 'c') then
r = 'if wert \==' quote(m.a.fx.val, "'") ,
'then return 0;'
else
r = 'if length(wert) \==' (lO + rO) 'then return 0;' r
end
else do
myMiLe = m.a.minLen.ty
if fy > 1 then do
fq = fy -1
myMiLe = myMiLe - m.a.minLen.fq
end
if minLL < myMiLe then
r = 'if length(wert) <' myMiLe 'then return 0;' r
if fy = ty & m.a.fy == '*' then /* single * */
ret1 = ret1 'm.vars.'m.a.fy.ref ,
'= substr(wert,' (1+lO)', length(wert) -' (lO+rO)');'
else if fy < ty & abbrev(m.a.fy, '*') ,
& abbrev(m.a.ty, '*') then do
/* several variable length parts */
suMiLe = m.a.minLen.ty - m.a.minLen.fy
m.match_g = m.match_g + 1
sub = 'MATCH_G'm.match_g
m.sub = matchGenMat(a, opt, fy+1, ty, suMiLe)
if rO = 0 then
subV = 'substr(wert, lx)'
else do
r = r 'wSub = left(wert, length(wert) -' rO');'
subV = 'substr(wSub, lx)'
end
r = r 'do lx = length(wert) -' (suMiLe+rO-1) ,
'by -1 to' (lO+1)';' ,
'if \ matchGG('subV', m.'sub', vars) then' ,
'iterate;'
ret1 = ret1 'm.vars.'m.a.fy.ref '= substr(wert,' (lO+1) ,
|| ', lx -' (lO+1)');'
ret1After = 'end; return 0;'
end
else
call err 'matchGenMat bad case' a'.'fy m.a.fy a'.'ty m.a.ty
end
if opt == 'v' & fx == 1 then do
if r <> '' then
r = 'm.vars.0 = -9;' r
ret1 = ret1 'm.vars.0 =' length(m.a.wildC)';'
end
r = r ret1 'return 1;' ret1After
return r
endProcedure matchGenMat
matchGenRep: procedure expose m.
parse arg o, wildC
xQ = 0
xS = 0
do ox=1 to m.o.0
if m.o.ox == '?' then do
xQ = pos('?', wildC, xQ+1)
if xQ < 1 then
call err 'unmatchted ?' ox
m.o.ox.re2 = xQ
end
else if m.o.ox == '*' then do
xS = pos('*', wildC, xS+1)
if xS < 1 then
call err 'unmatchted *' ox
m.o.ox.re2 = xS
end
else if m.o.ox == '&' & m.o.ox.ref >> '0' then do
if m.o.ox.ref > length(wildC) then
call err '&'m.o.ox.ref 'but wildcards' wildC
xQ = m.o.ox.ref
xS = xQ
m.o.ox.re2 = xQ
end
end
r = ''
do ox=1 to m.o.0
if abbrev(m.o.ox, 'c') then
r = r '||' quote(m.o.ox.val, "'")
else if m.o.ox == '&' & m.o.ox.re2 == 's' then
r = r '|| wert'
else if m.o.ox == '&' & m.o.ox.re2 == 'm' then
r = r '||' quote(mask, "'")
else if pos(m.o.ox, '*?&') > 0 then
r = r '|| m.vars.'m.o.ox.re2
end
if r=='' then
return "''"
else
return substr(r, 5)
endProcedure matchGenRep
/* copy match end ****************************************************/
/* copy comp begin ****************************************************
the shell compiler
syntax and semantics of the shell language see javaDoc
**********************************************************************/
/***** initialisation ************************************************/
/*--- module initialisation -----------------------------------------*/
compIni: procedure expose m.
if m.compIni = 1 then
return
m.compIni = 1
call pipeIni
call scanReadIni
cc = classNew('n Compiler u')
call mNewArea 'COMP.AST', '='
m.comp_chOp = '.-<@|?%^'
m.comp_chKind = '.-=#@:%^'
m.comp_chKindDesc = 'Obj Str Skel Text Exe Wsh Call Fun'
m.comp_chKiNO = '=:#'
m.comp_chKiNBOE = '=<#:' /* nonBLock only expression not Primary*/
m.comp_chDol = '$'
m.comp_chSpa = m.ut_space
call mPut 'COMP_EXTYPE.b', m.comp_chDol'{}' /* braces */
call mPut 'COMP_EXTYPE.d', m.comp_chDol /* data */
call mPut 'COMP_EXTYPE.s', m.comp_chDol /* strip */
call mPut 'COMP_EXTYPE.w', m.comp_chDol||m.comp_chSpa /* word */
m.comp_idChars = m.ut_alfNum'@_'
m.comp_wCatC = 'compile'
m.comp_wCatS = 'do withNew with for forWith ct proc arg if else'
m.comp_astOps = m.comp_chOp'!)&'
m.comp_astOut = '.-@<^' /*ast kind for call out */
m.comp_astStats = ''
return
endProcedure compIni
compKindDesc: procedure expose m.
parse arg ki
kx = pos(ki, m.comp_chKind)
if length(ki) == 1 & kx > > 0 then
return "kind"word(m.comp_chKindDesc, kx)"'"ki"'"
else
return "badKind'"ki"'"
endProcedure compKindDesc
/*--- constructor of Compiler ---------------------------------------*/
comp: procedure expose m.
parse arg src
nn = oNew('Compiler')
m.nn.cmpRdr = in2File(src)
return nn
endProcedure comp
/*--- compile one unit of the source with kind ki
and return oRunner with the code -------------------------*/
compile: procedure expose m.
parse arg m, ki, hook
s = m.m.scan
m.m.comp_assVars = 0
call compSpComment m
a = ''
if m.m.end \== '' then
call scanNlUntil s, '$#out'
else if ki == '*' then
call scanNlUntil s, '$#'
else
a = compUnit(m, ki, '$#')
if compIsEmpty(m, a, 0) then
return ''
cd = compAst2Rx(m, '!', a)
if 0 then
say cd
return oRunner(cd)
endProcedure compile
compBegin: procedure expose m.
parse arg m, spec
m.m.scan = m'.scan'
m.m.out = ''
m.m.end = ''
s = m.m.scan
if m.m.cmpRdr == '' then
call scanOpt scanSrc(s, spec), , '0123456789'
else
call scanReadOpen scanReadReset(scanOpt(s, , '0123456789'),
, m.m.cmpRdr), spec' '
return m
endProcedure compBegin
compEnd: procedure expose m.
parse arg m, erKi
s = m.m.scan
if erKi \== '' then
if \ scanEnd(s) then
return scanErr(s, 'wsh' compKindDesc(erKi),
"expected: compile stopped before end of input")
call scanClose s
return m
endProcedure compEnd
/*--- parse the whole syntax of a unit ------------------------------*/
compUnit: procedure expose m.
parse arg m, ki, stopper
s = m.m.scan
if pos(ki, m.comp_chKind) < 1 then
return scanErr(s, 'bad kind' ki 'in compUnit(...'stopper')')
else if ki <> '#' then do
a = compAst(m, '¢')
do forever
one = compPipe(m, ki)
if one \== '' then
call mAdd a, one
if \ scanLit(m.m.scan, '$;', '<>', '$<>') then
return compUnNest(a)
end
end
else do
res = compAST(m, '¢')
call scanChar s
if verify(m.s.tok, m.comp_chSpa) > 0 then
call mAdd res, compAst(m, '=', strip(m.s.tok, 't'))
do while scanNL(s, 1) & \ abbrev(m.s.src, stopper)
call mAdd res, compAst(m, '=', strip(m.s.src, 't'))
end
return res
end
endProcedure compUnit
compUnnest: procedure expose m.
parse arg a
do while m.a.0 = 1 & pos(m.a.kind, '¢-.;') > 0
n = m.a.1
if m.a.kind \== m.n.kind then
return a
call mFree a
a = n
end
return a
endProcedure compUnnest
/*--- compile an expression, type d=data, b=block w=word, s=strip ---*/
compExpr: procedure expose m.
parse arg m, type, ki, textEnd
s = m.m.scan
if symbol('m.comp_exType.type') \== 'VAR' then
call err s, 'bad type' type 'in compExpr'
if ki == '#' then do
if textEnd == '' then
call scanChar(s)
else if textEnd <= m.s.pos then
return ''
else
call scanChar s, textEnd - m.s.pos
if type == 's' then
res = compAst(m, '=', strip(m.s.tok))
else
res = compAst(m, '=', , m.s.tok)
res = compAST(m, '-', , res)
m.res.containsC = 1
m.res.containsD = 1
return res
end
else if ki == '%' | ki == '^' then do
call compSpComment m
vr = compVar(m, left('c', ki == '^'))
if vr == '' then
return ''
if m.vr.var == 'c' then
res = compAst(m, 'M')
else
res = compAst(m, ki, , compASTAddOp(m, vr, '&'))
call compSpComment m
if textEnd == '' | textEnd < m.s.pos then do
ex = compOpBE(m, '=', 1, , textEnd)
if ex \== '' then do
call mAdd res, ex
call compSpComment m
end
end
m.res.containsC = 1
m.res.containsD = 1
return res
end
if length(ki) \== 1 | pos(ki, '.-=@') < 1 then
return scanErr(s, 'bad kind' ki 'in compExpr')
res = compAST(m, translate(ki, '-;', '=@'))
m.res.containsC = 0
txtKi = translate(ki, '++=+', '.-=@')
laPrim = 0
gotTxt = 0
if pos(type, 'sb') > 0 then
m.res.containsC = compSpComment(m) >= 2
do forever
if textEnd \== '' then
if m.s.pos >= textEnd then
leave
if scanVerify(s, m.comp_exType.type, 'm') then do
if textEnd \== '' then
if m.s.pos > textEnd then do
m.s.tok = left(m.s.tok, length(m.s.tok) ,
+ textEnd - m.s.pos)
m.s.pos = textEnd
end
one = compAST(m, txtKi, m.s.tok)
if verify(m.s.tok, m.comp_chSpa) > 0 then
gotTxt = 1
end
else do
old = scanPos(s)
if \ scanLit(s, m.comp_chDol) then
leave
if pos(scanLook(s, 1), '.-') > 0 then
one = compCheckNN(m, compOpBE(m, , 1, 0),
, 'primary block or expression expected')
else
one = compPrimary(m)
if one = '' then do
call scanBackPos s, old
leave
end
laPrim = m.res.0 + 1
end
call mAdd res, one
if compComment(m) then
m.res.containsC = 1
end
if pos(type, 'bs') > 0 then do
do rx=m.res.0 by -1 to laPrim+1
one = m.res.rx
m.one.text = strip(m.one.text, 't')
if length(m.one.text) <> 0 then
leave
call mFree one
end
m.res.0 = rx
end
m.res.containsD = laPrim > 0 | gotTxt
return compAstFree0(res, '')
endProcedure compExpr
/*--- compile a primary and return code -----------------------------*/
compPrimary: procedure expose m.
parse arg m, ops
s = m.m.scan
if scanString(s) then
return compASTAddOp(m, compAST(m, '=', m.s.val), ops)
r = compVar(m, left('c', right(ops, 1) == '^'))
if r == '' then
return ''
if m.r.var \== 'c' then
return compASTAddOp(m, compAst(m, '&', m.r.var, r), ops)
else
return compASTAddOp(m, compAst(m, 'M'),
, left(ops, length(ops)-1))
endProcedure compPrimary
/*--- oPBE ops (primary or block or expression)
oDef = default Kind, oPre = opPrefix,
uniq=1 extract unique, uniq='<' prefix <
withEx <> 0: expression allowed ------------------------------*/
compOpBE: procedure expose m.
parse arg m, oDef, uniq, withEx, textEnd
s = m.m.scan
old = scanPos(s)
op = compOpKind(m, oDef)
if uniq == '<' & left(op, 1) \== '<' then
op = left('<', uniq == '<') || op
if pos(scanLook(s, 1), '/¢') > 0 then do
if uniq == 1 & length(op) == 1 then
if op == '.' then
op = '|.'
else if op == '=' then
op = '-='
else if pos(op, '-@<') > 0 then
op = op || op
return compBlock(m, op)
end
if compSpComment(m) == 0 ,
& pos(right(op, 1), m.comp_chKiNBOE) <= 0 then
return compPrimary(m, op)
if withEx \== 0 then do
res = compExpr(m, 's', right(op, 1), textEnd)
if res \== '' then
return compASTAddOp(m, res, left(op, length(op)-1))
end
call scanBackPos s, old
return ''
endProcedure compOPBE
/*--- compile var of ^or % clause -----------------------------------*/
compCallVar: procedure expose m.
parse arg m, ki
call compSpComment m
vr = compVar(m, left('c', ki == '^'))
if vr == '' then
call scanErr m.m.scan, 'var expected after' ki
call compSpComment m
if m.vr.var == 'c' then
return compAst(m, 'M')
else
return compAst(m, ki, , compASTAddOp(m, vr, '&'))
endProcedure compCallVar
/*--- compile a pipe and return code --------------------------------*/
compPipe: procedure expose m.
parse arg m, ki
s = m.m.scan
res = compAST(m, 'P', ' ', '', '')
do forever
one = compExprStmts(m, ki)
if one \== '' then do
if m.res.0 > 2 then
call scanErr s, '$| before statements needed'
call mAdd res, one
end
pre = left(m.comp_chDol, scanLit(s, m.comp_chDol))
if scanLook(s, 2) == '<>' then
leave
if scanLit(s, '<') then do
if m.res.2 == '' then
m.res.2 = compAst(m, '.')
else
call mAdd m.res.2, compAst(m, '+', ', ')
call mAdd m.res.2, compOpBE(m, '<', '<')
m.res.text = m.res.text'f'
end
else if scanLit(s, '>>', '>') then do
if m.res.1 <> '' then
call scanErr s, 'duplicate output'
m.res.text = if(m.s.tok == '>', 'F', 'A') ,
||substr(m.res.text, 2)
m.res.1 = compOpBE(m, '<', '<')
end
else if scanLit(s, '|') then do
if m.res.0 < 3 then
call scanErr s, 'stmts expected before |'
call compSpNlComment m
call mAdd res, compCheckNE(m, compExprStmts(m, ki),
, 'stmts or expressions after | expected')
end
else
leave
end
call scanBack s, pre
if m.res.0 > 3 | m.res.1 \== '' | m.res.2 \== '' then
return res
one = if(m.res.0 = 3, m.res.3)
call mFree res
return one
endProcedure compPipe
/*--- compile expressions and stmts ---------------------------------*/
compExprStmts: procedure expose m.
parse arg m, ki
s = m.m.scan
res = compAst(m, '¢')
nlLe = 0 /* sophisticated logic using left and right NLs*/
do forever
one = compExprStm1(m, ki, nlLe)
if one == '' then
return compAstFree0(res)
call mAdd res, one
nlLe = scanNl(s)
end
endProcedure compExprStmts
/*--- scan over space comm nl until next
expression or statement and compile it --------------------*/
compExprStm1: procedure expose m.
parse arg m, ki, nlLe
s = m.m.scan
if pos(ki, ':%^') > 0 then do /* statements with $ are ok */
call compSpNlComment m, '*'
if ki \== ':' then do
one = compExpr(m, 's', ki)
if one \== '' then
return one
end
end
else if ki == '@' then do /* rexx statements */
call compSpNlComment m
one = compExpr(m, 's', ki)
if one\ == '' then do
if m.one.0 < 1 then
call scanErr s, 'assert not empty' m.one.0
do forever /* scan all continued rexx lines */
la = m.one.0
la = m.one.la
if m.la.kind \== '+' then
leave
m.la.text = strip(m.la.text, 't')
if right(m.la.text, 1) \== ',' then
leave
m.la.text = strip(left(m.la.text,
, length(m.la.text)-1), 't')' '
call compSpNlComment m
cont = compExpr(m, 's', '@')
if cont == '' | m.cont.kind \== m.one.kind then
call scanErr s, 'bad rexx continuation'
call mAddSt one, cont
call mFree cont
end
return compAstFree0(one)
end
end
else do /* statemens need $, nl logic for expr */
do forever /* tricky logic for empty lines */
do forever
sx = m.s.pos
call scanSpaceOnly s
if \ compComment(m) then
leave
nlLe = 0
end
m.s.pos = sx
one = compExpr(m, 'd', ki)
nlRi = scanNL(s, '?')
if one == '' then do
if nlLe & nlRi then
return compAst(m, translate(ki, ';-', '@=') ,
, ,compAst(m,'='))
end
else if m.one.containsD then
return one
if \ nlRi then
leave
nlLe = scanNL(s)
end
end
return compStmt(m, ki)
endProcedure compExprStm1
/*--- compile a single statement ------------------------------------*/
compStmt: procedure expose m.
parse arg m, ki
s = m.m.scan
res = compAss(m)
if res \== '' then
return res
pre = ''
old = scanPos(s)
if scanLit(s,m.comp_chDol'$',m.comp_chDol'@',m.comp_chDol,'@') then
pre = m.s.tok
if pre == m.comp_chDol'$' then
return compCheckNN(m, compOpBE(m,'=', 1),
, 'block or expression expected after $$')
if right(pre, 1) == '@' then do
one = compOpBE(m, '@')
if one \== '' then
return compAstAddOp(m, one, ')')
end
wCat = compName(m, 'sv')
fu = m.s.tok
if right(pre, 1) == '@' & wCat \== 's' then
call scanErr s, 'primary, block or expression expected'
if fu == 'arg' then do
res = compAst(m, 'R')
do forever
call compSpComment m
if scanLit(s, ',') then
a1 = compAst(m, '+', ',')
else do
gotV = 1
a1 = compVar(m, 'v')
end
if a1 \== '' then
call mAdd res, a1
else if gotV == 1 then
return res
else
call scanErr s, 'empty arg'
end
end
if fu == 'ct' then do
call compSpComment m
return compAst(m, 'C', , compCheckNN(m, compExprStm1(m, ki, 0),
, 'ct statement'))
end
if fu == 'do' then do
call compSpComment m
pre = compExpr(m, 's', '@')
res = compAst(m, 'D', , pre)
p1 = m.pre.1
if pre \== '' then do
txt = ''
do px=1 to m.pre.0
pC = m.pre.px
if m.pC.kind \== '+' then
leave
txt = txt m.pC.text
cx = pos('=', txt)
if cx > 0 then do
m.res.text = strip(left(txt, cx-1))
leave
end
end
end
call compSpComment m
call mAdd res, compCheckNN(m, compExprStm1(m, ki, 0),
, 'stmt after do')
return res
end
if wordPos(fu, 'for forWith with') > 0 then do
res = compAst(m, 'F', fu)
call compSpComment m
if fu \== 'with' then do
b = compVar(m)
end
else do
b = compAss(m)
if b == '' then
b = compCheckNE(m, compExpr(m, 's', '.'),
, "assignment or expression after with")
end
call compSpComment m
st = compCheckNN(m, compExprStm1(m, ki, 0),
, "var? statement after" fu)
if b = '' then do
b = compBlockName(m, st)
if b \== '' then
b = compAst(m, '=', b)
else if \ abbrev(fu, 'for') then
call scanErr s, "variable or named block after" fu
end
call mAdd res, b, st
return res
end
if fu == 'withNew' then do
oldVars = m.m.comp_assVars
m.m.comp_assVars = ''
one = compCheckNN(m, compExprStm1(m, ki, 0), 'after withNew')
r = compAst(m, 'F', 'withNew', '', one,
, compAst(m, '*', '!.'))
m.r.class = classNew('n* CompTable u' ,
substr(m.m.comp_assVars, 3))
m.r.1 = compAst(m, '.', ,
, compAst(m, '+', "oNew('"m.r.class"')"))
m.m.comp_assVars = oldVars
return r
end
if fu == 'proc' then do
call compSpComment m
nm = ''
if compName(m, 'v') == 'v' then do
nm = m.s.tok
call compSpComment m
end
st = compCheckNN(m, compExprStm1(m, ki, 0), 'proc statement')
if nm == '' then do
nm = compBlockName(m, st)
if nm == '' then
call scanErr s, 'var or namedBlock expected after proc'
end
return compAst(m, 'B', '', compAst(m, '=', nm), st)
end
if fu == 'if' | fu == 'else' then do /* unchanged rexx */
call scanBack s, fu
return compExpr(m, 's', '@')
end
call scanBack s, pre || fu
return ''
endProcedure compStmt
compBlockName: procedure expose m.
parse arg m, a
a1 = m.a.1
if m.a.kind == '¢' then
return m.a.text
else if m.a.kind == '*' & m.a1.kind == '¢' then
return m.a1.text
return ''
endProcedure compBlockName
compVar: procedure expose m.
parse arg m, vk
if pos('o', vk) > 0 then call err(sdf)/0
s = m.m.scan
ty = compName(m, 'v' || vk)
if ty \== '' then do
r = compAst(m, '=', m.s.tok)
m.r.var = ty
return r
end
if \ scanLit(s, '{') then
return ''
call scanLit s, '?', '>'
f = m.s.tok
r = compCheckNE(m, compExpr(m, 'b', '='), 'var name')
if \scanLit(s, '}') then
call scanErr s, 'closing } missing after {'
m.r.var = f
return r
endProcedure compVar
compAss: procedure expose m.
parse arg m, vk
s = m.m.scan
old = scanPos(s)
call scanLit s, m.comp_chDol'=', '='
pr = m.s.tok
if pr \== '' then
call compSpComment m
v = compVar(m, vk)
if v \== '' then do
call compSpComment m
if \ scanLit(s, '=') then do
call scanBackPos s, old
return ''
end
end
else if pr == '' then
return ''
else
oldInfo = scanInfo(s)
eb = compCheckNE(m, compOpBE(m, '=', 1),
, 'block or expression in assignment after' pr)
if m.eb.kind == '¢' then
eb = compAstAddOp(m, eb, '-')
if v == '' then do
v = compBlockName(m, eb)
if v == '' then
call scanEr3 s, 'var or namedBlock expected',
'in assignment after' pr, oldInfo
v = compAst(m, '=', v)
m.v.var = 'v'
end
if m.m.comp_assVars \== 0 then
if m.v.kind == '=' & m.v.var == 'v' then do
if words(m.v.text) \= 1 then
call compAstErr v, 'bad var'
if m.eb.kind == '*' then
ki = left(m.eb.text, 1)
else
ki = m.eb.kind
if pos(ki, '-=s') > 0 then
f = ', f' m.v.text 'v'
else if pos(ki, '.<@o') > 0 then
f = ', f' m.v.text 'r'
else
call compAstErr eb, 'string or object'
if pos(f, m.m.comp_assVars) < 1 then
m.m.comp_assVars = m.m.comp_assVars || f
end
return compAst(m, 'A', , v, eb)
endProcedure compAss
/*--- block deals with the correct kind and operators
the content is parsed by compUnit -----------------------------*/
compBlock: procedure expose m.
parse arg m, ops
s = m.m.scan
if \ scanLit(s, '¢', '/') then
return ''
start = m.s.tok
if ops == '' | pos(right(ops, 1), m.comp_chKind) < 1 then
return scanErr(s, 'bad kind' ops 'for block')
ki = right(ops, 1)
ops = left(ops, length(ops)-1)
starter = start
if start == '¢' then
stopper = m.comp_chDol'!'
else do
call scanVerify s, '/', 'm'
starter = '/'m.s.tok'/'
stopper = m.comp_chDol || starter
if \scanLit(s, '/') then
call scanErr s, 'ending / after stopper' stopper 'expected'
end
res = compUnit(m, ki, stopper)
if \ scanLit(s, stopper, substr(stopper, 2)) then
call scanErr s, 'ending' stopper 'expected after' starter
if abbrev(starter, '/') then
m.res.text = substr(starter, 2, length(starter)-2)
return compAstAddOp(m, res, ops)
endProcedure compBlock
/**** lexicals *******************************************************/
/*--- skip a comment. return 0 if there is none ---------------------*/
compComment: procedure expose m.
parse arg m
s = m.m.scan
got = 0
do forever
if scanLit(s, m.comp_chDol'**') then
m.s.pos = 1 + length(m.s.src) /* before next nl */
else if scanLit(s, m.comp_chDol'*+') then
call scanNL s, 1
else if scanLit(s, m.comp_chDol'*(') then do
do forever
if scanVerify(s, m.comp_chDol, 'm') then iterate
if scanNL(s) then iterate
if compComment(m) then iterate
if \ scanLit(s, m.comp_chDol) then
call scanErr s, 'source end in comment'
if scanLit(s, '*)') then
return 1
if scanLit(s, m.comp_chDol) then iterate
if scanString(s) then iterate
end
end
else
return got
got = 1
end
endProcedure compComment
/*--- skip spaces and comments --------------------------------------*/
compSpComment: procedure expose m.
parse arg m, xtra
s = m.m.scan
got = 0
do forever
if scanVerify(s, m.comp_chSpa) then
got = bitOr(got, 1)
else if compComment(m) then
got = bitOr(got, 2)
else if xtra == '' then
return got
else if \ scanLit(s, xtra) then
return got
else do
got = bitOr(got, 4)
m.s.pos = 1+length(m.s.src)
end
end
endProcedure compSpComment
/*--- skip spaces, NLs and comments ---------------------------------*/
compSpNlComment: procedure expose m.
parse arg m, xtra
found = 0
do forever
if compSpComment(m, xtra) < 1 then
if \ scanNL(m.m.scan) then
return found
found = 1
end
endProcedure compSpNlComment
/*--- scan a name in one of the categories
v=var, c=compile, s=stmt ----------------------------------*/
compName: procedure expose m.
parse arg m, cats
s = m.m.scan
if \ scanName(s) then
return ''
if wordPos(m.s.tok, m.comp_wCatS) > 0 then do
if pos('s', cats) > 0 then
return 's'
end
else if wordPos(m.s.tok, m.comp_wCatC) > 0 then do
if pos('c', cats) > 0 then
return 'c'
end
else if pos('v', cats) > 0 then do
return 'v'
end
call scanBack s, m.s.tok
return ''
endProcedure compName
compOpKind: procedure expose m.
parse arg m, op
s = m.m.scan
if scanVerify(s, m.comp_chOp || m.comp_chKiNO) then
op = m.s.tok
else if op == '' then
return ''
/* ??????? temporary until old syntax vanished ????? */
x = verify(op, '%^', 'm')
if x > 0 & x < length(op) then
call scanErr s, 'old syntax? run not at end'
if right(op, 1) == '<' then
op = op'='
kx = verify(op, m.comp_chKiNO, 'm')
if kx \== 0 & kx \== length(op) then
call scanErr s, 'kind' substr(op, kx, 1) 'not after ops'
if pos(right(op, 1), m.comp_chKind) == 0 then
call scanErr s, 'no kind after ops' op
return op
endProcedure compOpKind
compSpNlComment: procedure expose m.
/**** small helper routines ******************************************/
/*--- if va == null then issue an error with msg --------------------*/
compCheckNN: procedure expose m.
parse arg m, va, msg
if va == '' then
call scanErr m.m.scan, msg 'expected'
return va
endProcedure compCheckNN
/*--- return true iff expression is empty ---------------------------*/
compIsEmpty: procedure expose m.
parse arg m, a, block0
do forever
if a == '' then
return 1
else if m.a.kind == '*' then
a = m.a.1
else if m.a.kind \== '¢' then
return 0
else if block0 then
return 0
else if m.a.0 = 1 then
a = m.a.1
else
return m.a.0 < 1
end
endProcedure compIsEmpty
/*--- if va == null or empty then issue an error with msg -----------*/
compCheckNE: procedure expose m.
parse arg m, ex, msg
e1 = left(ex, 1)
if compIsEmpty(m, ex, 1) then
call scanErr m.m.scan, msg 'expected'
return ex
endProcedure compCheckNE
/**** AST = Astract Syntax Tree ***************************************
------- atoms, no children
= string constant
+ rexx fragment
------- containers (any number of children)
- string expression
. object expression
; rexx statements
¢ block
------- molecules
* operand chain ==> 1 operands in text, as in syntax plus
) run ($@ stmt), & variable access, ! execute
& variable access==> 1
A assignment ==> 2
B proc ==> 2
C ct ==> 1
D do ==> 2
F for + with ==> 2
P Pipe ==> * 1=input 2=output , 3..* piped stmtBlocks
R aRg * list of arguments/separators
T Table
M compile
% RunOut ==> 1,2 (Run, arguments)
^ RunRet ==> 1,2 (Run, arguments)
**********************************************************************/
/*--- create a new AST ----------------------------------------------*/
compAST: procedure expose m.
parse arg m, ki, txt
n = mNew('COMP.AST')
if length(ki) <> 1 then
return err('compAST bad kind' ki) / 0
m.n.kind = ki
m.n.text = txt
if pos(ki, '¢;-.*&ABCDFPRTM%^') > 0 then do
do cx=1 to arg()-3
m.n.cx = arg(cx+3)
end
m.n.0 = cx-1
if ki == '*' then do
if verify(txt, m.comp_astOps) > 0 then
return err('compAst ki=* bad ops:' txt) / 0
end
else if txt \== '' & pos(ki, '&*FPT') < 1 then
return err('kind' ki 'text='txt'|')/0
end
else if pos(ki, '=+') > 0 then do
m.n.0 = 'kind'ki
end
else do
return err( "compAst kind '"ki"' not supported") / 0
end
return n
endProcedure compAST
/*--- free AST if empty ---------------------------------------------*/
compASTFree0: procedure expose m.
parse arg a, ret
if m.a.0 > 0 then
return a
call mFree a
return ret
endProcedure compAstFree0
/*--- add operandands to an AST -------------------------------------*/
compASTAddOp: procedure expose m.
parse arg m, a, ops
if verify(ops, m.comp_astOps) > 0 then
return err('addOp bad ops:' ops) / 0
k = if(m.a.kind=='*', left(m.a.text, 1), m.a.kind)
do while right(ops, 1) == k
ops = left(ops, length(ops)-1)
end
if ops == '' then
return a
if ki \== '*' then
return compAst(m, '*', ops, a)
m.a.text = ops || m.a.text
return a
endProcedure compAstAddOp
/*--- return the kind of an AST -------------------------------------*/
compASTKind: procedure expose m.
parse arg m, a
m.m.astOps = ''
if \ abbrev(a, 'COMP.AST.') then
return left(a, 1)
c = a
do while m.c.kind == 'ops'
if m.c.text \== '' then
return left(m.c.text, 1)
c = m.c.1
end
if a == c then
return '?'
return compAstKind(m, c)
endProcedure compASTKind
compAstSay: procedure expose m.
parse arg a, lv
if \ abbrev(a, 'COMP.AST.') then do
if a \== '' then
return err('bad ast' a)
say left('', 19)': * empty ast'
return
end
say lefPad(left('', lv) m.a.kind, 10) ,
|| rigPad(if(dataType(m.a.0, 'n'), m.a.0), 3),
'@'rigPad(substr(a, 10), 4)':' m.a.text'|'
if dataType(m.a.0, 'n') then do cx=1 to m.a.0
call compAstSay m.a.cx, lv+1
end
return
endProcedure compAstSay
compAstErr: procedure expose m.
parse arg a, txt
call errSay txt
call compAstSay a, 0
return err(txt)
endProcedure compAstErr
/*--- return the code for an AST with operand chain trg -------------*/
compCode2rx: procedure expose m.
parse arg m, ops, f
if ops == '' then
return f
o1 = right(ops, 1)
oR = left(ops, length(ops)-1)
if pos(o1, ')!') > 0 then
return compCode2rx(m, oR, strip(f))
if pos(o1, '-.<|?@') > 0 then
return compRun2rx(m, ops, quote(oRunner(f)))
call err 'compCode2rx bad ops' ops 'code='f
endProcedure compCode2rx
compCon2rx: procedure expose m.
parse arg m, ops, f, a
do ox=length(ops) by -1 to 1 while pos(substr(ops,ox,1), '.-')>0
end
if substr(ops, ox+1, 1) == '.' then
f = s2o(f)
if length(f) < 20 then
v = quote(f, "'")
else if a \== '' & m.a.text == f then
v = 'm.'a'.text'
else
v = 'm.'compAst(m, '=', f)'.text'
if substr(ops, ox+1, 1) == '.' then
return compObj2rx(m, left(ops, ox), v)
else
return compString2rx(m, left(ops, ox), v)
endProcedure compCon2rx
compString2rx: procedure expose m.
parse arg m, ops, f
if ops == '' then
return f
o1 = right(ops, 1)
oR = left(ops, length(ops)-1)
if pos(o1, '!') then
return compCode2rx(m, oR, 'call out' f)
if o1 == '-' then
return compString2rx(m, oR, f)
if o1 == '.' then
return compObj2rx(m, oR, 's2o('f')')
if o1 == '&' then do
o2 = substr('1'ops, length(ops), 1)
if pos(o2, '.<^%@)') < 1 then
return compString2rx(m, oR, 'vGet('f')')
else
return compObj2rx(m, oR, 'vGet('f')')
end
if o1 == '<' then
return compFile2rx(m, oR, 'file('f')')
call err 'compString2rx bad ops' ops
endProcedure compString2rx
compObj2rx: procedure expose m.
parse arg m, ops, f
if ops == '' then
return f
o1 = right(ops, 1)
oR = left(ops, length(ops)-1)
if o1 == '.' then
return compObj2rx(m, oR, f)
if o1 == '-' then
return compString2rx(m, oR, 'o2string('f')')
if o1 == '!' then
return compCode2rx(m, oR, 'call out' f)
if o1 == '<' then
return compFile2rx(m, oR, 'o2file('f')')
if o1 == '@' then
return compRun2Rx(m, oR, f)
if pos(o1, ')%^') > 0 then
return compRun2rx(m, ops, f)
call err 'compObj2rx bad ops' ops 'for' f
endProcedure compObj2rx
compRun2rx: procedure expose m.
parse arg m, ops, f
if ops == '' then
return f
o1 = right(ops, 1)
oR = left(ops, length(ops)-1)
if o1 == '@' then
return compRun2Rx(m, oR, f)
if pos(o1, ')%') > 0 then
return compCode2Rx(m, oR, 'call oRun' f)
if o1 == '^' then
if pos(right(oR, 1), '.<^%') < 1 then
return compString2Rx(m, oR, 'oRun('f')')
else
return compObj2Rx(m, oR, 'oRun('f')')
return compObj2rx(m, ops, f)
endProcedure compRun2rx
compFile2rx: procedure expose m.
parse arg m, ops, f
if ops == '' then
return f
o1 = right(ops, 1)
oR = left(ops, length(ops)-1)
if pos(o1, '<.@') > 0 then
return compFile2rx(m, oR, f)
if o1 == '|' | o1 == '?' then
return compObj2Rx(m, oR, 'jSingle('f ||if(o1=='?', ", ''")')')
return compRun2rx(m, ops, f)
endProcedure compFile2rx
compAst2rx: procedure expose m.
parse arg m, ops, a
ki = m.a.kind
/* astStats ausgeschaltet
if pos(ki, m.comp_astStats) < 1 then do
m.comp_astStats = m.comp_astStats ki
m.comp_astStats.ki = 0
m.comp_astStatT.ki = 0
end
m.comp_astStats.ki = m.comp_astStats.ki + 1
if m.a.text \== '' then
m.comp_astStatT.ki = m.comp_astStatT.ki + 1
if ki == '*' then do
k2 = vGet(a'.1>>KIND')
if symbol('m.comp_astStat1.k2') \== 'VAR' then
m.comp_astStat1.k2 = 1
else
m.comp_astStat1.k2 = m.comp_astStat1.k2 + 1
end */
if ki == '+' & ops == '' then
return m.a.text
if ki == '=' then
return compCon2Rx(m, ops, m.a.text, a)
if ki == '*' then
return compAst2Rx(m, ops || m.a.text, m.a.1)
o1 = right(ops, 1)
oR = left(ops, max(0, length(ops)-1))
if ki == '-' then
return compString2rx(m, ops, compCatRexxAll(m, a,,, ' || '))
if ki == '.' then
return compObj2Rx(m, ops, compCatRexxAll(m, a,,, ' || '))
if ki == ';' then
return compCode2Rx(m, ops, compCatRexxAll(m, a,,,' || '))
if ki == '¢' then do
a1 = m.a.1
if m.a.0 == 1 & m.a1.kind == '¢' then
return compAst2Rx(m, ops, a1)
if o1 == '-' then do
res = compAst2CatStr(m, a)
if res \== '' then /* () necessary if part of expression */
return compString2rx(m, oR, '('strip(res)')')
end
if o1 == '.' then
return compAst2Rx(m, ops'|', a)
if pos(o1, '|?') > 0 then
if m.a.0 = 1 & compAstOut(a1) then
return compAst2Rx(m, oR, a1)
res = ''
do ax=1 to m.a.0
res = res';' compAst2rx(m, '!', m.a.ax)
end
if verify(res, '; ') = 0 then
res = 'nop'
else
res = 'do'res'; end'
if pos(o1, '-@!)') > 0 then
return compCode2Rx(m, ops, res)
if pos(o1, '|?<') > 0 then
return compCode2Rx(m, ops'<@', res)
end
if ki == '&' then do
nm = compAst2Rx(m, '-', m.a.1)
if m.a.text=='' | m.a.text=='v' then
return compString2rx(m, ops'&', nm)
else if m.a.text == '?' then
return compString2rx(m, ops, 'vIsDefined('nm')')
else if m.a.text == '>' then
return compString2rx(m, ops, 'vIn('nm')')
else
call compAstErr a, 'bad text' m.a.text 'in ast &'
end
if ki == '%' | ki == '^' then do
c1 = compAst2Rx(m, '.', m.a.1)
if m.a.0 > 1 then
c1 = c1',' compAst2Rx(m, '', m.a.2)
return compRun2Rx(m, ops || ki, c1)
end
if ki == 'A' then do /* assignment */
nm = compAst2Rx(m, '-', m.a.1)
vl = m.a.2
if m.vl.kind == '=' | m.vl.kind == '-' ,
| (m.vl.kind == '*' & right(m.vl.text, 1) == '-') then
return compCode2Rx(m, ops,
, 'call vPut' nm',' compAst2Rx(m, '-', vl))
else
return compCode2Rx(m, ops,
, 'call vPut' nm',' compAst2Rx(m, '.', vl))
end
if ki == 'B' then do /* proc */
call vPut utInter('return' compAst2Rx(m, '-', m.a.1)),
, oRunner(compAst2Rx(m ,'!', m.a.2))
return ''
end
if ki == 'C' then do /* ct */
call utInter compAst2Rx(m, '!', m.a.1)
return ''
end
if ki == 'D' then do /* do */
res = 'do' compAst2rx(m, '', m.a.1)
if m.a.text \== '' then
res = res"; call vPut '"m.a.text"'," m.a.text
return compCode2Rx(m, ops, res';' compAst2Rx(m, '!', m.a.2),
|| "; end")
end
if ki == 'F' then do /* for... */
a1 = m.a.1
st = compAst2Rx(m, '!', m.a.2)
if abbrev(m.a.text, 'for') then do
if m.a.1 == '' then
v = "''"
else
v = compAst2Rx(m, '-', m.a.1)
if m.a.text == 'for' then
s1 = 'do while vIn('v')'
else if m.a.text \== 'forWith' then
call compAstErr a, 'bad for...'
else
s1 = 'call vWith "+"; do while vForWith('v')'
return compCode2Rx(m, ops, s1';' st'; end')
end
else if \ abbrev(m.a.text, 'with') then
call compAstErr a, 'bad with...'
if m.a1.kind \== 'A' then do
v = compAst2Rx(m, '.', a1)
end
else do
v = compAst2Rx(m, ,a1)
if \ abbrev(v, 'call vPut ') | pos(';', v) > 0 then
call scanErr s, 'bad vPut' v
v = 'vPut('substr(v, 11)')'
end
ret1 = 'call vWith "+",' v';' st
if m.a.0 <= 2 then
return ret1"; call vWith '-'"
a3 = m.a.3
if m.a3.kind \== '*' then
call compAstErr a, 'for/with a.3 not *'
return ret1';' compObj2Rx(m, m.a3.text, "vWith('-')")
end
if ki == 'P' then do /* pipe */
if ((left(m.a.text, 1) == ' ') \== (m.a.1 == '')) ,
| ((substr(m.a.text, 2) == '') \== (m.a.2 == '')) ,
| (m.a.0 <= 3 & m.a.text == '') then
call compAstErr a, 'bad/trivial astPipe'
res = ''
do ax=3 to m.a.0
a1 = ''
if ax < m.a.0 then /* handle output */
t1 = 'N'
else if m.a.1 == '' then
t1 = 'P'
else do
t1 = left(m.a.text, 1)
a1 = compAst2Rx(m, '.', m.a.1)
end
if ax == 3 then do /* handle input */
t1 = '+'t1 || substr(m.a.text, 2)
if m.a.2 \== '' then
a1 = a1',' compAst2Rx(m, '.', m.a.2)
end
else
t1 = t1'|'
res = res"; call pipe '"t1"'," a1 ,
";" compAst2Rx(m, '!', m.a.ax)
end
return compCode2Rx(m, ops, substr(res, 3)"; call pipe '-'")
end
if ki == 'R' then do /* aRg statement */
prs = 'parse arg ,'
pts = ''
do ax=1 to m.a.0
a1 = m.a.ax
if m.a1.kind = '+' & m.a1.text == ',' then
prs = prs','
else do
prs = prs 'ggAA'ax
pts = pts'; call vPut' compAst2Rx(m, '-', a1)', ggAA'ax
end
end
return compCode2rx(m, ops, prs pts)
end
if ki == 'M' then do
if m.a.0 = 0 then
args = ''
else
args = compAst2Rx(m, , m.a.1)
return compRun2rx(m, ops, 'wshHookComp( ,'args ',in2Buf())')
end
return compAstErr(a, 'compAst2rx bad ops='ops 'kind='ki 'ast='a)
endProcedure compAst2rx
compAstOut: procedure expose m.
parse arg a
if m.a.kind \== '*' then
return pos(m.a.kind, m.comp_astOut) > 0
return pos(left(m.a.text, 1), m.comp_astOut) > 0
endProcedure compAstOut
compAst2CatStr: procedure expose m.
parse arg m, a
res = ''
if compAstOut(a) then
res = compCatRexx(res, compAst2rx(m, , a), ' ')
else if m.a.kind \== '¢' then
return ''
else do ax=1 to m.a.0
b = compAst2CatStr(m, m.a.ax)
if b == '' then
return ''
res = compCatRexx(res, b, ' ')
end
return res
endProcedure compAst2CatStr
compCatRexxAll: procedure expose m.
parse arg m, a, ops, mi, sep
res = ''
do ax=1 to m.a.0
a1 = m.a.ax
res = compCatRexx(res, compAst2rx(m, ops, m.a.ax), mi , sep)
end
return strip(res)
endProcedure compCatRexxAll
/*--- cat two rexx parts, avoid strange effects ---------------------*/
compCatRexx: procedure expose m.
parse arg le, ri, mi, sep
if mi \== '' then
return le || mi || ri
lr = right(le, 1)
rl = left(ri, 1)
if (lr == "'" | lr == '"') then do
if rl == lr then /* "a","b" -> "ab" */
return left(le, length(le)-1) || substr(ri, 2)
else if rl == '(' then /* "a",( -> "a" || ( */
return le||sep||ri /* avoid function call */
end
else if pos(lr, m.comp_idChars) > 0 then
if pos(rl, m.comp_idChars'(') > 0 then
return le || sep || ri /* a,b -> a || b */
return le || ri
endProcedure compCatRexx
/* copy comp end *****************************************************/
/* copy scan begin ************************************************
Achtung: inc generiert SB aus scan, Aenderungen nur in scan|
SB = scanBasic: single line, no reader, no newLines, class not needed
scanSrc(m, source) starts scanning a single line = scanBasic
scanLook(m,len) : returns next len chars, pos is not moved
scanChar(m,len) : scans next len chars
scanString(m,q): scan a String with quote q. (with doubble = 1)
scanVerify(m,c,o): verify(...,c,o,...)
scanEnd(m) : returns whether we reached end of input
scanLit(m,lit) : scan Literal lit if present or return 0
scanChar(m,n) : scan next n characters
scanName(m) : scan a name
ScanNat(m) : scan a natural number (without sign)
scanString(m,q): scan a String with quote q. (with doubble = 1)
scanVerify(m,c,o): verify(...,c,o,...)
scanKeyValue(m): scan a key = value clause (with spaces)
scanWord(m,st,uc) : scan a space delimited word or a string,
st=stopper, if u=1 then uppercase non-strings
scanSpace(m) : skips over spaces (and nl and comment if \ basic
scanInfo(m) : text of current scan location
scanErr(m, txt): error with current scan location
m is an address, to store our state
returns: true if scanned, false otherwise
if a scan function succeeds, the scan position is moved
m.m.tok ==> last token
m.m.val ==> last value for scanString/Word
m.m.pos ==> scan position
m.m.src ==> scan source
**********************************************************************/
/*--- start basic scannig: set new src, reset outFields -------------*/
scanSrc: procedure expose m.
parse arg m, m.m.src
m.m.pos = 1
m.m.tok = ''
m.m.scanIsBasic = 1
return m
endProcedure scanSrc
scanBasic: procedure expose m.
parse arg src
if symbol('m.scan.0') == 'VAR' then
m.scan.0 = m.scan.0 + 1
else
m.scan.0 = 1
return scanSrc('SCAN.'m.scan.0, src)
endProcedure scanBasic
scanEr3: procedure expose m.
parse arg m, txt, info
return err('s}'txt'\n'info)
scanErr: procedure expose m.
parse arg m, txt
if arg() > 2 then
return err(m,'old interface scanErr('m',' txt',' arg(3)')')
return scanEr3(m, txt, scanInfo(m))
/*--- scanInfo: text of current scan position for scanErr -----------*/
scanInfo: procedure expose m.
parse arg m
if m.m.scanIsBasic then
return scanSBInfo(m)
else
interpret objMet(m, 'scanInfo')
endProcedure scanInfo
scanSBInfo: procedure expose m.
parse arg m
return 'last token' m.m.tok 'scanPosition' ,
strip(substr(m.m.src, m.m.pos, 40), 't') ,
|| '\npos' m.m.Pos 'in string' strip(m.m.src, 't')
/*--- return the next len characters until end of src ---------------*/
scanLook: procedure expose m.
parse arg m, len
if len == '' then
return substr(m.m.src, m.m.pos)
else
return substr(m.m.src, m.m.pos,
, min(len, 1 + length(m.m.src) - m.m.pos))
endProcedure scanLook
/*--- scan len chararcters, atmost to end of src --------------------*/
scanChar: procedure expose m.
parse arg m, len
m.m.tok = scanLook(m, len)
m.m.pos = m.m.pos + length(m.m.tok)
return m.m.tok \== ''
endProcedure scanChar
/*--- scan the literal lit ------------------------------------------*/
scanLit: procedure expose m.
parse arg m
do ax=2 to arg()
if abbrev(substr(m.m.src, m.m.pos), arg(ax)) then do
m.m.tok = arg(ax)
m.m.pos = m.m.pos + length(arg(ax))
return 1
end
end
m.m.tok = ''
return 0
endProcedure scanLit
/*--- scan with verify, vOpt is passed to verify --------------------*/
scanVerify: procedure expose m.
parse arg m, alpha, vOpt
if vOpt == '' then /* empty string does not take default */
nx = verify(m.m.src, alpha, , m.m.pos)
else
nx = verify(m.m.src, alpha, vOpt, m.m.pos)
if nx = 0 then
nx = length(m.m.src) + 1
m.m.tok = substr(m.m.src, m.m.pos, nx - m.m.pos)
m.m.pos = nx
return m.m.tok \== ''
endProcedure scanVerify
/*--- scan while in charset -----------------------------------------*/
scanWhile: procedure expose m.
parse arg m, chSet
return scanVerify(m, chSet, 'n')
/*--- scan until in charset -----------------------------------------*/
scanUntil: procedure expose m.
parse arg m, chSet
return scanVerify(m, chSet, 'm')
/*--- scan until (and over) string End ------------------------------*/
scanStrEnd: procedure expose m.
parse arg m, sep
sx = m.m.pos
bx = sx
do forever
ex = pos(sep, m.m.src, sx)
if ex = 0 then do
m.m.val = m.m.val || substr(m.m.src, bx)
return 0
end
m.m.val = m.m.val || substr(m.m.src, bx, ex-bx)
bx = ex + length(sep)
if \ abbrev(substr(m.m.src, bx), sep) then do
m.m.tok = m.m.tok || substr(m.m.src, m.m.pos, bx-m.m.pos)
m.m.pos = bx
return 1
end
sx = bx + length(sep)
end
endProcedure scanStrEnd
/*--- scan a string with quote char qu ------------------------------*/
scanString: procedure expose m.
parse arg m, prefs
if prefs = '' then do
call scanLit m, "'", '"'
end
else do
do px=1 to words(prefs) until scanLit(m, word(prefs, px))
end
end
if m.m.tok == '' then
return 0
m.m.val = ''
if \ scanStrEnd(m, m.m.tok) then
return scanErr(m, 'ending Apostroph missing')
return 1
endProcedure scanString
/*--- scan a word and put value into *.val
a word is either delimited by space or stopper
or a string (with single or double quotes ------*/
scanWord: procedure expose m.
parse arg m, stopper, ucWord
if scanString(m) then
return 1
if stopper == '' then
stopper = m.ut_space
if \scanUntil(m, stopper) then
return 0
if ucWord == 1 then
m.m.val = translate(m.m.tok)
else
m.m.val = m.m.tok
return 1
endProcedure scanWord
/*--- skip, scan and return word or scanErr -------------------------*/
scanRetWord: procedure expose m.
parse arg m, stopper, ucWord, eWhat
if scanWord(scanSKip(m), stopper, ucWord) then
return m.m.val
else
return scanErr(m, eWhat 'expected')
endProcedure scanRetWord
/*--- scan a key = word phrase
put key into m.key and word into m.m.val -------*/
scanKeyValue: procedure expose m.
parse arg m, def, uc
if \ scanWord(m, ' =''"') then
return 0
m.m.key = m.m.val
if \ scanLit(scanSkip(m), '=') then
m.m.val = def
else if \ scanWord(scanSkip(m)) then
return scanErr(m, 'word expected after' m.m.key '=')
if uc == 1 then
upper m.m.key m.m.val
return 1
endProcedure scanKeyValue
/*--- scan over space, nl, comments ---------------------------------*/
scanSpace: procedure expose m.
parse arg m
if m.m.scanIsBasic then
return scanSpaceOnly(m)
else
return scanSpNlCo(m)
endProcedure scanSpace
scanSpaceOnly: procedure expose m.
parse arg m
nx = verify(m.m.src, m.ut_space, , m.m.pos)
if nx = 0 then
nx = length(m.m.src) + 1
m.m.tok = left(' ', nx <> m.m.pos)
m.m.pos = nx
return m.m.tok == ' '
endProcedure scanSpaceOnly
/*--- skip over space and return m ----------------------------------*/
scanSkip: procedure expose m.
parse arg m
call scanSpace m
return m
endProcedure scanSkip
/*--- return true if at end of src ----------------------------------*/
scanEnd: procedure expose m.
parse arg m
if m.m.pos <= length(m.m.src) then
return 0
else if m.m.scanIsBasic then
return 1
else
return m.m.atEnd
endProcedure scanEnd
/*--- scan a natural number (no sign, decpoint ...) Ignore After ----*/
scanNatIA: procedure expose m.
parse arg m
return scanVerify(m, '0123456789')
/*--- scan an integer (optional sign, no decpoint ...) Ignore After -*/
scanIntIA: procedure expose m.
parse arg m
poX = m.m.pos
call scanLit m, '-', '+'
if \ scanNatIA(m) then do
m.m.pos = poX
return 0
end
m.m.tok = substr(m.m.src, poX, m.m.pos - poX)
return 1
endProcedure scanIntIA
/*--- scanOpt set the valid characters for names, and comments
it must be called
before any of the following functions ---------------------*/
scanOpt: procedure expose m.
parse arg m, m.m.scanName1, namePlus, m.m.scanComment, nest
if m.m.scanName1 == '' then
m.m.scanName1 = m.ut_alfa
if namePlus == '' then
m.m.scanNameR = m.m.scanName1 || '0123456789'
else
m.m.scanNameR = m.m.scanName1 || namePlus
m.m.scanNestCom = nest == 1
return m
endProcedure scanOpt
/*--- return true if at comment -------------------------------------*/
scanSBCom: procedure expose m.
parse arg m
m.m.tok = ''
if m.m.scanComment == '' then
return 0
if \ abbrev(substr(m.m.src, m.m.pos), m.m.scanComment) then
return 0
m.m.tok = substr(m.m.src, m.m.pos)
m.m.pos = 1 + length(m.m.src)
return 1
endProcedure scanSBCom
/*--- scan a Name, first char in *.scanName1, rest in *.scanNameR ---*/
scanName: procedure expose m.
parse arg m
if pos(substr(m.m.src, m.m.pos, 1),
, m.m.scanName1) <= 0 then do
m.m.tok = ''
return 0
end
return scanVerify(m, m.m.scanNameR)
endProcedure scanName
/*--- check character after a number
must not be Identifier or plus ----------------------------*/
scanCheckNumAfter: procedure expose m.
parse arg m, res, plus
if \ res then
return 0
if pos(substr(m.m.src, m.m.pos, 1), m.m.scanNameR || plus) > 0 then
call scanErr m, 'illegal char after number' m.m.tok
return 1
endProcedure scanCheckNumAfter
/*--- scan a natural number check character after -------------------*/
scanNat: procedure expose m.
parse arg m
if arg() \== 1 then
return err('old interface scanNat') / 0
return scanCheckNumAfter(m, scanNatIA(m), '.')
endProcedure ScanNat
/*--- scan an Integer check character after -------------------------*/
scanInt: procedure expose m.
parse arg m
if arg() \== 1 then
return err('old interface scanInt') / 0
return scanCheckNumAfter(m, scanIntIA(m), '.')
endProcedure ScanInt
/*--- scan a Number check character after ---------------------------*/
scanNum: procedure expose m.
parse arg m
if arg() \== 1 then
return err('old interface scanNum') / 0
return scanCheckNumAfter(m, scanNumIA(m))
endProcedure ScanInt
/*--- scan a number (optional sign, decpoint, exponent) Ignore After-*/
scanNumIA: procedure expose m.
parse arg m
poX = m.m.pos
call scanLit m, '-', '+'
cx = scanNumUSPos(m)
if cx == 0 then do
m.m.pos = poX
return 0
end
m.m.tok = substr(m.m.src, poX, cx-poX)
m.m.val = translate(m.m.tok)
m.m.pos = cx
return 1
endProcedure scanNumIA
/*--- scan unsigned number (opt. decpoint, exponent) Ignore After ---*/
scanNumUSPos: procedure expose m.
parse arg m
poX = m.m.pos
cx = verify(m.m.src, '0123456789', , poX)
if cx > 0 then
if substr(m.m.src, cx, 1) == '.' then
cx = verify(m.m.src, '0123456789', , cx+1)
if cx < 1 then do
if abbrev('.', substr(m.m.src, poX)) then
return 0
end
else if abbrev('.', substr(m.m.src, poX, cx-poX)) then do
return 0
end
else if pos(substr(m.m.src, cx, 1), 'eE') > 0 then do
cy = cx + 1 + (pos(substr(m.m.src, cx+1, 1), '-+') > 0)
cx = verify(m.m.src, '0123456789', , cy)
if cx==cy | (cx == 0 & cy > length(m.s.src)) then
call scanErr m, 'exponent expected after E'
end
if cx >= poX then
return cx
else
return length(m.s.src)+1
/*
m.m.tok = substr(m.m.src, poX, cx-poX)
m.m.pos = cx
end
else do
m.m.tok = substr(m.m.src, poX)
m.m.pos = length(m.s.src)+1
end
m.m.val = translate(m.m.tok)
return 1 */
endProcedure scanNumUSPos
scanType: procedure expose m.
parse arg m, opt
m.m.tok = ''
if scanName(m) then
m.m.type = 'n'
else if scanNum(m) then
m.m.type = 0
else if scanString(m) then
m.m.type = left(m.m.tok, 1)
else if scanSpace(m) then
m.m.type = 's'
else do
call scanChar m, 1
m.m.type = m.m.tok
end
return m.m.type
endProcedure scanType
/* copy scan end *************************************************/
/* copy scanRead begin ***********************************************
Scan: scan an input: with multiple lines
==> all of scan
returns: true if scanned, false otherwise
m.m.tok ==> last token
m.m.val ==> last value for scanString/Word/KeyValue
m.key ==> key for scanKeyValue
m.m.pos ==> scan position
m.m.src ==> scan source
**********************************************************************/
scanReadIni: procedure expose m.
if m.scanRead_ini == 1 then
return
m.scanRead_ini = 1
call jIni
ts = classNew('n ScanRes u f TOK v, f VAL v, f KEY v, f TYPE v')
call classNew 'n ScanRead u JRW', 'm',
, 'oReset return scanReadReset(m, arg)',
, 'scanNL return scanReadNL(m, unCond)',
, 'scanCom return scanSBCom(m)',
, 'scanInfo return scanReadInfo(m)',
, 'scanPos return scanReadPos(m)',
, "jOpen call scanReadOpen m, arg(3)" ,
, "jClose call scanReadClose m" ,
, 'isWindow 0',
, "jRead if scanType(m) == '' then return 0;" ,
"m.rStem.1 = oClaCopy('"ts"', m, ''); m.rStem.0 = 1"
call classNew "n EditRead u JRW", "m" ,
, "jRead if \ editRead(m, rStem) then return 0",
, "jOpen" ,
, "jReset m.m.linex = arg - 1"
call classNew 'n ScanSqlStmtRdr u JRW', 'm',
, "jReset call scanSqlStmtRdrReset m, arg, arg2",
, "jOpen call scanOpen m'.SCAN'" ,
, "jClose call scanClose m'.SCAN'" ,
, "jRead r = scanSqlStmt(m'.SCAN');if r=='' then return 0" ,
"; m.rStem.1 = r; m.rStem.0 = 1"
return
endProcedure scanReadIni
scanOpen: procedure expose m.
parse arg m
interpret objMet(m, 'jOpen')
return m
endProcedure scanOpen
scanClose: procedure expose m.
parse arg m
interpret objMet(m, 'jClose')
return m
endProcedure scanClose
/*--- scan over white space, nl, comments ...------------------------*/
scanSpNlCo: procedure expose m.
parse arg m
res = 0
do while scanSpaceOnly(m) | scanCom(m) | scanNl(m)
res = 1
end
m.m.tok = left(' ', res)
return res
endProcedure scanSpNlCo
/*--- scan next line ------------------------------------------------*/
scanNL: procedure expose m.
parse arg m, unCond
interpret objMet(m, 'scanNL')
/*--- scanNl until line starts with trg -----------------------------*/
scanNlUntil: procedure expose m.
parse arg s, trg
do until scanLook(s, length(trg)) == trg
if \ scanNl(s, 1) then
return 0
end
return 1
endProcedure scanNlUntil
/*--- scan one comment ----------------------------------------------*/
scanCom: procedure expose m.
parse arg m
interpret objMet(m, 'scanCom')
/*--- go back the current token -------------------------------------*/
scanBack: procedure expose m.
parse arg m, tok
if m.m.pos <= length(tok) then
call scanErr sc, 'cannot back "'tok'" length'
cx = m.m.pos - length(tok)
if substr(m.m.src, cx, length(tok)) \== tok then
return scanErr(m, 'cannot back "'tok'" value') + sauerei
m.m.pos = cx
return
endProcedure scanBack
/*--- return position in simple format ------------------------------*/
scanPos: procedure expose m.
parse arg m
interpret objMet(m, 'scanPos')
endProcedure scanPos
/*--- set position to position in arg to-----------------------------*/
scanBackPos: procedure expose m.
parse arg m, to
cur = scanPos(m)
wc = words(cur)
if wc <> words(to) ,
| subWord(cur, 1, wc-1) <> subWord(to, 1, wc-1) then
call scanErr m 'cannot back from' cur 'to' to
m.m.pos = word(to, wc)
return
endProcedure scanBackPos
/*--- begin scanning the lines of a reader --------------------------*/
scanRead: procedure expose m.
parse arg rdr, n1, np, co
return scanOpt(oNew(m.class_ScanRead, rdr), n1, np, co)
scanReadReset: procedure expose m.
parse arg m, m.m.rdr m.m.strip .
return oMutate(m, m.class_ScanRead)
endProcedure scanReadReset
scanReadOpen: procedure expose m.
parse arg m, line0
call jOpen m.m.rdr, '<'
return scanSetPos0(m, (line0 == '') 1, line0)
endProcedure scanReadOpen
scanReadClose: procedure expose m.
parse arg m
call jClose m.m.rdr
m.m.atEnd = 'closed'
return m
endProcedure scanReadClose
/*--- scan over next newLine
if unCond \== 1 only if we are already at endOfLine
return true if we scanned a NL -----------------------------*/
scanReadNL: procedure expose m.
parse arg m, unCond
m.m.tok = ''
if unCond \== 1 then
if m.m.pos <= length(m.m.src) then
return 0
if m.m.atEnd then
return 0
if unCond == '?' then
return 1
m.m.tok = substr(m.m.src, m.m.pos)
r = m.m.rdr
if \ jRead(r) then do
m.m.atEnd = 1
m.m.pos = 1 + length(m.m.src)
return 0
end
if m.m.strip == '-' then
m.m.src = m.r
else /* strip trailing spaces for vl32755 inputs ,
use only if nl space* is equivalent to nl */
m.m.src = strip(m.r, 't')
m.m.pos = 1
m.m.lineX = m.m.lineX + 1
return 1
endProcedure scanReadNl
/*--- postition scanner to lx px (only with jBuf)
after rdr is positioned to line before ----------------------*/
scanSetPos: procedure expose m.
parse arg m, lx px
call jPosBefore m.m.rdr, lx
return scanSetPos0(m, lx px)
/*--- postition scanner to lx px
after rdr is positioned to line before -------------------------*/
scanSetPos0: procedure expose m.
parse arg m, lx px, line0
call scanReset m, line0
call scanNl m
m.m.lineX = lx
m.m.pos = px
return m
endProcedure scanSetPos0
/*--- reset scanner fields ------------------------------------------*/
scanReset: procedure expose m.
parse arg m, m.m.src
m.m.pos = 1
m.m.tok = ''
m.m.scanIsBasic = 0
m.m.atEnd = 0
m.m.lineX = 0
m.m.val = ''
m.m.key = ''
return m
endProcedure
scanTextCom: procedure expose m.
parse arg m, untC, untWrds
if \ m.m.scanNestCom then
return scanText(m, untC, untWrds)
else if wordPos('*/', untWrds) > 0 then
return scanText(m, untC'*/', untWrds)
res = scanText(m, untC'*/', untWrds '*/')
if res then
if scanLook(m, 2) == '*/' then
call scanErr m, '*/ without preceeding comment start /*'
return res
endProcedure scanTextCom
scanText: procedure expose m.
parse arg m, untC, untWrds
res = ''
do forever
if scanUntil(m, untC) then do
res = res || m.m.tok
if m.m.pos > length(m.m.src) then do
/* if windowing we need to move the window| */
if scanNl(m, 0) then
if right(res, 1) \==' ' & scanLook(m, 1)\==' ' then
res = res' '
iterate
end
end
c9 = scanLook(m, 9)
do sx=1 to words(untWrds)
if abbrev(c9, word(untWrds, sx)) then do
m.m.tok = res
return 1
end
end
if scanCom(m) | scanNl(m, 0) then do
if right(res, 1) \== ' ' & scanLook(m, 1) \== ' ' then
res = res' '
end
else if scanString(m) then
res = res || m.m.tok
else if scanChar(m, 1) then
res = res || m.m.tok
else if scanEnd(m) then do
m.m.tok = res
return res \== '' /* erst hier NACH scanCom, scanNl */
end
else
call scanErr m, 'bad pos'
end
endProcedure scanText
scanReadPos: procedure expose m.
parse arg m, msg
return m.m.lineX m.m.pos
endProcedure scanReadPos
scanReadInfo: procedure expose m.
parse arg m
msg = 'last token' m.m.tok 'scanPosition' ,
strip(substr(m.m.src, m.m.pos, 40), 't')
if scanEnd(m) then
msg = msg'\natEnd after'
else
msg = msg'\npos' m.m.pos 'in'
return msg 'line' m.m.lineX':' strip(m.m.src, 't')
endProcedure scanReadInfo
/*--- use scan sqlEdit macro --> temporarily here -------------------*/
/*--- read next line from edit data ---------------------------------*/
editRead: procedure expose m.
parse arg m, rStem
m.m.lineX = m.m.lineX + 1
if adrEdit('(ll) = line' m.m.lineX, 12) \= 0 then
return 0
m.rStem.1 = ll
m.rStem.0 = 1
return 1
endProcedure editRead
/*--- search loop in edit macro -------------------------------------*/
scanSqlSeekId: procedure expose m.
parse arg m, lx, cmd, opts
if opts = '' then
opts = word
/* line 1 col 0, otherwise first word is skipped*/
if adrEdit("cursor =" max(trunc(lx), 1) 0, 12) = 12 then
return -1
do while adrEdit("seek" cmd opts, 4) = 0 /* find each command*/
call adrEdit "(fx) = cursor"
if m.debug then do
call adrEdit "(LI) = LINE" fx
call debug 'scanSqlSeekId after' lx 'found' cmd 'at' fx li
end
call jReset m.m.rdr, fx
call jOpen m, '<'
m.m.lineX = fx
do while word(scanPos(m), 1) <= fx & scanSqlClass(m)
if m.m.sqlClass = 'i' & m.m.val == cmd then
return fx
end
call jClose m
end
return -1
endProcedure scanSqlSeekId
/* copy scanRead end *************************************************/
/* copy scanWin begin *************************************************
scan the the concatenation of the lines of a reader
any token my be split over several line
except the end-of-line-comment-token
**********************************************************************/
scanWinIni: procedure expose m.
if m.scanWin.ini = 1 then
return
m.scanWin.ini = 1
call scanReadIni
call classNew 'n ScanWin u ScanRead', 'm',
, "oReset call scanWinReset m, arg, arg2",
, "jOpen call scanWinOpen m, arg(3)",
, "jClose call scanReadClose m",
, 'scanNL return scanWinNl(m, unCond)',
, 'scanCom return scanWinCom(m)',
, 'scanInfo return scanWinInfo(m)',
, 'scanPos return scanWinPos(m)',
, 'isWindow 1'
return
endProcedure scanWinIni
/*--- instanciate a new window scanner ------------------------------*/
scanWin: procedure expose m.
parse arg rdr, wOpts
return oNew(m.class_ScanWin, rdr, wOpts)
/*--- set the reader and window attributes of scanner m -------------*/
scanWinReset: procedure expose m.
parse arg m, m.m.rdr, winOpt
return scanSqlOpt(scanWinOpt(oMutate(m, m.class_ScanWin), winOpt))
/*--- set the window scanner attributes -----------------------------*/
scanWinOpt: procedure expose m.
parse arg m, cuLe wiLi wiBa
if pos('@', cuLe) > 0 then
parse var cuLe cuLe '@' m.m.cutPos
else
m.m.cutPos = 1
cuLe = word(cuLe 72, 1)
m.m.cutLen = cuLe /* fix recLen */
wiLe = cuLe * (1 + word(wiLi 5, 1))
m.m.posMin = word(wiba 3, 1) * cuLe /* room to go back */
m.m.posLim = m.m.posMin + wiLe
m.m.winTot = m.m.posLim + wiLe
return m
endProcedure scanWinReset
/*--- open reader and start scanning --------------------------------*/
scanWinOpen: procedure expose m.
parse arg m, line0
call jOpen m.m.rdr, '<'
if line0 == '' then
return scanSetPos0(m, 1 1)
if length(line0) // m.m.cutLen \== 0 then
line0 = line0||left('', m.m.cutLen - length(line0)//m.m.cutLen)
return scanSetPos0(m, (1 - length(line0) % m.m.cutLen) 1, line0)
endProcedure scanWinOpen
/*--- move the source window: cut left side and append at right side
return number of characters cut at left -----------------------*/
scanWinRead: procedure expose m.
parse arg m
dlt = 0
if m.m.atEnd then
return 0
if m.m.pos >= m.m.posLim then do /* cut left side */
dlt = m.m.pos - ((m.m.pos-1) // m.m.cutLen + 1 + m.m.posMin)
call assert 'dlt >= 0 & dlt // m.m.cutLen = 0','dlt m.m.cutLen'
m.m.src = substr(m.m.src, dlt+1)
m.m.pos = m.m.pos - dlt
m.m.lineX = m.m.lineX + dlt % m.m.cutLen
end
r = m.m.rdr
do while length(m.m.src) < m.m.winTot /* read and fill to len */
if \ jRead(r) then do
m.m.atEnd = 1
return dlt
end
m.m.src = m.m.src || substr(m.r, m.m.cutPos, m.m.cutLen)
end
call assert 'length(m.m.src) = m.m.winTot',
, 'm.m.winTot length(m.m.src) m.m.src'
return dlt
endProcedure scanWinRead
/*--- return position of next line start ----------------------------*/
scanWinNLPos: procedure expose m.
parse arg m
return m.m.pos + m.m.cutLen - ((m.m.pos - 1) // m.m.cutLen)
/*--- scan comment --------------------------------------------------*/
scanWinCom: procedure expose m.
parse arg m
call scanWinRead m
if m.m.scanComment \== '' then do
cl = length(m.m.scanComment)
if scanLook(m, cl) == m.m.scanComment then do
np = scanWinNlPos(m)
if np = m.m.pos then
np = np + m.m.cutLen
if np >= m.m.pos + cl then do
m.m.tok = substr(m.m.src, m.m.pos, np - m.m.pos)
m.m.pos = np
return 1
end
end
end
if m.m.scanNestCom then
if scanLit(m, '/*') then do
tk = substr(m.m.src, m.m.pos, m.m.cutLen + 2)
call scanTextCom m, , '*/'
if \ scanLit(m, '*/') then
call scanErr m, 'nested comment after /* not finished'
if pos('*/', tk) < 1 then
m.m.tok = left(tk, m.m.cutLen - 5)'...*/'
else
m.m.tok = left(tk, pos('*/', tk) + 1)
return 1
end
m.m.tok = ''
return 0
endProcedure scanWinCom
/*--- scan nl -------------------------------------------------------*/
scanWinNL: procedure expose m.
parse arg m, unCond
call scanWinRead m
m.m.tok = ''
if unCond \== 1 then
return 0
np = scanWinNLPos(m)
if np = m.m.pos then
return 0
if unCond == '?' then
return 1
m.m.tok = substr(m.m.pos, np-m.m.pos)
m.m.pos = np
return 1
endProcedure scanWinNl
/*--- return current position in input ------------------------------*/
scanWinPos: procedure expose m.
parse arg m
ps = m.m.pos - 1
return (m.m.lineX + (ps % m.m.cutLen)) (ps // m.m.cutLen + 1)
endProcedure scanWinPos
/*--- return a description of the current scan position -------------*/
scanWinInfo: procedure expose m.
parse arg m
p = scanWinPos(m)
if scanEnd(m) then do
res = 'atEnd after'
p = m.m.lineX - 1 + length(m.m.src) % m.m.cutLen
p = word(p, 1)
end
else do
res = 'pos' word(p, 2) 'in'
p = word(p, 1)
end
return 'last token' m.m.tok 'scanPosition' ,
strip(left(substr(m.m.src, m.m.pos), 40), 't') ,
|| '\n'res 'line' p':' strip(substr(m.m.src,
, 1 + (p - m.m.lineX) * m.m.cutLen, m.m.cutLen), 't')
endProcedure scanWinInfo
/* copy scanWin end ************************************************/
/* copy scanSql begin ************************************************/
/*--- initialize with reader inRdr ----------------------------------*/
scanSqlReset: procedure expose m.
parse arg m, r, scanWin, stmtOpt
call scanSqlStmtOpt scanSqlOpt(m), strip(stmtOpt)
if scanWin \== 0 then
return scanWinReset(m, r, scanWin)
else if r \== '' then
return scanReadReset(m, r)
else
return scanSrc(m, m.m.src)
endProcedure scanSqlReset
scanSqlOpt: procedure expose m.
parse arg m
return scanOpt(m, m.ut_alfa'$#@', '0123456789_' , '--', 1)
endProcedure scanSqlOpt
/*--- scan a sql token put class in m.sqlclass:
'i': ordinary identifier e.g. Name
'd': delimited identifier e.g. "Delimited"
'q': qualified identifier e.g. abc."efg"
'u': integer units e.g. 8G
'n': number e.g. -234 or .2e3
's': string e.g. 'abc''ef'
'' : at end
: any other character e.g. ;
---------------------------------------------------------------*/
scanSqlClass: procedure expose m.
parse arg m, retSpace
m.m.val = ''
if scanSpNlCo(m) & retSpace = 1 then do
m.m.sqlClass = 'b'
return 1
end
c2 = scanLook(m ,2)
if scanLit(m, "'", "x'", "X'") then do
if \ scanStrEnd(m, "'") then
call scanErr m, 'ending apostroph missing'
m.m.sqlClass = 's'
if \abbrev(m.m.tok, "'") then
m.m.val = x2c(m.m.val)
end
else if scanSqlQuId(m, 1) then do
if m.m.val.0 > 1 then
m.m.sqlClass = 'q'
else if abbrev(m.m.tok, '"') then
m.m.sqlClass = 'd'
else
m.m.sqlClass = 'i'
end
else if scanSqlNumPM(m) then do
if m.m.tok == '-' | m.m.tok == '+' then
m.m.sqlClass = m.m.tok
else
m.m.sqlClass = 'n'
end
else if scanChar(m, 1) then
m.m.sqlClass = m.m.tok
else if scanEnd(m) then do
m.m.sqlClass = ''
return 0
end
else
call scanErr m, 'cannot scan sql'
return 1
endProcedure scanSqlClass
scanSqlSkipBrackets: procedure expose m.
parse arg m, br
if br \== '' then
nop
else if scanLit(m, '(') then
br = 1
else
return 0
do while scanSqlClass(m) & m.m.sqlClass \== ';'
if m.m.sqlClass = '(' then br = br + 1
else if m.m.sqlClass \== ')' then iterate
else if br > 1 then br = br - 1
else return 1
end
call scanErr m, '; or eof, but' br 'closing ) expected'
endProcedure skipBrackets
/*--- scan an ordinary sql identifier e.g. abc, ef_12 ---------------*/
scanSqlId: procedure expose m.
parse arg m
if \ scanName(m) then
return 0
m.m.val = translate(m.m.tok)
return 1
endProcedure scanSqlId
/*--- scan a delimited or ordinay sql identifier --------------------*/
scanSqlDeId: procedure expose m.
parse arg m
if scanSqlId(m) then
return 1
if \ scanString(m, '"') then
return 0
m.m.val = strip(m.m.val, 't')
return 1
endProcedure scanSqlDeId
/*--- scan a qualified sql identifier -------------------------------*/
scanSqlQuId: procedure expose m.
parse arg m, starOk
res = ''
rto = ''
do qx=1
if \ scanSqlDeId(m) then do
if qx == 1 then
return 0 /* sometimes last qual may be '*' */
if starOk \== 1 | \ scanLit(m, '*') then
call scanErr m, 'id expected after .'
else if scanLit(scanSkip(m), '.') then
call scanErr m, 'dot after id...*'
else
leave
end
m.m.val.qx = m.m.val
res = res'.'m.m.val
rto = rto'.'m.m.tok
if \ scanLit(scanSkip(m), '.') then
leave
call scanSpace m
end
m.m.val.0 = qx
m.m.val = substr(res, 2)
m.m.tok = substr(rto, 2)
return 1
endProcedure scanSqlQuId
/*--- scan a sql number, Ignore After -------------------------------*/
scanSqlNumIA: procedure expose m.
parse arg m
if \ scanSqlNumPM(m) then
return 0
else if m.m.tok == '+' | m.m.tok == '-' then
call scanErr m, 'no sqlNum after +-'
return 1
endProcedure scanSqlNumIA
/*--- scan a sql number, + or -, ignore after -----------------------*/
scanSqlNumPM: procedure expose m.
parse arg m
if scanLit(m, '+', '-') then do
si = m.m.tok
call scanSkip m
end
else
si = ''
cx = scanNumUSPos(m)
if cx == 0 then do
m.m.val = si
m.m.tok = si
return si \== ''
end
m.m.tok = si || substr(m.m.src, m.m.pos, cx-m.m.pos)
m.m.val = translate(m.m.tok)
m.m.pos = cx
return 1
endProcedure scanSqlNumIA
/*--- scan a sql number, check After --------------------------------*/
scanSqlNum: procedure expose m.
parse arg m
if arg() \== 1 then
return err('old interface scanSqlNum') / 0
return scanCheckNumAfter(m, scanSqlNumIA(m))
endProcedure ScanSqlNum
/*--- scan a sql number with a unit which may follow without space --*/
scanSqlNumUnit: procedure expose m.
parse arg m, both, units
if \ scanSqlNumIA(m) then
return 0
nu = m.m.val
sp = scanSpace(m)
if scanSqlId(m) then do
if units == '' | wordpos(m.m.val, units) > 0 then
nu = nu m.m.val
else if both | \ sp then
call scanErr m, 'bad unit' m.m.val 'after' nu
else
call scanBack m, m.m.tok
end
else if both then
call scanErr m, 'no unit after' nu
else if \sp & pos(scanLook(m, 1), m.m.scanNameR) > 0 then
call scanErr m, 'bad unit after number' nu
m.m.val = nu
return 1
endProcedure scanSqlNumUnit
/*--- find next statement, after scanSqlStmtOpt -----------------------
m.m.stop contains delimiter, will be changed by
terminator?; or --#terminator */
scanSqlStmtOpt: procedure expose m.
parse arg m, m.m.stop
if m.m.stop == '' then
m.m.stop = ';'
return m
endProcedure scanSqlStmtOpt
scanSqlStop: procedure expose m.
parse arg m
res = ''
fuCo = copies(m.m.scanComment'#SET', m.m.scanComment \== '')
u1 = '''"'left(m.m.scanComment, m.m.scanComment \== '')
do lx=1
if lx > 100 then
say '????iterating' scanLook(m)
if m.m.stop == '' then
scTx = scanTextCom(m, u1 ,fuCo)
else
scTx = scanTextCom(m, u1||left(m.m.stop,1), m.m.stop fuCo)
if scTx then
res = res || m.m.tok
if fuCo \== '' then
if scanLook(m, length(fuCo)) == fuCo then do
if scanCom(m) then do
tx = m.m.tok
if word(tx, 2) == 'TERMINATOR' ,
& length(word(tx, 3)) == 1 then do
m.m.stop = word(tx, 3)
if \ (right(res, 1) == ' ' ,
| scanLook(m, 1) == ' ') then
res = res' '
end
else
say 'ignoring --##SET at' scanInfo(m)
end
iterate
end
if m.m.stop \== '' then
call scanLit m, m.m.stop
res = strip(res)
if length(res)=11 ,
& abbrev(translate(res), 'TERMINATOR') then do
m.m.stop = substr(res, 11, 1)
res = ''
end
return res
end
endProcedure scanSqlStop
scanSqlStmt: procedure expose m.
parse arg m
do forever
res = scanSqlStop(m)
if res <> '' then
return res
if scanEnd(m) then
return ''
end
endProcedure scanSqlStmt
/*-- return next sqlStmt from rdr ( or string or '' = j.in) ---------*/
scanSqlIn2Stmt: procedure expose m.
parse arg rdr, wOpt
s = scanSqlIn2Scan(rdr, m'.SCAN_SqlIn2Stmt', wOpt)
res = scanSqlStmt(scanOpen(s))
call scanReadClose s
return res
endProcedure scanSqlIn2Stmt
/*-- reset s as scanSql from rdr ( or string or '' = j.in) ----------*/
scanSqlIn2Scan: procedure expose m.
parse arg m, s, wOpt, sOpt
if m \== '' & wOpt == '' then
if oKindOfString(m) then
wOpt = 0
return scanSqlReset(s, in2File(m), wOpt, sOpt)
endProcedure scanSqlIn2Scan
/*-- create a new scanSqlStmtRdr ------------------------------------*/
scanSqlStmtRdr: procedure expose m.
parse arg rdr, wOpt, sOpt
return oNew('ScanSqlStmtRdr', rdr, wOpt, sOpt)
/*-- reset a new scanSqlStmtRdr
must be called from jReset to allow jRead ------------------*/
scanSqlStmtRdrReset: procedure expose m.
parse arg m, rdr, wOpt, sOpt
call scanSqlIn2Scan rdr, m'.SCAN', wOpt, sOpt
return oMutate(m, m.class_ScanSqlStmtRdr)
endProcedure scanSqlStmtRdrReset
/* copy scanSql end ************************************************/
/* copy scanUtil begin ************************************************
scan db2 utility input statements using scan and a reader
**********************************************************************/
/*--- initialize with reader inRdr ----------------------------------*/
scanUtilOpt: procedure expose m.
parse arg m
call scanSqlOpt m
m.m.scanNestCom = 0
m.m.utilBrackets = 0
m.scanUtil = 'BACKUP CATENFM CATMAINT CHECK' ,
'COPY COPYTOCOPY DIAGNOSE EXEC LISTDEF LOAD' ,
'MERGECOPY MODIFY OPTIONS QUIESCE REBUILD' ,
'RECOVER REORG REPAIR REPORT RESTORE' ,
'RUNSTATS STOSPACE TEMPLATE UNLOAD'
return m
endProcedure scanUtilOpt
/*--- scan next token and put its class in m.sc.utilClass:
'u' a utility name
'n' a name
'"' a quoted name
"'" an apostroph'd string
'.' a .
',' a ,
'v' a value
'' at end
---------------------------------------------------------------*/
scanUtil: procedure expose m.
parse arg sc
m.sc.utilSpace = scanSpace(sc)
ty = '?'
if scanLit(sc, '(') then do
m.sc.utilBrackets = m.sc.utilBrackets + 1
end
else if scanLIT(sc, ')') then do
m.sc.utilBrackets = m.sc.utilBrackets - 1
if m.sc.utilBrackets < 0 then
call scanErr sc, 'unmatched closing bracket )'
end
else if scanLit(sc, ',') then do
end
else if scanLit(sc, '.') then do
end
else if scanString(sc, "'") then do
end
else if scanString(sc, '"') then do
end
else if scanName(sc) then do
m.sc.val = translate(m.sc.tok)
if m.sc.utilBrackets > 0 then
ty = 'n'
else if 0 < wordPos(m.sc.val, m.scanUtil) then
ty = 'u'
else
ty = 'n'
end
else if scanVerify(sc, ' (),''"', 'm') then do
ty = 'v'
m.sc.val = translate(m.sc.tok)
end
else if \scanEnd(sc) then do
call scanErr sc, 'scanUtil stopped before end'
end
else do
ty = ''
m.sc.val = ''
end
if ty == '?' then
m.sc.utilClass = left(m.sc.tok, 1)
else
m.sc.utilClass = ty
return m.sc.utilClass
endProcedure scanUtil
/*--- scan a value or a bracketed list of values --------------------*/
scanUtilValue: procedure expose m.
parse arg sc, remApo, nl
if remApo = '' | rempApo = 0 then
remApo = "nv"
else if rempApo = 1 then
remApo = "nv'"
if '(' \== scanUtil(sc) then
return scanUtilValueOne(sc, remApo)
v = ''
brx = m.sc.utilBrackets
oLine = word(scanPos(sc), 1)
do forever
call scanUtil sc
one = scanUtilValueOne(sc, remApo)
if one == '' then
call scanErr sc, 'eof in brackets'
else if brx > m.sc.utilBrackets then
return v
nLine = word(scanPos(sc), 1)
if \ m.sc.utilSpace then
v = v || one
else if nl \== '' & oLine <> nLine then
v = v || nl || one
else
v = v' 'one
oLine = nLine
end
endProcedure scanUtilValue
scanUtilValueOne: procedure expose m.
parse arg sc, valTy
if m.sc.utilClass == '' then
return ''
else if m.sc.utilClass == 'u' then
call scanErr sc, 'util in scanUtilValueOne'
if pos(m.sc.utilClass, valTy) > 0 then
return m.sc.val
else
return m.sc.tok
endProcedure scanUtilValueOne
/*--- skip over nested brackets -------------------------------------*/
scanUtilSkipBrackets: procedure expose m.
parse arg m, br, doCat
if br \== '' then
lim = m.m.utilBrackets - br
else if scanLit(m, '(') then do
lim = m.m.utilBrackets
m.m.utilBrackets = lim + 1
end
else
return 0
doCat = doCat == 1
res = ''
do while scanUtil(m) \== ''
if m.m.utilBrackets <= lim then do
if doCat then
m.m.val = res
return 1
end
if doCat then
res = res m.m.tok
end
return scanErr(m, 'eof with' m.m.utilBrackets 'open (')
endProcedure skipBrackets
/*--- analyze a punch file write intoField to stdOut ----------------*/
scanUtilInto: procedure expose m.
parse arg m
if m.m.utilBrackets \== 0 then
call scanErr m, 'scanUtilInto with brackets' m.m.utilBrackets
/*sc = scanUtilReader(m.j.in)
call jOpen sc, 'r'
*/ do forever
cl = scanUtil(m)
if cl == '' then
return 0
if cl = 'n' & m.m.tok == 'INTO' then
leave
end
if scanUtil(m) \== 'n' | m.m.tok \== 'TABLE' then
call scanErr m, 'bad into table '
if \ scanSqlQuId(scanSkip(m)) then
call scanErr m, 'table name expected'
if m.m.utilBrackets \== 0 then
call scanErr m, 'into table in brackets' m.m.utilBrackets
m.m.tb = m.m.val
m.m.part = ''
m.m.when = ''
do forever
cl = scanUtil(m)
if cl == '' then
call scanErr m, 'eof after into'
if cl == 'n' & m.m.tok == 'PART' then do
if scanUtil(m) == 'v' then
m.m.part = m.m.val
else
call scanErr m, 'bad part'
end
else if cl=='n' & wordPos(m.m.val, 'WHEN WORKDDN') > 0 then do
call scanUtilSkipBrackets m
end
else if cl == '(' then do
leave
end
end
oX = m.m.lineX
oL = overlay('', m.m.src, 1, m.m.pos-2)
do while m.m.utilBrackets > 0
call scanUtil m
if oX \== m.m.lineX then do
call out strip(oL, 't')
oX = m.m.lineX
oL = m.m.src
end
end
call out left(oL, m.m.pos)
/* call jClose sc
*/ return 1
endProcedure scanUtilInto
/* copy scanUtil end *************************************************/
/* copy pipe begin ****************************************************
**********************************************************************/
pipeIni: procedure expose m.
if m.pipe_ini == 1 then
return
m.pipe_ini = 1
call catIni
call mapReset v
m.v_with.0 = 0
m.v_withMap = ''
m.v_with.0.map = ''
m.pipe.0 = 1
m.pipe.1.in = m.j.in
m.pipe.1.out = m.j.out
call pipe '+'
return
endProcedure pipeIni
/*-------------------------------
+- push pop frame
PYNFA ouput: Parent saY Newcat File, Appendtofile
psf| input: parent string file oldOut
old --> new
pipeBegin --> pipe '+N'
pipeBeLa f --> pipe '+F'
pipeLast --> pipe 'P|'
pipeLast f --> pipe 'F|', f
pipeEnd --> pipe '-'
--------------------------------*/
pipe: procedure expose m.
parse arg opts, aO
ox = 1; oc = substr(opts, ox, 1)
ax = m.pipe.0
px = ax -1
if oc == '-' then do
if px < 2 then
call err 'pipe pop empty'
call jClose m.pipe.ax.out
call jClose m.pipe.ax.in
ax = px
m.pipe.0 = ax
px = ax-1
ox = ox+1; oc = substr(opts, ox, 1)
end
if oc == '+' then do
px = ax
ax = ax+ 1
m.pipe.0 = ax
m.pipe.ax.in = jOpen(m.pipe.px.in, '<')
m.pipe.ax.out = jOpen(m.pipe.px.out, '>')
ox = ox+1; oc = substr(opts, ox, 1)
end
oOut = m.pipe.ax.out
if pos(oc, 'NYPFA') > 0 then do
call jClose oOut
if oc == 'Y' then
m.pipe.ax.out = jOpen(m.pipe.1.out, '>')
else if oc == 'P' then
m.pipe.ax.out = jOpen(m.pipe.px.out, '>')
else if oc == 'N' then
m.pipe.ax.out = jOpen(Cat(), '>')
else if oc == 'F' then
m.pipe.ax.out = jOpen(o2file(aO), '>')
else if oc == 'A' then
m.pipe.ax.out = jOpen(o2file(aO), '>>')
ox = ox+1; oc = substr(opts, ox, 1)
end
m.j.out = m.pipe.ax.out
if oc \== ' ' then do
call jClose m.pipe.ax.in
if substr(opts, ox+1) = '' & oc \== 's' then
ct = ''
else
ct = jOpen(Cat(), '>')
lx = 3
do forever
if oc == 's' then do
call jWrite ct, arg(lx)
lx = lx + 1
end
else do
if oc == 'p' then
i1 = m.pipe.px.in
else if oc == '|' then
i1 = oOut
else if oc == 'f' then do
i1 = arg(lx)
lx = lx + 1
end
else
call err 'implement' oc 'in pipe' opts
if ct \== '' then
call jWriteAll ct, o2File(i1)
end
ox = ox + 1
if substr(opts, ox, 1) == ' ' then
leave
else if ct == '' then
call err 'pipe loop but ct empty'
else
oc = substr(opts, ox, 1)
end
if ct == '' then
m.pipe.ax.in = jOpen(o2file(i1), '<')
else
m.pipe.ax.in = jOpen(jClose(ct), '<')
if lx > 3 & lx <> arg() + 1 then
call err 'pipe opts' opts 'but' arg() 'args not' (lx-1)
end
m.j.in = m.pipe.ax.in
return
endProcedure pipe
/*--- write all from rdr (rsp in) to out, not lazy ----------------*/
pipeWriteNow: procedure expose m.
parse arg rdr
call jWriteNow m.j.out, if(rdr == '', m.j.in, rdr)
return
endProcedure pipeWriteNow
/*--- write all from rdr (rsp in) to out, possibly lazy -----------*/
pipeWriteAll: procedure expose m.
parse arg rdr
call jWriteAll m.j.out, if(rdr == '', m.j.in, rdr)
return
endProcedure pipeWriteAll
pipePreSuf: procedure expose m.
parse arg le, ri
do while in()
call out le || m.in || ri
end
return
endProcedure pipePreSuf
vIsDefined: procedure expose m.
parse arg na
return '' \== vAdr(na, 'g')
endProcedure vIsDefined
vWith: procedure expose m.
parse arg fun, o
if fun == '-' then do
tBe = m.v_with.0
tos = tBe - 1
if tos < 0 then
call err 'pop empty withStack'
m.v_with.0 = tos
m.v_withMap = m.v_with.tos.map
return m.v_with.tBe.obj
end
else if fun \== '+' then
call err 'bad fun vWith('fun',' o')'
par = m.v_with.0
tos = par + 1
m.v_with.0 = tos
if symbol('m.v_with.tos.obj') == 'VAR' then
if objClass(o) == objClass(m.v_with.tos.obj) then do
m.v_with.tos.obj = o
m.v_withMap = m.v_with.tos.map
return
end
m.v_with.tos.obj = o
if par > 0 then
key = m.v_with.par.classes
else
key = ''
if o \== '' then
key = strip(key objClass(o))
m.v_with.tos.classes = key
if symbol('m.v_withManager.key') == 'VAR' then do
m.v_with.tos.map = m.v_withManager.key
m.v_withMap = m.v_withManager.key
return
end
m = mapNew()
m.v_with.tos.map = m
m.v_withMap = m
m.v_withManager.key = m
do kx=1 to words(key)
c1 = word(key, kx)
call vWithAdd m, kx, classMet(c1, 'oFlds')
call vWithAdd m, kx, classMet(c1, 'stms')
end
return
endProcedure vWith
vWithAdd: procedure expose m.
parse arg m, kx, ff
do fx=1 to m.ff.0
n1 = m.ff.fx
dx = pos('.', n1)
if dx > 1 then
n1 = left(n1, dx-1)
else if dx = 1 | n1 = '' then
iterate
call mPut m'.'n1, kx
end
return
endProcedure vWithAdd
vForWith: procedure expose m.
parse arg var
call vWith '-'
if \ vIn(var) then
return 0
call vWith '+', m.in
return 1
endProcedure vForWith
vGet: procedure expose m.
parse arg na
a = vAdr(na, 'g')
if a = '' then
call err 'undefined var' na
return m.a
endProcedure vGet
vPut: procedure expose m.
parse arg na, val
a = vAdr(na, 'p')
m.a = val
return val
endProcedure vPut
/*--- find the final address
return f || a with address a and
f = m -> mapGet(a), o -> obect m.a, s -> string m.a ---*/
vAdr: procedure expose m.
parse arg na, f
cx = 0
cx = verify(na, '&>', 'm')
if cx > 0 then
a = left(na, cx-1)
else do
a = na
cx = length(na)+1
end
nxt = 0
do forever
cy = verify(na, '&>', 'm', cx+1)
if cy > 0 then
fld = substr(na, cx+1, cy-cx-1)
else
fld = substr(na, cx+1)
if substr(na, cx, 1) == '>' then do
if nxt then
a = vAdrByM(a)
if fld \== '' then
a = a'.'fld
end
else do
if nxt then
a = vAdrByM(a)
mp = m.v_withMap
aL = a
if pos('.', a) > 0 then
aL = left(a, pos('.', a)-1)
if mp \== '' & symbol('m.mp.aL') == 'VAR' then do
wx = m.mp.aL
a = m.v_with.wx.obj'.'a
end
else if cx >= length(na) then
return mapAdr(v, a, f)
else
a = mapAdr(v, a, 'g')
if fld \== '' then
a = vAdrByM(a)'.'fld
end
if cy < 1 then do
if f == 'g' then
if symbol('m.a') \== 'VAR' then
return ''
return a
end
cx = cy
nxt = 1
end
endProcedure vAdr
vAdrByM:
parse arg axx
if axx = '' then
return err('null address at' substr(na, cx) 'in' na)
if symbol('m.axx') \== 'VAR' then
return err('undef address' axx 'at' substr(na, cx) 'in' na)
ayy = m.axx
if ayy == '' then
return err('null address at' substr(na, cx) 'in' na)
return ayy
endProcedure vAdrByM
vIn: procedure expose m.
parse arg na
if \ in() then
return 0
if na \== '' then
call vPut na, m.in
return 1
endProcedure vIn
vRead: procedure expose m. /* old name ????????????? */
parse arg na
say '||| please use vIn instead fo vIn'
return vIn(na)
vHasKey: procedure expose m.
parse arg na
return mapHasKey(v, na)
vRemove: procedure expose m.
parse arg na
return mapRemove(v, na)
/* copy pipe end *****************************************************/
/* copy cat begin ****************************************************
**********************************************************************/
/*--- create a new cat ----------------------------------------------*/
cat: procedure expose m.
m = oNew('Cat') /* calls catReset */
do ax=1 to arg()
call catWriteAll m, arg(ax)
end
return m
endProcedure cat
catReset: procedure expose m.
parse arg m
m.m.RWs.0 = 0
m.m.catWr = ''
m.m.catRd = ''
m.m.catIx = -9e9
m.m.catKeepOpen = ''
return m
endProcedure catReset
catClose: procedure expose m.
parse arg m
if m.m.catWr \== '' then do
call jClose m.m.catWr
call mAdd m'.RWS', m.m.catWr
m.m.catWr = ''
end
if m.m.catRd \== '' then do
call jClose m.m.catRd
m.m.catRd = ''
end
m.m.catIx = -9e9
return m
endProcedure catClose
catOpen: procedure expose m.
parse arg m, oo
if oo == m.j.cRead then do
m.m.catIx = 0
call catNextRdr m
end
else if oo == m.j.cWri | oo == m.j.cApp then do
if oo == m.j.cWri then
m.m.RWs.0 = 0
m.m.catIx = -55e55
end
else do
call err 'catOpen('m',' oo') bad opt'
end
return m
endProcedure catOpen
/*--- return and open next reader -----------------------------------*/
catNextRdr: procedure expose m.
parse arg m
if m.m.catRd \== '' then
call jClose m.m.catRd
cx = m.m.catIx + 1
m.m.catIx = cx
if cx > m.m.RWs.0 then do
m.m.catRd = ''
return 0
end
m.m.catRd = m.m.RWs.cx
if cx = word(m.m.catKeepOpen, 1) then
m.m.catKeepOpen = subWord(m.catKeepOpen, 2)
else
call jOpen m.m.catRd , m.j.cRead
return 1
endProcedure catNextRdr
catRead: procedure expose m.
parse arg m, rStem
do while m.m.catRd \== ''
if jReadSt(m.m.catRd, rStem) then
return 1
call catNextRdr m
end
return 0
endProcedure catRead
catWrite: procedure expose m.
parse arg m, wStem
if m.m.catWr == '' then
m.m.catWr = jOpen(jBuf(), m.j.cWri)
call jWriteSt m.m.catWr, wStem
return
endProcedure catWrite
/*--- write contents of a reader to cat
or keep it for later reading ------------------------------*/
catWriteAll: procedure expose m.
parse arg m
if m.m.catWr \== '' then do
call mAdd m'.RWS', jClose(m.m.catWr)
m.m.catWr = ''
end
do ax=2 by 1 to arg()
r = o2File(arg(ax))
call mAdd m'.RWS', r
if m.r.jReading then do
m.m.catKeepOpen = m.m.rws.0 m.m.catKeepOpen
call jOpen r, m.j.cRead
end
end
return
endProcedure catWriteAll
/*--- create a reader/WriteO for an external file -------------------*/
file: procedure expose m.
parse arg str
return oNew('File', str)
endProcedure file
fileChild: procedure expose m.
parse arg m, name, opt
interpret objMet(m, 'fileChild')
endProcedure fileChild
fileRm: procedure expose m.
parse arg m
interpret objMet(m, 'fileRm')
return
endProcedure fileRm
filePath: procedure expose m.
parse arg m
interpret objMet(m, 'filePath')
endProcedure filePath
fileIsFile: procedure expose m.
parse arg m
interpret objMet(m, 'fileIsFile')
endProcedure fileIsFile
fileIsDir: procedure expose m.
parse arg m
interpret objMet(m, 'fileIsDir')
endProcedure fileIsDir
fileMkDir: procedure expose m.
parse arg m, opt
interpret objMet(m, 'fileMkDir')
return
endProcedure fileRm
fileRmDir: procedure expose m.
parse arg m, opt
interpret objMet(m, 'fileRmDir')
return
endProcedure fileRm
/*--- create a reader/WriteO for the filelist of a directory---------*/
fileList: procedure expose m.
parse arg m, opt
if oKindOfString(m) then
return oNew('FileList', dsn2Jcl(oAsString(m)), opt)
else
return oNew('FileList', filePath(m), opt)
endProcedure fileList
catIni: procedure expose m.
if m.cat.ini == 1 then
return
m.cat.ini = 1
call errIni
call jIni
call classNew "n Cat u JRW", "m",
, "jOpen call catOpen m, opt",
, "jReset call catReset m, arg",
, "jClose call catClose m",
, "jRead if \ catRead(m, rStem) then return 0",
, "jWrite call catWrite m, wStem",
, "jWriteAll call catWriteAll m, rdr; return"
if m.err_os == 'TSO' then
call fileTsoIni
else
call err 'file not implemented for os' m.err_os
return
endProcedure catIni
/* copy cat end ***************************************************/
/* copy mail begin ***************************************************/
mailHead: procedure expose m.
parse arg m, subj, rec, snd
m.m.1 = 'sender='if(snd=='', userid(), snd)
m.m.2 = 'type=TEXT/HTML'
m.m.3 = 'to='rec
m.m.4 = 'subject='subj
m.m.5 = 'SEND=Y'
m.m.6 = 'TEXT=<HTML>'
m.m.7 = 'TEXT=<HEAD>'
m.m.8 = 'TEXT=</HEAD>'
m.m.9 = 'TEXT=<BODY>'
m.m.10 = 'TESTINFO=Y'
m.m.0 = 10
return m
endProce4 re mailHead
/*--- add one or several arguments to stem m.a ----------------------*/
mailText: procedure expose m.
parse arg a
ix = m.a.0
do ax = 2 to arg()
ix = ix + 1
m.a.ix = 'text='arg(ax)
end
m.a.0 = ix
return a'.'ix
endProcedure mailText
mailSend: procedure expose m.
parse arg m, dsn
call mAdd m,'INFO=Y' ,
,'TEXT=</BODY>' ,
,'TEXT=</HTML>'
call dsnAlloc 'dd(mailIn)' if(dsn<> '', dsn, 'new') '::v4092'
call writeDD mailIn, 'M.'m'.'
call tsoClose mailIn
if m.mail_libAdd \== 0 then do
dsnOs3560 = 'PCL.U0000.P0.'iirz2dsn(sysVar(sysNode)) ,
|| 'AKT.PERM.@008.LLB'
call adrTSO "TLIB ADD DATASET('"dsnOs3560"') STEPLIB"
end
address LINKMVS 'OS3560'
if rc <> 0 then
call err 'call OS3560 failed Rc('rc')'
if m.mail_libAdd \== 0 then
call adrTSO "TLIB delete DATASET('"dsnOs3560"') STEPLIB"
call tsoFree mailIn
return 0
endProcedure mailSend
/* copy mail end *****************************************************/
/* copy fileTso begin ************************************************/
fileTsoReset: procedure expose m.
parse arg m, sp
m.m.wriMax = 200
if symbol('m.m.defDD') \== 'VAR' then
m.m.defDD = 'CAT*'
m.m.spec = sp
return m
endProcedure fileTsoReset
fileTsoOpen: procedure expose m.
parse arg m, opt
call dsnSpec m, m.m.spec
if m.m.dsn ='INTRDR' | wordPos('WRITER(INTRDR)', m.m.attr) > 0 then
m.m.stripT = 80
else
m.m.stripT = copies('t',
, pos(':V', m.m.attr) < 1 | pos('RECFM(V', m.m.attr) > 0)
if opt == m.j.cRead then do
aa = dsnAllo2(m, 'SHR', m.m.defDD)
if pos('(', m.m.dsn) > 0 & m.m.sys == '' then
if sysDsn("'"m.m.dsn"'") <> 'OK' then
call err 'cannot read' m.m.dsn':' sysDsn("'"m.m.dsn"'")
call tsoOpen word(aa, 1), 'R'
end
else do
if opt == m.j.cApp then
aa = dsnAllo2(m, 'MOD', m.m.defDD)
else if opt == m.j.cWri then
aa = dsnAllo2(m, 'OLD', m.m.defDD)
else
call err 'fileTsoOpen('m',' opt') with bad opt'
call tsoOpen word(aa, 1), 'W'
end
m.m.buf.0 = 0
parse var aa m.m.dd m.m.free
call errAddCleanup 'call jCloseClean' m
return m
endProcedure fileTsoOpen
fileTsoClose: procedure expose m.
parse arg m
call tsoClose m.m.dd
call tsoFree m.m.free
m.m.free = ''
m.m.dd = ''
call errRmCleanup 'call jCloseClean' m
return m
endProcedure fileTsoClose
fileTsoWrite: procedure expose m.
parse arg m, wStem
if m.m.stripT \== '' then do
m.j_b.0 = m.wStem.0
if m.m.stripT == 't' then do bx=1 to m.j_b.0
m.j_b.bx = strip(m.wStem.bx, m.m.stripT)
end
else do bx=1 to m.j_b.0
m.j_b.bx = left(m.wStem.bx, m.m.stripT)
end
wStem = j_b
end
call writeDD m.m.dd, 'M.'wStem'.', , m.m.tso_truncOk == 1
return
endProcedure fileTsoWrite
fSub: procedure expose m.
return file('sysout(T) writer(intRdr)')
endProcedure fSub
/*--- open file with spec spec, edit it at close --------------------
vw = if contains abbrev of VIEW then view
if contains 0 then do NOT use o2text ------------------*/
fEdit: procedure expose m.
parse arg spec, vw
if spec == '' then
spec = 'new ::f'
else if abbrev(spec, '::') then
spec = 'new' spec
else if abbrev(spec, ':') then
spec = 'new' ':'spec
if pos('0', vw) < 1 then
f = oNew(m.class_FileEdit, spec)
else do
f = oNew(m.class_FileEdit0, spec)
vw = strip(translate(vw, ' ', 0))
end
m.f.editArgs = vw
return f
endProcedure fEdit
fileTsoEditClose: procedure expose m.
parse arg m
dsn = m.m.dsn
parse var m.m.editArgs eTy eAr
upper eTy
if abbrev('VIEW', eTy, 1) then
eTy = 'view'
else do
if \ abbrev('EDIT', eTy) then
eAr = m.m.editArgs
eTy = 'edit'
end
/* parm uses a variable not text ||||*/
cx = pos('PARM(', translate(eAr))
cy = pos(')', eAr, cx+5)
if cx > 0 & cy > cx then do
macrParm = substr(eAr, cx+5, cy-cx-5)
eAr = left(eAr, cx+4)'macrParm'substr(eAr, cy)
end
if dsn \== '' then do
call fileTsoClose m
call adrIsp eTy "dataset('"dsn"')" eAr, 4
return
end
fr = m.m.free
dd = m.m.dd
m.m.free = ''
call fileTsoClose m
call adrIsp "LMINIT DATAID(lmmId) ddName("dd") ENQ(SHRW)"
eRc = adrIsp(eTy "dataid("lmmId")" eAr, '*')
lRc = adrIsp("LMFree DATAID("lmmId")", '*')
call tsoFree fr
if (eRc \== 0 & eRc \== 4) | lRc \== 0 then
call err eTy eAr 'rc' eRc', lmFree rc' lRc
return
endProcedure fileTsoEditClose
fileTsoIni: procedure expose m.
if m.fileTso.ini == 1 then
return
m.fileTso.ini = 1
m.file.sep = '.'
m.fileTso.buf = 0
call jIni
um = "call err 'for tso undefined method'"
call classNew "n File u JRW", "m",
, "jOpen call fileTsoOpen m, opt",
, "jReset call fileTsoReset m, arg",
, "jClose call fileTsoClose m",
, "jRead if \ readDD(m.m.dd, 'M.'rStem'.') then return 0",
, "jWrite call fileTsoWrite m, wStem",
, "filePath call dsnSpec m, m.m.spec; return m.m.dsn" ,
, "fileIsFile" um "'fileIsFile'" ,
, "fileIsDir return 1" ,
, "fileChild return file(word(m.m.spec, 1)'.'name opt)",
, "fileRm" um "'fileRm'" ,
, "fileMkDir" ,
, "fileRmDir" um "'fileRmDir'"
call classNew "n FileList u JRW", "m",
, "jReset if arg2 == 'r' then m.m.dsnMask=arg'.**';",
"else m.m.dsnMask=arg || copies('.*', pos('*', arg) < 1)" ,
, "jOpen call csiOpen m, m.m.dsnMask",
, "jClose" ,
, "jRead do bx=1 to 10 while csiNext(m, rStem'.'bx); end;",
"m.rStem.0=bx-1"
call classNew "n FileEdit0 u File", "m",
, "jClose call fileTsoEditClose m"
call classNew "n FileEdit u FileEdit0, f MAXL v", "m",
, "jOpen call fileTsoOpen m,opt; m.m.maxL=tsoDSIMaxl(m.m.dd)",
, "jWrite call fileTsoWrite m, o2TextStem(wStem, j_b,m.m.maxL)"
return
endProcedure fileTsoIni
/* copy fileTso end ************************************************/
/* copy mat begin ****************************************************/
sqrt: procedure expose m.
parse arg n
if n < 2 then
return n
k = 1
g = n
do while k+1 < g
m = (g + k) % 2
if m * m <= n then
k = m
else
g = m
end
return k
endProcedure sqrt
isPrime: procedure expose m.
parse arg n
if n < 2 then
return 0
if n // 2 = 0 then
return n = 2
do q=3 by 2 to sqrt(n)
if n // q = 0 then
return 0
end
return 1
endProcedure isPrime
nxPrime: procedure expose m.
parse arg n
do i = n + (\ (n // 2)) by 2
if isPrime(i) then
return i
end
endProcedure nxPrime
permut: procedure expose m.
parse arg m, p
m.m.1 = 1
do i=2 while p > 0
j = i - (p // i)
m.m.i = m.m.j
m.m.j = i
p = p % i
end
m.m.0 = i-1
return i-1
endProcedure permut
/* copy mat end ****************************************************/
/* copy db2Util begin ************************************************/
/--- return (first) list of columns from punch file
i.e. lines between first pair of ( and ) on a line
used by abub gbGr ----------------------------------------------*/
loadCols: procedure expose m.
if (\ in()) | word(m.in, 1) <> 'LOAD' then
call err 'not load but' m.l1
do while in() & strip(m.in) \== '('
end
if strip(m.in) \== '(' then
call err '( not found in load:' m.in
m.in = '-'
do while in() & strip(m.in) \== ')'
call out m.in
end
if strip(m.in) \== ')' then
call err ') not found in load:' m.in
return 1
endProcedure loadCols
/* ???????????? achtung nicht fertig |
Idee: allgemein Punch Umformungs Utility
aber man müsste wohl auf scan Util umstellen
und abstürzen wenn man etwas nicht versteht
GrundGerüst von cadb2 umgebaut
????????????????? */
db2UtilPunch: procedure expose m.
parse upper arg args
call scanSrc scanOpt(s), args
a.rep = 1
a.tb = ''
a.trunc = 0
a.iDD = ''
a.iDSN = ''
do while scanKeyValue(scanSkip(s), 1)
ky = m.s.key
say '????ky' ky m.s.val
if wordPos(ky, 'REP TB TRUNC IDD IDSN') < 1 then
call scanErr s, 'bad key' ky
a.ky = m.s.val
end
if a.iDSN \== '' then do
if a.iDD == '' then
a.iDD = 'IDSN'
call out ' TEMPLATE' a.iDD 'DSN('a.iDsn')'
end
do while in() & word(m.in, 1) <> 'LOAD'
call out m.in
end
ll = space(m.in, 1)
if \ abbrev(ll, 'LOAD DATA ') then
call err 'bad load line:' m.in
call out subword(m.in, 1, 2) 'LOG NO'
if abbrev(ll, 'LOAD DATA INDDN ') then
call db2UtilPunchInDDn word(ll, 4)
else if \ abbrev(ll, 'LOAD DATA LOG ') then
call err 'bad load line' m.in
if a.rep then
call out ' STATISTICS INDEX(ALL) UPDATE ALL'
call out ' DISCARDS 1'
call out ' ERRDDN TERRD'
call out ' MAPDDN TMAPD '
call out ' WORKDDN (TSYUTD,TSOUTD) '
call out ' SORTDEVT DISK '
do in()
li = m.in
if pos('CHAR(', li) > 0 then
call out strip(li, 't') 'TRUNCATE'
else if word(li, 1) word(li, 3) == 'PART INDDN' then do
call out li,
call out ' RESUME NO REPLACE COPYDDN(TCOPYD)' ,
call out ' DISCARDDN TDISC '
end
else
call out li
end
return
endProcedure db2UtilPunch
db2UtilPunchInDDn:
parse arg inDDn
if a.iDD == '' then
ll = ' INDDN' inDDn
else
ll = ' INDDN' a.iDD
if a.rep then
call out ll 'RESUME NO REPLACE COPYDDN(TCOPYD)'
else
call out ll 'RESUME YES'
call out ' DISCARDDN TDISC'
return
endSubroutine db2UtilPunchInDDn
/* copy db2Util end ************************************************/
/* copy sqlDiv begin *************************************************/
/*--- generate the format m for a sql cx as specified in sp
use the information from the sqlDa ------------------------*/
sqlFTabReset: procedure expose m.
parse arg ff, maxCh, maxBlo, maxDe
return sqlFTabOpts(fTabReset(ff, , , '-'), maxCh, maxBlo, maxDe)
/*--- default formats per datatype ----------------------------------*/
sqlFTabOpts: procedure expose m.
parse arg ff, m.ff.maxChar, m.ff.blobMax, m.ff.maxDec
if m.ff.maxChar == '' then
m.ff.maxChar = 32
if m.ff.blobMax == '' then
m.ff.blobMax = 200
bf = '%-'max(m.ff.blobMax, 4)'C'
m.ff.sql2fmt.384 = '%-10C' /* date */
m.ff.sql2fmt.388 = '%-8C' /* time */
m.ff.sql2fmt.392 = '%-26C' /* timestamp */
m.ff.sql2fmt.400 = 'c' /* graphic string */
m.ff.sql2fmt.404 = bf /* BLOB */
m.ff.sql2fmt.408 = bf /* CLOB */
m.ff.sql2fmt.412 = bf /* DBCLOB */
m.ff.sql2fmt.448 = 'c' /* varchar */
m.ff.sql2fmt.452 = 'c' /* char */
m.ff.sql2fmt.452 = 'c' /* long varchar */
m.ff.sql2fmt.460 = 'c' /* null term. string */
m.ff.sql2fmt.464 = 'c' /* graphic varchar */
m.ff.sql2fmt.468 = 'c' /* graphic char */
m.ff.sql2fmt.472 = 'c' /* long graphic varchar */
m.ff.sql2fmt.480 = '%-7e' /* float */
m.ff.sql2fmt.484 = 'd' /* packed decimal */
m.ff.sql2fmt.492 = '%20i' /* bigInt */
m.ff.sql2fmt.496 = '%11i' /* int */
m.ff.sql2fmt.500 = '%6i' /* smallInt */
m.ff.sql2fmt.904 = '%-34H' /* rowID 17 Byte Binary */
return ff
endProcedure sqlFTabOpts
/*--- set a defaultFormat for type tx in fTab ff --------------------*/
sqlFTabDef: procedure expose m.
parse arg ff, tx, m.ff.sql2fmt.tx
return ff
/*--- complete / override column info from sqlCa --------------------*/
sqlFTabComplete: procedure expose m.
parse arg m, cx, aOth, aFmt
if aOth then
call sqlFTabOthers m, cx
f2x = classMet(sqlFetchClass(cx), 'f2x')
do tx=1 to m.m.0
c1 = m.m.tx.col
if symbol('m.m.set.c1') == 'VAR' then do
sx = m.m.set.c1
parse var m.m.set.sx c1 aDone
m.m.tx.done = aDone \== 0
m.m.tx.fmt = m.m.set.sx.fmt
m.m.tx.labelSh = m.m.set.sx.labelSh
end
if symbol('m.f2x.c1') \== 'VAR' then
iterate
kx = m.f2x.c1
if m.m.tx.labelLo = '' then
m.m.tx.labelLo = m.sql.cx.d.kx.sqlName
if m.m.tx.labelSh = '' then
m.m.tx.labelSh = m.sql.cx.d.kx.sqlName
if m.m.tx.fmt <> '' | \ aFmt then
iterate
/* use format for datatype */
ty = m.sql.cx.d.kx.sqlType
ty = ty - ty // 2 /* odd = with null */
le = m.sql.cx.d.kx.sqlLen
if symbol('m.m.sql2fmt.ty') <> 'VAR' then
call err 'sqlType' ty 'col' c1 'not supported'
f1 = m.m.sql2fmt.ty
if f1 == 'c' then
f1 = '%-'min(le, m.m.maxChar)'C'
else if f1 == 'd' then do
pr = m.sql.cx.d.kx.sqlLen.sqlPrecision
sc = m.sql.cx.d.kx.sqlLen.sqlScale
if sc < 1 then
f1 = '%' || (pr + 1) || 'i'
else
f1 = '%' || (pr + 2) || '.'sc'i'
end
if \ abbrev(f1, '%') then
call err 'sqlType' ty 'col' c1 'bad format' f1
m.m.tx.fmt = f1
end
return m
endProcedure sqlFTabComplete
/*--- add all cols of sqlCA to fTab,
that are not yet (witho aDone=0) ----------------------*/
sqlFTabOthers: procedure expose m.
parse arg m, cx
do cy=1 to m.m.0
if m.m.cy.done then do
nm = m.m.cy.col
done.nm = 1
end
end
ff = m.sql.cx.fetchFlds
do kx=1 to m.sql.cx.d.sqlD
c1 = word(ff, kx)
if done.c1 \== 1 then
call ftabAdd m, c1
end
return m
endProcedure sqlFTabOthers
/*--- fetch all rows from cursor cx, tabulate and close crs ---------*/
sqlFTab: procedure expose m.
parse arg m, cx
if pos('o', m.m.opt) < 1 then
call sqlFTabComplete m, cx, pos('|', m.m.opt) < 1,
, pos('a', m.m.opt) < 1
if pos('a', m.m.opt) > 0 | pos('o', m.m.opt) > 0 then
return fTab(m, sqlQuery2Rdr(cx))
/* fTab would also work in other cases,
however, we do it without sqlQuery2Rdr */
dst = 'SQL_fTab_dst'
if pos('c', m.m.opt) > 0 then do
if pos('c', m.m.generated) < 1 then
call fTabGenCol m
do rx=1 while sqlFetch(cx, dst)
call out left('--- row' rx '', 80, '-')
call fTabCol m, dst
end
call out left('--- end of' (rx-1) 'rows ', 80, '-')
end
else do
call fTabBegin m
do rx=1 while sqlFetch(cx, dst)
call out f(m.m.fmt, dst)
end
call fTabEnd m
end
call sqlClose cx
return m
endProcedure sqlFTab
/*--- create insert statment into table tb
for object m in spufi (72chars) format ---------------------*/
sql4obj: procedure expose m.
parse arg m, tb
call out 'insert into' tb '--' className(objClass(m))
line = ''
ff = oFldD(m)
pr = ' ('
do fx=1 to m.ff.0
call sql4ObjOut substr(m.ff.fx, 2)
end
call sql4ObjOut , 1
call out ' ) values '
pr = ' ('
do fx=1 to m.ff.0
f1 = m || m.ff.fx
v = m.f1 /* no strip T, gives errors in RCM profile | */
if dataType(v, n) then
call sql4ObjOut v
else do qx=1 until v == ''
vx = verify(v, m.ut_alfPrint)
if vx = 0 then do
l1 = min(60, length(v))
w = quote(left(v, l1), "'")
end
else if vx > 29 then do
l1 = min(60, vx-1)
w = quote(left(v, l1), "'")
end
else do
l1 = min(29, length(v))
w = 'x'quote(c2x(left(v, l1)), "'")
end
if qx == 1 then
call sql4ObjOut w
else do
if qx = 2 then
call sql4ObjOut , 1
call out ' ||' w
end
v = substr(v, l1+1)
end
end
call sql4ObjOut , 1
call out ' ) ; '
return
endProcedure
sql4objOut:
parse arg t1, force
if (force == 1 & line \== '') | length(line t1) > 65 then do
call out pr substr(line, 3)
pr = ' ,'
line = ''
end
if force \== 1 then
line = line',' t1
return
endProcedure sql4objOut
/*--- -dis db interface ---------------------------------------------*/
/*--- do one -dis db... and insert it into stem --------------------*/
sqlDisDb: procedure expose m.
parse upper arg o, cc
do cx=1
mid = strip(left(m.cc.cx, 10))
if words(mid) > 1 then
call err 'bad msgId' mid 'line:' m.cc.cx
if mid == '' | wordPos(mid, 'DSNT360I DSNT361I DSNT365I') ,
> 0 then
iterate
if mid == 'DSN9022I' then
if cx = m.cc.0 then
return m.o.0
else
call err 'not at end' cx':' m.cc.cx
if mid \== 'DSNT362I' then
call err 'DSNT362I expected not line:' m.cc.cx
dx = pos('DATABASE =', m.cc.cx)
sx = pos('STATUS =' , m.cc.cx)
if dx < 1 | sx <= dx then
call err 'bad DSNT362I line' cx':' m.cc.cx
db = word(substr(m.cc.cx, dx+10), 1)
sta = strip(substr(m.cc.cx, sx+8))
call sqlDisDbAdd o, db, ,0, 0, 'DB', sta
do cx=cx+1 while abbrev(m.cc.cx, ' ')
end
if abbrev(m.cc.cx, 'DSNT397I ') then do
cx = cx + 1
if \ abbrev(space(m.cc.cx, 1),
, 'NAME TYPE PART STATUS ') then
call err 'NAME TYPE PART STATUS mismatch' cx m.cc.cx
txNa = pos('NAME', m.cc.cx)
txTy = pos('TYPE', m.cc.cx)
txPa = pos('PART', m.cc.cx)
txSt = pos('STAT', m.cc.cx)
txEn = verify(m.cc.cx, ' ', 'n', txSt+6)
if 0 then say 'title' txNa txTy txPa txSt txEn cx m.cc.cx
cx=cx+1
do forever
do while abbrev(m.cc.cx, '----')
cx = cx + 1
end
if abbrev(m.cc.cx, '*') then
leave
parse var m.cc.cx sp =(txTy) ty . =(txPa) paFr . ,
=(txSt) sta =(txEn)
sp = strip(sp)
if words(sp) \= 1 | wordPos(ty, 'TS IX') < 0 then
call err 'bad name or type' cx':'m.cc.cx
if paFr == '' | paFr == 'L*' then
paFr = 0
else if abbrev(paFr, 'D') | abbrev(paFr, 'L') then
paFr = substr(paFr, 2)
if \ datatype(paFr, 'n') then
call err 'part not numeric' cx':'m.cc.cx
paTo = paFr
cw = cx
cx = cx + 1
if abbrev(m.cc.cx, ' -THRU ') then do
parse var m.cc.cx =(txPa) paTo . =(txSt)
if \ datatype(paTo, 'n') then
call err '-thru part not numeric' cx':'m.cc.cx
cx = cx + 1
end
call sqlDisDbAdd o, db, sp, paFr, paTo, ty, sta
end
end
if m.cc.cx = '******** NO SPACES FOUND' then
cx = cx + 1
if abbrev(m.cc.cx, '******* DISPLAY OF DATABASE ') ,
& word(m.cc.cx,5) == db then
if word(m.cc.cx,6) == 'ENDED' then
iterate
else if word(m.cc.cx,6) == 'TERMINATED' then
call err 'db display overflow' cx':' m.cc.cx
call err 'database' db 'ENDED mismatch' cx':' m.cc.cx
end
endProcedure sqlDbDis
/*--- insert one tuple into tDbState --------------------------------*/
sqlDisDbAdd: procedure expose m.
if arg(7) == '' | arg(7) == 'RW' then
return
parse arg o
m.o.0 = m.o.0 + 1
q = o'.'m.o.0
parse arg , m.q.db, m.q.sp, m.q.paFr, m.q.paTo, m.q.ty, m.q.sta
/*say added q m.q.db'.'m.q.sp':'m.q.paFr'-'m.q.paTo m.q.ty':'m.q.sta*/
ky = m.q.db'.'m.q.sp
if symbol('m.o.ky') \== 'VAR' then
m.o.ky = m.o.0
return
endProceedure sqlDisDbAdd
/*--- get index in o for db sp part ---------------------------------*/
sqlDisDbIndex: procedure expose m.
parse arg st, d, s, pa
if symbol('m.st.d.s') \== 'VAR' then
return 0
ix = m.st.d.s
if ix > m.st.0 | d \== m.st.ix.db | s \== m.st.ix.sp then
return 0
if pa == '' then
return ix
do ix=ix to m.st.0 while d == m.st.ix.db & s == m.st.ix.sp
if pa < m.st.ix.paFr then
return 0
else if pa <= m.st.ix.paTo then
return ix
end
return 0
endProcedure sqlDisDbIndex
/*--- dsn Command, return true if continuation needed ---------------*/
sqlDsnCont: procedure expose m.
parse arg cc, ssid, cmd
say '???dsnCont' cmd
cont = sqlDsn(cc, ssid, cmd, 12) <> 0
if cont then do
cz = m.cc.0
cy = cz - 1
if \ abbrev(m.cc.cy, DSNT311I) ,
| \ abbrev(m.cc.cz, 'DSN9023I') then
call err 'sqlDsn rc=12 for' cmd 'out='cz ,
'\n'cy'='m.cc.cy'\n'cz'='m.cc.cz
m.cc.0 = cz-2
end
return cont
endProcedure sqlDsnCont
/* copy sqlDiv end *************************************************/
/* copy db2Cat begin *************************************************/
catTbLastCol: procedure expose m.
parse upper arg cr, tb
return sql2one( ,
"select strip(char(colcount)) || ' ' || strip(c.name) one" ,
"from sysibm.sysTables t left join sysibm.sysColumns c" ,
"on c.tbCreator = t.creator and c.tbName = t.name" ,
"and c.colNo = t.colCount" ,
"where t.creator = '"cr"' and t.name = '"tb"'",,,, 'r')
endProcedure catTbLastCol
catTbCols: procedure expose m.
parse upper arg cr, tb
if sql2St("select strip(name) name " ,
"from sysibm.sysColumns " ,
"where tbcreator = '"cr"' and tbname='"tb"'",
"order by colNo", ggSt) < 1 then
return ''
res = m.ggst.1.name
do cx=2 to m.ggst.0
res = res m.ggst.cx.name
end
return res
endProcedure catTbCols
catTbColsTrunc: procedure expose m.
parse upper arg cr, tb, maxL
if sql2St("select strip(name) name, colType, length, length2" ,
"from sysibm.sysColumns " ,
"where tbcreator = '"cr"' and tbname='"tb"'",
"order by colNo", ggSt) < 1 then
return ''
res = ''
do cx=1 to m.ggst.0
ty = m.ggSt.cx.colType
if pos('LOB', ty) > 0 then
res = res', substr('m.ggSt.cx.name', 1,' ,
min(maxL, m.ggSt.cx.length2)') 'm.ggSt.cx.name
else if pos('CHAR', ty) > 0 & m.ggSt.cx.length > maxL then
res = res', substr('m.ggSt.cx.name', 1,' maxL')',
m.ggSt.cx.name
else
res = res',' m.ggSt.cx.name
end
return substr(res, 3)
endProcedure catTbColsTrunc
catIxKeys: procedure expose m.
parse upper arg cr, ix
sql = "select colSeq sq, colName col, ordering ord" ,
"from sysibm.sysKeys" ,
"where ixCreator = '"cr"' and ixName = '"ix"'" ,
"order by colSeq"
call sqlQuery 1, sql
res = ''
drop d
do kx=1 while sqlFetch(1, d)
if m.d.sq \= kx then
call err 'expected' kx 'but got colSeq' m.d.sq ,
'in index' cr'.'ix'.'m.d.col
res = res || strip(m.d.col) || translate(m.d.ord, '<>?', 'ADR')
end
call sqlClose 1
return res
endProcedure catIxKeys
catColCom: procedure expose m.
parse upper arg fCr, fTb, tCr, tTb
sql = "select t.name, t.colType, t.nulls, t.""DEFAULT""" ,
", coalesce(f.nulls, 'new')" ,
"from sysibm.sysColumns t" ,
"left join sysibm.sysColumns f" ,
"on f.tbCreator = '"fCr"' and f.tbName = '"fTb"'" ,
"and f.name = t.name" ,
"where t.tbCreator = '"tCr"' and t.tbName = '"tTb"'" ,
"order by t.colNo"
call sqlQuery 1, sql, 'na ty nu de nn'
pr = ' '
do kx=1 while sqlFetch(1)
/* say kx m..na m..ty m..nu m..de 'nn' m..nn */
if pos('CHAR', m..ty) > 0 then
dv = "''"
else if pos('INT' ,m..ty) > 0 ,
| wordPos(m..ty, 'REAL FLOAT') > 0 then
dv = 0
else if m..ty == 'TIMESTMP' then
dv = '0001-01-01-00.00.00'
else if pos('LOB', m..ty) > 0 then
dv = m..ty"('')"
else
dv = '???'
if m..nu = 'Y' then
dv = 'case when 1=0 then' dv 'else null end'
r = '???'
if m..ty = 'ROWID' then do
r = '--'
end
else if m..nn == 'new' then do
if m..de = 'Y' then
r = '--'
else if m..nu == 'N' then
r = dv
else
r = 'case when 1=0 then' dv 'else null end'
end
else do
if m..nu = 'Y' | (m..nu = m..nn) then
r = ''
else
r = 'coalesce('m..na',' dv')'
end
if abbrev(r, '--') then do
r = ' ' r
end
else do
r = pr r
pr = ','
end
if pos('???', r) > 0 then
call err 'no default for type' m..ty 'in' tCr'.'tTb'.'m..na
call out r m..na
end
call sqlClose 1
return
endProcedure catColCom
/* copy db2Cat end *************************************************/
/* copy sqlWsh begin **************************************************
remote SQL using csmExWsh ************************************/
sqlConClass_w: procedure expose m.
if m.sqlWsh_ini == 1 then
return m.class_SqlWshConn
m.sqlWsh_ini = 1
call sqlConClass_S
call csmIni
call classNew 'n SqlWshRdr u CsmExWsh', 'm',
, "jReset call jReset0 m; m.m.rdr = jBuf()" ,
"; m.m.rzDb=arg; m.m.sql = arg2;m.m.type= arg(3)" ,
, "jOpen call sqlWshRdrOpen m, opt"
return classNew('n SqlWshConn u', 'm',
, "sqlRdr return oNew(m.class_sqlWshRdr, m.sql_conRzDb" ,
", src, type)" ,
, "sqlsOut return sqlWshOut(rdr,m.sql_conRzDB,retOk,m.ft.opt)")
endProcedure sqlConClass_w
/*--- send an sql to csm and handle sqlCode -------------------------*/
sqlWshRdrOpen: procedure expose m.
parse arg m, oOpt
r = m.m.rdr
m.r.buf.0 = 1
m.r.buf.1 = m.m.sql
parse var m.m.RzDb m.m.rz '/' dbSys
m.m.wOpt = 'e sqlRdr' dbSys
call csmExWshOpen m, oOpt
d = m.m.deleg
em = ''
do while jRead(d)
if objClass(m.d) \== m.class_S then do
m.d.readIx = m.d.readIx - 1
leave
end
em = em'\n'm.d
end
if em == '' then
return m
call jClose m.m.deleg
return err('sqlWshRdr got' substr(em, 3))
endProcedure sqlWshRdrOpen
/*--- send an sql to csm and handle sqlCode -------------------------*/
sqlWshOut: procedure expose m.
parse arg rdr, rzDb, retOk, oo
parse value dsnCsmSys(rzDb) with rz '/' dbSys
if pos('o', oo) > 0 then
spec = 'e sqlsOut'
else
spec = 'v' || (m.wsh.outLen+4) 'sqlsOut'
call csmExWsh rz, rdr, spec dbSys oo retOk
return 1
endProcedure sqlWshOut
/* copy sqlWsh end *************************************************/
/* copy sqlS begin **************************************************
sqlStmts **********************************************/
sqlConClass_S: procedure expose m.
if m.sqlS_ini == 1 then
return m.class_SqlConnS
m.sqlS_ini = 1
call sqlConClass_R
call scanWinIni
return classNew('n SqlConnS u SqlConn', 'm',
, "sqlsOut return sqlsOutSql(rdr, retOk, ft)")
endProcedure sqlConClass_S
/*** execute sql's in a stream (separated by ;) and output as tab */
sqlStmts: procedure expose m.
parse arg sqlSrc, retOk, wOpt, sOpt, fOpt
return sqlsOut(scanSqlStmtRdr(sqlSrc, wOpt, sOpt), retOk, fOpt)
endProcedure sqlStmts
/*--- output sql as table -------------------------------------------*/
sql2tab: procedure expose m.
parse arg src, retOk, ft
cx = m.sql_defCurs
if ft == '' then
ft = sqlFTabOpts(fTabReset('SQL.'cx'.2Tab', 'c 1','1 c' , '-'))
else if objClass(ft) == m.class_s then
ft = sqlFTabOpts(fTabReset('SQL.'cx'.2Tab', 'c 1','1 c','-'ft))
call sqlQuery cx, in2str(src, ' '), retOk
call sqlFTab ft, cx
return
endProcedure sql2tab
/*--- result of each sql read from rdr to out
oo='a' autoTab, 't'=sqlTab, 'o'=object, 'c'=csv ----------*/
sqlsOut: procedure expose m.
parse arg rdr, retOk, ft
if ft = '' then
ft = sqlFTabOpts(fTabReset(sql_outFTab, 'c 1', , 'a'))
else if objClass(ft) == m.class_s then
ft = sqlFTabOpts(fTabReset(sql_outFTab, 'c 1', , ft))
interpret classMet(m.sql_ConCla, 'sqlsOut')
sqlsOutSql: procedure expose m.
parse arg rdr, retOk, ft
m.sql_errRet = 0
cx = m.sql_defCurs
r = jOpen(in2file(rdr), '<')
do while jRead(r)
sqlC = sqlExecute(cx, m.r, retOk)
if m.sql_errRet then
leave
if m.sql.cx.resultSet == '' | m.sql.cx.fun == 'CALL' then
if m.ft.verbose then
call outNl(m.sql_HaHi ,
|| sqlMsgLine(sqlC, m.sql.cx.updateCount, m.r))
if m.sql.cx.resultSet == '' then
iterate
do until \ sqlNextResultSet(cx) | m.sql_errRet
call sqlFTab fTabResetCols(ft), cx
if m.ft.verbose then
call out sqlMsgLine(m.sql.cx.fetchCount ,
'rows fetched', , m.r)
end
end
call jClose r
if m.sql_errRet then do
call sqlClose cx, '*'
say 'sqlsOut terminating because of sql error'
end
return \ m.sql_errRet
endProcedure sqlsOutSql
/*--- sql hook ------------------------------------------------------
hook paramter db | windowSpec | db? , windowSpec? , fTabOpt?
db: dbSys, rz/dbSysAbkürzung, 1 oder 2 chars
windowSpec: 0 = variable len, 123 = window123
default spufi = window72 ---------------------*/
wshHook_S: procedure expose m.
parse arg m, spec
parse var spec ki 2 rest
call errSetSayOut 'so'
if ki == '/' then do
inp = m.m.in
end
else do
call compIni
if pos(ki, m.comp_chKind) <= 0 then do
ki = '='
rest = spec
end
inp = wshCompile(m, ki)
end
if pos('@',rest)>0 then call err 'was ist das??????' spec
if words(rest)==1 & (datatype(rest, 'n') | pos('@',rest)>0) then
rest = ','rest
parse var rest dbSy ',' wOpt ',' fOpt
d2 = ii2rzDb(dbSy, 1)
call sqlConnect d2
m.m.info = 'runSQL'
if \ sqlStmts(inp, 'rb ret', strip(wOpt), , strip(fOpt)) then do
m.m.end = 1
m.m.exitCC = 8
end
call sqlDisConnect
return ''
endProcedure wshHook_s
/*--- wshHook for sqlRdr read from dd wsh --------------------------*/
wshHook_sqlRdr: procedure expose m.
parse arg m, dbSys
call errSetSayOut 'so'
call sqlIni
m.sql_retOk = m.sql_retOk 'rb ret'
m.sql_errRet = 0
call sqlConnect dbSys
if \ m.sql_errRet then
r = sqlRdr(m.m.in)
if \ m.sql_errRet then
call jOpen r, '<'
if \ m.sql_errRet then do
call pipeWriteAll r
call jClose r
end
if m.sql_errRet then do
call out 'from' sysvar(sysnode) mvsVar(sysName) m.sql_ConRzdb
m.m.end = 1
m.m.exitCC = 4
end
/* else
call out sqlMsgLine(m.r.bufI0 'rows fetched', , m.r.srcTxt) */
call sqlDisConnect
return ''
endProcedure wshHook_sqlRdr
/*--- wshHook for sqlsOut read from dd wsh --------------------------*/
wshHook_sqlsOut: procedure expose m.
parse arg m, dbSys oo retOk
call errSetSayOut 'so'
call sqlIni
m.sql_retOk = m.sql_retOk 'rb ret'
m.sql_errRet = 0
call sqlConnect dbSys
if oo == 'a' | oo == 't' then do
myOut = m.j.out
m.myOut.truncOk = 1
end
if \ m.sql_errRet then
call sqlsOut m.m.in, retOk, oo
if m.sql_errRet then do
call out 'from' sysvar(sysnode) mvsVar(sysName) m.sql_ConRzdb
m.m.end = 1
m.m.exitCC = 4
end
call sqlDisConnect
return ''
endProcedure wshHook_sqlsOut
/* copy sqlS end *************************************************/
/* copy sqlCsm begin *************************************************/
sqlConClass_C: procedure expose m.
if m.sqlCsm_ini == 1 then
return m.class_sqlCsmConn
m.sqlCsm_ini = 1
call sqlConClass_R
call csmIni
call classNew 'n SqlCsmRdr u JRW', 'm',
, "jReset m.m.rzDb=arg; m.m.src=arg2; m.m.type=arg(4)" ,
, "jOpen call sqlCsmRdrOpen m, opt",
, "jClose" ,
, "jRead return 0"
return classNew('n SqlCsmConn u', 'm',
, "sqlRdr return oNew(m.class_SqlCsmRdr" ,
", m.sql_conRzDB, src, type)" ,
, "stmts return err('no stmts in sqlCsm')")
endProcedure sqlConClass_C
/*--- send an sql to csm and handle sqlCode -------------------------*/
sqlCsmExe:
parse arg ggRzDb, sql_query, ggRetOk
parse value dsnCsmSys(ggRzDb) with sql_host '/' sql_db2SSID
sql_query = strip(sql_query) /* csmASqls fails on leading spaces */
address tso "CSMAPPC START PGM(CSMASQL)"
if \ (rc = 0 | rc = 4) then
return err('csmappc rc' rc)
if sqlCode = 0 then
return 0
ggSqlStmt = sql_query /* for sqlMsg etc. */
if pos('*', ggRetOk) > 0 | wordPos(sqlCode, ggRetOk) > 0 ,
then do
if sqlCode < 0 & pos('say', ggRetOk) > 0 then
call errSay ' }'sqlmsg(sqlCA2Rx(sqlCa))'\nsqlCsmExe' ggRzDb
return sqlCode
end
else if sqlCode < 0 then
call err sqlmsg(sqlCA2rx(sqlCa))'\nsqlCsmExe' ggRzDb
else if pos('w', ggRetOk) < 1 then
if sqlCode = 100 then
call errSay ' }sqlCode +100 row not found\nsql =' ggSqlStmt
else
call errSay 'w}'sqlMsg(sqlCA2rx(sqlCa))'\nsqlCsmExe' ggRzDb
return sqlCode
endProcedure sqlCsmExe
/*--- execute a query from sql, with one resultset ------------------*/
sqlCsmRdrOpen: procedure expose m.
parse arg m, opt
src = sqlRdrOpenSrc(m, opt)
res = sqlCsmExe(m.m.rzDb, src, 100 retOk)
if res < 0 then
return res
if words(m.m.type) = 1 & \ abbrev(m.m.type, ' ') then
cl = class4name(m.m.type)
else if m.m.type <> '' then
cl = classNew('n* SqlCsm u f%v' m.m.type)
else do
vv = ''
do kx=1 to sqlD
vv = sqlNiceVarsApp(vv, SQLDA_REXXNAME.kx)
end
cl = classNew('n* SqlCsm u f%v' vv)
end
ff = classFldD(cl)
if sqlD <> m.ff.0 then
return err('sqlCsmQuery sqlD' sqlD '<>' m.ff.0 'for' ,
className(cl))
do rx=1 to sqlRow#
m.m.buf.rx = m'.BUFD.'rx
call oMutate m'.BUFD.'rx, cl
end
m.m.buf.0 = sqlRow#
do kx=1 to sqlD
rxNa = SQLDA_REXXNAME.kx
do rx=1 to sqlRow#
dst = m'.BUFD.'rx || m.ff.kx
if substr(sqlIndicator.rx, kx ,1) == 'ff'x then
m.dst = m.sqlNull
else
m.dst = value(rxNa'.'rx)
end
end
return 0
endProcedure sqlCsmRdrOpen
/* copy sqlCsm end *************************************************/
/* copy sqlO begin **************************************************
sql interface mit o und j Anbindung
**********************************************************************/
sqlConClass_R: procedure expose m.
if m.sqlO_ini == 1 then
return m.class_sqlConn
m.sqlO_ini = 1
call sqlIni
call jIni
/* call scanReadIni */
call classNew 'n SqlRdr u JRW', 'm',
, "jReset m.m.sql = arg; m.m.type = arg2;",
, "jOpen call sqlRdrOpen m, opt",
, "jClose call sqlRdrClose m",
, "jRead if \ sqlRdrRead(m, rStem) then return 0"
call classNew 'n SqlResRdr u JRW', 'm',
, "jReset m.m.cursor = arg; m.m.type = arg2;",
, "jOpen call sqlRdrO2 m" ,
, "jClose call sqlClose m.m.cursor" ,
, "jRead if \ sqlRdrRead(m, rStem) then return 0"
return classNew('n SqlConn u', 'm',
, "sqlRdr return oNew(m.class_SqlRdr, src, type)" ,
, "sqlsOut return err('no stmts/sqlsOut in conClass_R')")
endProcedure sqlConClass_R
/*--- return a new sqlRdr with sqlSrc from src
type is the class for result, if empty generated --------------*/
sqlRdr: procedure expose m.
parse arg srcRdr, type
src = in2str(srcRdr, ' ')
interpret classMet(m.sql_ConCla, 'sqlRdr')
endProcedure sqlRdr
/*--- execute sql query, generate type and fetchList ----------------*/
sqlRdrOpen: procedure expose m.
parse arg m, opt
src = m.m.sql
cx = sqlGetCursor()
m.m.cursor = cx
if words(m.m.type) <> 1 | abbrev(m.m.type, ' ') then do
m.sql.cx.fetchClass = ''
res = sqlQuery(cx, src, m.m.type)
m.m.type = sqlFetchClass(cx)
end
else do
m.m.type = class4name(m.m.type)
res = sqlQuery(cx, src, mCat(classFlds(m.m.type),' '))
m.sql.cx.fetchClass = m.m.type
end
if res >= 0 then
return sqlRdrO2(m)
call sqlFreeCursor cx
return res
endProcedure sqlRdrOpen
sqlRdrOpenSrc: procedure expose m.
parse arg m, opt
if opt\== m.j.cRead then
call err 'opt not' m.j.cRead 'sqlRdrOpenSrc('m',' opt')'
m.m.srcTxt = in2str(m.m.src, ' ')
return m.m.srcTxt
sqlRdrO2: procedure expose m.
parse arg m
cx = m.m.cursor
if m.m.type \== m.sql.cx.fetchClass | m.m.Type == '' then
call err 'type' m.m.type '\==' m.sql.cx.fetchClass 'fetchClass'
m.m.fetchCount = ''
return m
endProcedure sqlRdrO2
/*--- generate class for fetched objects, if necessary --------------*/
sqlFetchClass: procedure expose m.
parse arg cx, force
if m.sql.cx.fetchClass == '' | force == 1 then
m.sql.cx.fetchClass = classNew('n* Sql u f%v' ,
m.sql.cx.fetchFlds)
return m.sql.cx.fetchClass
endProcedure sqlFetchClass
/*--- read next from cursor, return as object -----------------------*/
sqlRdrRead: procedure expose m.
parse arg m, rStem
cx = m.m.cursor
if m.sql.cx.fetchcount \== m.m.bufI0 then
call err cx 'fetchCount='m.sql.cx.fetchcount ,
'<> m'.m'.bufI0='m.m.bufI0
do bx=1 to 10
v = oNew(m.m.type)
if \ sqlFetch(m.m.cursor, v) then do
call mFree v
leave
end
m.rStem.bx = v
end
m.rStem.0 = bx-1
return bx > 1
endProcedure sqlRdrRead
/*--- close sql Cursor ----------------------------------------------*/
sqlRdrClose: procedure expose m.
parse arg m
cx = m.m.cursor
call sqlClose cx
call sqlFreeCursor cx
m.m.cursor = ''
m.m.fetchCount = m.sql.cx.fetchCount
return m
endProcedure sqlRdrClose
sqlQuery2Rdr: procedure expose m.
parse arg cx
r = jReset(oMutate('SQL_RDR.'cx, m.class_SqlResRdr), cx)
m.r.type = sqlFetchClass(cx)
return r
endProcedure sqlQuery2Rdr
/*--- select and write all to stdOut --------------------------------*/
sqlSel: procedure expose m.
parse arg src, type
s = sqlRdr(src, type)
call pipeWriteAll s
return /* do not return fetchCount, writeAll may be delayed| */
endProcedure sqlSel
/* copy sqlO end *************************************************/
/* copy sql begin ****************************************************/
/*** sql.1: basic interface to dsnRexx *******************************/
/*--- initialize sql ------------------------------------------------*/
sqlIni: procedure expose m.
if m.sql_ini == 1 then
return
m.sql_ini = 1
call utIni
m.sqlNull = '---'
m.sqlInd = 'sqlInd'
m.sql_defCurs= 49
m.sqlCAMsg = 0
m.sqlSuMsg = 2
m.sql_dbSys = ''
m.sql_rzDb = ''
isInProd = wordPos(sysvar(sysNode), 'RZ2') > 0
m.sql_retOk = 'dne' copies('rod', \ isInProd)
m.sql_retOkDef = m.sql_RetOk
m.sql_cursors = left('', 100)
return 0
endProcedure sqlIni
sqlRetDef: procedure expose m.
m.sql_retOk = m.sql_retOkDef
return
/*--- execute sql thru the dsnRexx interface fail if sqlcode <> 0 ---*/
sqlExec0: procedure expose m.
parse arg ggSqlStmt, ePlus
if abbrev(ggSqlStmt, 'disCon') | abbrev(ggSqlStmt, 'connec') then
address dsnRexx ggSqlStmt
else
address dsnRexx 'execSql' ggSqlStmt
if rc == 0 & sqlCode == 0 & sqlWarn.0 == ' ' then
return 0
m.sql_errRet = 1
if \ dataType(sqlCode, 'n') | abs(rc) \== 1 then
ePlus = strip(ePlus 'dsnRexx rc='rc'\n')
if wordPos('ret', m.Sql_retOK) < 1 then
call err ePlus || sqlMsg()
else
call errSay ePlus || sqlMsg()
return sqlCode
endProcedure sqlExec0
/*--- connect to the db2 subsystem sys
cCla = connectionClass
e = rexx local only
r = rexx local only, rdr&objects
s = rexx local only, rdr&objects, stmts (default local)
c = with csmASql , rdr&objects
w = with sqlWsh , rdr&objects, stmts (default remote) ----*/
sqlConnect: procedure expose m.
parse arg sys, cCla
upper sys
if abbrev(sys, '*/') then
sys = substr(sys, 3)
if pos('/', sys) <= 0 then
cCla = firstNS(translate(cCla, 'rs', 'cw'), 's')
else if cCla = '' then
cCla = 'w'
if cCla == 'e' then
m.sql_conCla = 'sql E no connection class'
else
interpret 'm.sql_conCla = sqlConClass_'cCla'(sys, cCla)'
if pos(cCla, 'ers') == 0 then do
m.sql_conRzDB = sys
return
end
call sqlIni /* initialize dsnRexx */
address tso "SUBCOM DSNREXX"
if rc <> 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
if sys = '-' then
return 0
if sys == '' then
if sysvar(sysnode) == 'RZ4' then
sys = 'DP4G'
else if sysvar(sysnode) == 'RZX' then
sys = 'DX0G'
else
call err 'no default dbSys for' sysvar(sysnode)
m.sql_conRzDB = sys
m.sql_dbSys = sys
return sqlExec0('connect' sys)
endProcedure sqlConnect
/*--- diconnect from db2 --------------------------------------------*/
sqlDisconnect: procedure expose m.
parse arg retOk
m.sql_conCla = ''
m.sql_conRzDb = ''
if m.sql_dbSys == '' then
return 0
m.sql_dbSys = ''
m.sql_csmHost = ''
return sqlExec0('disConnect')
endProcedure sqlDisconnect
/*--- execute sql thru the dsnRexx interface
check for handled errors, recover from easy errors -------*/
sqlExec: /* no procedure, to keep variables sql... */
parse arg ggSqlStmt, ggSqlRet0
m.sql_HaHi = '' /* empty error Handler History */
do forever /* for retries */
address dsnRexx 'EXECSQL' ggSqlStmt
if rc == 0 & sqlCode == 0 & sqlWarn.0 == ' ' then
return 0
if \ dataType(sqlCode, 'n') | abs(rc) \== 1 then
return err('dsnRexx rc='rc sqlMsg())
ggSqlRet = ggSqlRet0 m.sql_retOk
if pos('*', ggSqlRet) >0 | wordPos(sqlCode,ggSqlRet) >0 then do
if sqlCode < 0 & pos('say', ggSqlRet) > 0 then
call outNl errMsg(' }'sqlMsg())
return sqlCode
end
if sqlCode >= 0 then do
if (sqlCode > 0 | sqlWarn.0 \== ' ') ,
& pos('w', ggSqlRet) < 1 then
call outNl errMsg(' }'sqlMsg())
return sqlCode
end
if translate(word(ggSqlStmt, 1)) == 'DROP' then do
if (sqlCode == -204 | sqlCode == -458) ,
& wordPos('dne', ggSqlRet) > 0 then
return sqlCode
if sqlCode = -672 & wordPos('rod', ggSqlRet) > 0 ,
& length(m.sql_hahi) < 1000 then do
m.sql_hahi = m.sql_HaHi || sqlMsgLine(sqlCode,
, 'tb='sqlErrMc ,ggSqlStmt)'\n'
m.sql_hahi = m.sql_HaHi || sqlExecHaHi('alter table' ,
SqlErrMc 'drop restrict on drop')'\n'
iterate
end
end
ggSqlEE = ''
if wordPos('rb', ggSqlRet) > 0 then
ggSqlEE = '\n'sqlExecHaHi('rollback')
if wordPos('ret', ggSqlRet) < 1 then do
call err m.sql_hahi || sqlMsg() || ggSqlEE
return sqlCode
end
m.sql_errRet = 1
call errSay errMsg(' }'m.sql_haHi || sqlMsg() || ggSqlEE)
return sqlCode
end
endProcedure sqlExec
/*--- execute sql fail showing haHi or return msgLine ---------------*/
sqlExecHaHi: procedure expose m.
parse arg ggSqlStmt
return sqlMsgLine(sqlExec0(ggSqlStmt, m.sql_hahi) ,
, , ggSqlStmt)
endProcedure sqlExechaHi
/*--- short message for executed sql including count ----------------*/
sqlMsgLine: procedure expose m. sqlErrD.
parse arg res, cnt, src, plus
verb = translate(word(src, 1))
if datatype(res, 'n') then
res = 'sqlCode' res
if cnt \== '' then do
res = res',' cnt
vx = wordPos(translate(word(src,1)), 'DELETE INSERT UPDATE')
if datatype(cnt, 'n') then
if vx > 0 then
res = res 'rows' word('deleted inserted updated', vx)
else if cnt <> 0 then
res = res 'rows updated'
end
if plus \== '' then
res = res',' plus
if abbrev(res, ', ') then
res = substr(res, 3)
if src \== '' then do
ll = 75 - length(res)
aa = strip(src)
if length(aa) > ll then
aa = space(aa, 1)
if length(aa) > ll then
aa = left(aa, ll-3)'...'
res = res':' aa
end
return res
endProcedure sqlMsgLine
/*--- send a command to db2 through the TSO dsn processor -----------*/
sqlDsn: procedure expose m.
parse arg st, sys, cmd, rcOk
x = outtrap('M.'st'.')
push 'END'
push cmd
address tso 'DSN SYSTEM('sys')'
rr = rc
x = outtrap(off)
if rr = 0 | rcOk = '*' | wordPos(rr, rcOk) > 0 then
return rr
fl = max(1, m.st.0 - 10)
em = 'rc' rr 'for DSN SYSTEM('sys') cmd' cmd,
'\nOuputlines' fl '-' m.st.0':'
do lx=fl to m.st.0
em = em '\n' strip(m.st.lx, 't')
end
call err em
endProcedure sqlDsn
/*** sql.2: error Handler and error Reporting ************************/
/*--- return an sql error message (multiline \n) --------------------*/
sqlMsg: /* no procedure, to keep variables sql... */
if \ dataType(sqlCode, 'n') then do
ggRes = 'sqlCode' sqlCode 'not numeric\n'sqlCaMsg()
end
else do
ggRes = sqlDsntiar(sqlRx2CA())
ggWa = sqlMsgWarn()
if ggWa \= '' then
ggRes = ggRes'\nwarnings' ggWa
if m.sqlCAMsg == 1 then
ggRes = ggRes'\n'sqlCaMsg()
end
ggSt = 'SQL_HOST'
ggVa = 'SQL_HOST.VAR'
ggBe = 'SQL_HOST.BEF'
call sqlHostVars ggSqlStmt, 12, ggSt
ggFrom = 'ggSqlStmt'
ggW1 = translate(word(ggSqlStmt, 1))
ggW2 = translate(word(ggSqlStmt, 2))
if ggW1 == 'PREPARE' then
ggFrom = sqlHostVarFind(ggSt, 'FROM')
else if ggW1 ggW2 == 'EXECUTE IMMEDIATE' then
ggFrom = sqlHostVarFind(ggSt, 1)
ggPos = 0
if datatype(sqlErrd.5, 'n') & sqlErrd.5 > 0 then do
ggPos = sqlErrd.5
ggRes = ggRes || sqlMsgSrcPos(value(ggFrom), sqlErrd.5)
end
if ggFrom == 'ggSqlStmt' then do
ggRes = ggRes'\nsql =' sqlShorten(ggSqlStmt, 2000, ggPos)
end
else do
ggRes = ggRes'\nsql =' sqlShorten(value(ggFrom), 2000, ggPos)
ggRes = ggRes'\nstmt =' sqlShorten(ggSqlStmt, 2000)
end
ggPref = '\nwith'
do ggXX=1 to m.ggSt.0
if ggFrom = m.ggVa.ggXX then
iterate
ggRes = ggRes || ggPref m.ggBe.ggXX ':'m.ggVa.ggXX ,
'=' sqlShorten(value(m.ggVa.ggXX), 210)
ggPref = '\n '
end
/* if m.sqlSuMsg == 1 | (m.sqlSuMsg == 2 & m.sql_csmhost \== '') then
ggRes = ggRes'\nsubsys =' m.sql_dbSys ,
|| ', host =' m.sql_csmhost
*/ return ggRes
endSubroutine sqlMsg
sqlShorten: procedure expose m.
parse arg txt, maxL, pos
if length(txt) <= maxL then
return txt
if \ datatype(pos, 'n') | pos < 1 then
pos = 1
ex = pos + min(60, maxL-7)
if ex <= maxL - 4 then
return left(txt, maxL-4) '...'
if ex >= length(txt) then
return left(txt, 67) '...\n'substr(txt, length(txt)-maxL+72)
else
return left(txt, 67) '...\n'substr(txt, ex-maxL+76, maxL-75) ,
'...'
endProcedure sqlShorten
/*--- use dsnTiar to translate sql Info to error text ---------------*/
sqlDsnTiar: procedure expose m.
parse arg ca
if -438 = sqlCa2Rx(ca) then
return '\nSQLCODE = -438:',
'APPLICATION RAISED ERROR WITH sqlState' sqlState ,
'and DIAGNOSTIC TEXT:' sqlErrMc
liLe = 78
msLe = liLe * 10
msg = d2c(msLe,2) || left('', msLe)
len = d2c(liLe, 4)
ADDRESS LINKPGM "DSNTIAR ca msg len"
if rc = 0 then nop
else if rc = 4 then say 'warn linkPgm dsnTiar rc' rc 'sqlCa' ca
else call err 'linkPgm dsnTiar rc' rc 'sqlCa' ca
res = strip(substr(msg, 13, liLe-10))
cx = pos(', ERROR: ', res)
if cx > 0 then
res = left(res, cx-1)':' strip(substr(res, cx+9))
do c=3+liLe by liLe to msLe while substr(msg, c, 10) = ''
res = res'\n 'strip(substr(msg, c+10, liLe-10))
end
return res
endProcedure sqlDsnTiar
/*--- format all rexx sqlCa fields into a message -------------------*/
sqlCaMsg:
return 'sqlCode' sqlCode 'sqlState='sqlState ,
'\n errMC='translate(sqlErrMc, ',', 'ff'x) ,
'\n warnings='sqlWarnCat('+') 'erP='sqlErrP ,
'\n errD.1='sqlErrD.1 '2='sqlErrD.2 '3='sqlErrD.3 ,
'\n errD.4='sqlErrD.4 '5='sqlErrD.5 '6='sqlErrD.6
endProcedure sqlCaMsg
/*--- concat the sql warnings with Separator sep --------------------*/
sqlWarnCat: procedure expose m. sqlWarn.
parse arg sep
return sqlWarn.0 || sep,
|| sqlWarn.1||sqlWarn.2||sqlWarn.3||sqlWarn.4||sqlWarn.5||sep ,
|| sqlWarn.6||sqlWarn.7||sqlWarn.8||sqlWarn.9||sqlWarn.10||sep
endProcedure sqlWarnCat
/*--- format the sqlCA into the dsnTiar SQLCA -----------------------*/
sqlRx2Ca: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
if \ (datatype(sqlcode, 'n') & datatype(sqlErrD.1, 'n') ,
& datatype(sqlErrD.3, 'n')) then
return err('sqlCode etc. not numeric\nsqlCa =' sqlCaMsg())
if digits() < 10 then
numeric digits 10
sqlCa = 'SQLCA ' || d2c(136, 4) || d2c(sqlCode, 4) ,
|| d2c(min(70, length(sqlErrMc)), 2)left(sqlErrMc, 70) ,
|| left(sqlErrP, 8) ,
|| d2c(sqlErrD.1, 4)d2c(sqlErrD.2, 4)d2c(sqlErrD.3, 4) ,
|| d2c(sqlErrD.4, 4)d2c(sqlErrD.5, 4)d2c(sqlErrD.6, 4) ,
|| sqlWarnCat() || sqlState
if length(sqlCa) <> 136 then
call err 'sqlCa length' length(sqlCa) 'not 136' ,
'\n'sqlCaMsg() '==>' ca', hex='c2x(ca)
return sqlCa
endProcedure sqlRx2Ca
/*--- extract the fields from the SqlCA and put it to rexx vars -----*/
sqlCA2Rx: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
parse arg ca
numeric digits 10
if length(ca) < 136 | c2d(substr(ca, 9, 4), 4) <> 136 then
call err 'bad sqlCa len' length(ca) 'not 136:' ca', hex='c2x(ca)
sqlCode = c2d(substr(ca, 13 ,4), 4)
sqlErrMC = substr(ca, 19, c2d(substr(ca, 17, 2), 2))
sqlErrP = substr(ca, 89, 8)
do ix=1 to 6
sqlErrD.ix = c2d(substr(ca, 93 + 4 * ix, 4), 4)
end
do ix=0 to 10
sqlWarn.ix = substr(ca, 121 + ix, 1)
end
sqlState = substr(ca, 132, 5)
return sqlCode
endProcedure sqlCA2Rx
/*--- make the text for sqlWarnings ---------------------------------*/
sqlMsgWarn: procedure expose m. sqlWarn.
r = ''
text =' 1=W var truncated, 1=S scrollable, 1=N nonScrollable,' ,
'2=W nulls in aggregate,' ,
'3=W more cols than vars,' ,
'3=Z more result sets than locators,' ,
'4=W no where, 4=D sensitive dynamic, 4=I insensitive,' ,
'4=S sensitive static,' ,
'5=W not valid sql, 5=1 readOnly, 5=2 readDelete,' ,
'5=3 readDeleteUpdate,' ,
'6=W day changed to month range,' ,
'7=W dec digits truncated,' ,
'8=W char substituted,' ,
'9=W arith excep in count, 9=Z multipe result sets,' ,
'10=W char conversion err in ca,'
do wx = 1 to 10
w = sqlWarn.wx
if w = ' ' then
iterate
t = wx'='w
cx = pos(' 'wx'='w' ', text)
ex = pos(',' , text, cx + 1)
if cx > 0 & ex > cx then
r = r substr(text, cx+1, ex-cx)
else
r = r wx'='w '?,'
end
r = strip(r, 't', ',')
if r = '' & sqlwarn.0 <> '' then
call err 'sqlWarn.0='sqlWarn.0 'but all warns empty'
return r
endProcedure sqlMsgWarn
/*--- show in the source src the point pos (where error occured)
a few lines from src around pos and arrow to pos ----------*/
sqlMsgSrcPos: procedure expose m.
parse arg src, pos
liLe = 68
liCn = 3
afLe = 25
t1 = space(left(src, pos), 1)
t2 = left(' ', substr(src, pos, 1) == ' ' ,
| substr(src, pos+1, 1) == ' ') ,
|| space(substr(src, pos+1), 1)
afLe = min(afLe, length(t2))
if length(t1) + afLe > liLe * liCn then
t1 = '...'right(t1, liLe * liCn - afLe -3)
else if length(t1)+length(t2) > liLe then
t1 = left(' ', (liCn * liLe - length(t1) -afLe) // liLe)||t1
pL = length(t1) // liLe
if length(t2) <= liLe-pL then
tx = t1 || t2
else
tx = t1 || left(t2, liLe-pL-3)'...'
res = '\nsrc' strip(substr(tx, 1, liLe), 't')
do cx=1+liLe by liLe to length(tx)
res = res || '\n +' strip(substr(tx, cx, liLe), 't')
end
loc = 'pos' pos 'of' length(src)
if length(loc)+6 < pL then
return res'\n >' right('>>>'loc'>>>', pL)
else
return res'\n >' left('', pL-1)'<<<'loc'<<<'
endProcdedure sqlMsgSrcPos
/*--- get the hostVars in the sql in src and the word before --------*/
sqlHostVars: procedure expose m.
parse arg src, cnt, st
cx = 1
sx = 1
do cnt
cx = pos(':', src, cx) + 1
if cx < 2 then
leave
if pos(substr(src, cx, 1), m.ut_rxN1) > 0 then
iterate
ex = verify(src, m.ut_rxDot, 'n', cx)
if ex < 1 then
m.st.var.sx = substr(src, cx)
else
m.st.var.sx = substr(src, cx, ex - cx)
if m.st.var.sx == '' | length(m.st.var.sx) > 100 then
iterate
/* search word before */
do bE = cx-2 by -1 to 1 ,
while substr(src, bE, 1) == ' '
end
do bB = bE by -1 to max(1, bE-20),
while pos(substr(src, bB, 1), m.ut_alfa) > 0
end
if bB < bE & bB >= 0 then
m.st.bef.sx = substr(src, bB+1, bE-bB)
else
m.st.bef.sx = ''
sx = sx + 1
end
m.st.0 = sx-1
return sx
endProcedure sqlHostVars
/*--- find the name of hostvar, by index or by before ---------------*/
sqlHostVarFind: procedure expose m.
parse arg st, fnd
if datatype(fnd, 'n') & fnd <= m.st.0 then
return m.st.var.fnd
do ix=1 to m.st.0
if translate(m.st.bef.ix) = fnd then
return m.st.var.ix
end
return ''
endSubroutine sqlHostVarFind
/*** sql.3: query/update/call interface ******************************/
/*--- reset sql cursor 'c'cx fields ---------------------------------*/
sqlReset: procedure expose m.
parse arg cx
m.sql.cx.updateCount = ''
m.sql.cx.fetchCount = 0
m.sql.cx.resultSet = ''
m.sql.cx.resultSet.0 = 0
m.sql.cx.i.sqlD = 'noDescInp'
m.sql.cx.var.0 = 0
return sqlResetCrs(cx)
endProcedue sqlReset
sqlResetCrs: procedure expose m.
parse arg cx
m.sql.cx.d.sqlD = 'noSqlDA'
m.sql.cx.fetchVars = ''
m.sql.cx.fetchFlds = ''
m.sql.cx.fetchClass = ''
m.sql.cx.type = ''
return 0
endProcedue sqlResetCrs
/*--- execute a query from sql, with one resultset ------------------*/
sqlQuery: procedure expose m.
parse arg cx, src, feVa, retOk
res = sqlPreDec(cx, src, feVa, retOk)
if res < 0 then
return res
res = sqlExec('open c'cx, retOk)
if res < 0 then
return res
m.sql.cx.updateCount = sqlErrd.3
m.sql.cx.resultSet = cx
return res
endProcedure sqlQuery
/*--- prepare statement and declare cursor --------------------------*/
sqlPreDec: procedure expose m.
parse arg cx, src, feVa, retOk
call sqlReset cx
s1 = ''
if pos(left(feVa, 1), '?:') < 1 then
s1 = 'into :M.SQL.'cx'.D'
res = sqlExec('prepare s'cx s1 'from :src', retOk)
if res < 0 then
return res
call sqlFetchVars cx, feVa
return sqlExec0('declare c'cx 'cursor for s'cx)
endProcedure sqlPreDec
/*--- prepare a query from sql, with one resultset ------------------*/
sqlQueryPrepare: procedure expose m.
parse arg cx, src, feVa, retOk
res = sqlPreDec(cx, src, feVa, retOk)
if res < 0 then
return res
return sqlExec0('describe input s'cx 'into :M.SQL.'cx'.I')
endProcedure sqlQueryPrepare
/*--- open a prepared query -----------------------------------------*/
sqlQueryExecute: procedure expose m.
parse arg cx retOk
do ix=1 to arg()-1
call sqlDASet cx , 'I', ix, arg(ix+1)
end
res = sqlExec('open c'cx 'using descriptor :M.SQL.'cx'.I', retOk)
if res < 0 then
return res
m.sql.cx.updateCount = sqlErrd.3
m.sql.cx.resultSet = cx
return res
endProcedure sqlQueryExecute
/*--- fetch next row to m.dst.* at end return false -----------------*/
sqlFetch: procedure expose m.
parse arg cx, dst, retOk
fetCode = sqlExec('fetch c'm.sql.cx.resultSet ,
'into' m.sql.cx.fetchVars, 100 retOk)
if fetCode == 100 then
return 0
if fetCode < 0 then
return fetCode
m.sql.cx.fetchCount = m.sql.cx.fetchCount + 1
interpret m.sql.cx.fetchCode
return 1
endProcedure sqlFetch
/*--- close cursor 'c'cx --------------------------------------------*/
sqlClose: procedure expose m.
parse arg cx, retOk
return sqlExec('close c'm.sql.cx.resultSet, retOk)
endProcedure sqlRxClose
/*-- execute an sql with no resultset, but possibly outParms --------*/
sqlUpdate: procedure expose m.
parse arg cx, src, retOk
m.sql.cx.updateCount = ''
m.sql.cx.resultSet = ''
bx = verify(src, '( ')
if bx > 0 then
fun = translate(word(substr(src, bx), 1))
if fun = 'SET' then do
w2 = translate(word(substr(src, bx), 2))
if \ abbrev(w2, ':') then
return sqlExec('execute immediate :src', retOk)
ex = pos('=', w2)
if ex = 0 then
ex = length(w2)+1
vn = strip(substr(w2, 2, ex-2))
if vn = '' then
call err 'bad hostVar in' src
m.sql.cx.Var.0 = 1
m.sql.cx.VarName.1 = vn
abc = 'und so weiter'
trace ?r
src2 = 'set :M.sql.'cx'.var.1' substr(w, ex) subword(src, 3)
src2 = 'set :abc' substr(w, ex) subword(src, 3)
return sqlExec('execute immediate :src2', retOk)
end
if fun == 'DECLARE' then do
if 'GLOBAL' == translate(word(substr(src, bx), 2)) then
return sqlExec('execute immediate :src', retOk)
end
res = sqlExec(src, retOk)
if wordPos(fun, 'DELETE INSERT UPDATE') > 0 then
m.sql.cx.updateCount = sqlErrd.3
return res
endProcedure sqlUpdate
/*-- prepare an update ----------------------------------------------*/
sqlUpdatePrepare: procedure expose m.
parse arg cx, src, retOk
res = sqlExec('prepare s'cx 'from :src', retOk)
return sqlExec('describe input s'cx 'into :M.SQL.'cx'.I')
endProcedure sqlUpdatePrepare
/*-- execute a prepared update with the given arguments -------------*/
sqlUpdateExecute: procedure expose m.
parse arg cx retOk
do ix=1 to arg()-1
call sqlDASet cx , 'I', ix, arg(ix+1)
end
res = sqlExec('execute s'cx 'using descriptor :M.SQL.'cx'.I',
, retOk)
m.sql.cx.updateCount = sqlErrd.3
return res
endProcedure sqlUpdateExecute
/*--- sql call statement --------------------------------------------*/
sqlCall: procedure expose m.
parse arg cx, src, retOk
call sqlReset cx
s = scanSrc(sql_call, src)
if \ scanUntil(s, ' ') | translate(m.s.tok) <> 'CALL' then
call scanErr s, 'no call'
if \ scanUntil(s, '(') then
call scanErr s, 'not ( after call'
prc = strip(m.s.tok)
s2 = ''
call scanLit s, '('
do ax=1
call scanSpaceOnly s
if scanString(s, "'") then do
m.sql.cx.var.ax = m.s.tok
call scanSpaceOnly s
end
else if scanUntil(s, ',)') then
m.sql.cx.var.ax = strip(m.s.tok)
else
call scanErr s, 'value expected in call list'
s2 = s2', :m.sql.'cx'.var.'ax
if scanLit(s, ')') then
leave
if \ scanLit(s, ',') then
call scanErr s, 'missing ,) in call list'
end
m.sql.cx.var.0 = ax
call scanSpaceOnly s
if \ scanEnd(s) then
call scanErr s, 'call does not end after )'
say cx 'a1='m.sql.cx.var.1 'a2='m.sql.cx.var.2 'a3='m.sql.cx.var.3
res = sqlExec('call' prc'('substr(s2, 3)')', 466 retOk)
say cx 'a1='m.sql.cx.var.1 'a2='m.sql.cx.var.2 'a3='m.sql.cx.var.3
if res \== 466 then
return res
cC = substr(sqlErrMc, lastPos('ff'x, sqlErrMc)+1)
rs = 'SQL.'cx'.RESULTSET'
m.rs = 100+cx
m.rs.0 = cc
m.rs.act = 0
lc = ''
do rx=1 to cc
lc = lc', :m.'rs'.'rx
end
call sqlExec0 'ASSOCIATE LOCATORS ('substr(lc, 3)')' ,
'WITH PROCEDURE' prc
if sqlNextResultSet(cx) then
return 0
else
return err('no resultset')
endProcedure sqlCall
/*--- switch to next resultset, return false if none ----------------*/
sqlNextResultSet: procedure expose m.
parse arg cx
rs = 'SQL.'cx'.RESULTSET'
if m.rs <= 100 | m.rs.act >= m.rs.0 then
return 0
ax = m.rs.act + 1
m.rs.act = ax
call sqlResetCrs cx
call sqlexec0 'allocate c'm.rs 'cursor for result set :m.'rs'.'ax
CALL SQLEXEC0 'DESCRIBE CURSOR :C'm.rs 'INTO :M.SQL.'cx'.D'
call sqlFetchVars cx
return 1
endProcedure sqlNextResultSet
/*-- execute a query, update or call --------------------------------*/
sqlExecute: procedure expose m.
parse arg cx, src, retOk
f = translate(word(src, 1))
bx = pos('(', f)
if bx > 0 then
f = left(f, max(1, bx-1))
m.sql.cx.fun = f
if f == 'SELECT' | f == 'WITH' | f == '(' then
return sqlQuery(cx, src, , retOk)
else if f == 'CALL' then
return sqlCall(cx, src, retOk)
else
return sqlUpdate(cx, src, retOk)
endProcedure sqlExecute
/*--- describe table and return sqlDA -------------------------------*/
sqlDescribeTable: procedure expose m.
parse upper arg tb, force
if force == 1 | \ datatype(m.sql.table.tb.sqlD, 'n') then
call sqlExec 'describe table :tb into :M.SQL.TABLE.'tb
return 'SQL.TABLE.'tb
endProcedure sqlDescribeTable
/*--- return select column list for table tb
omit Blobs (blobMax < 0) or substr(blob, 1, blobMax) ----------*/
sqlColList: procedure expose m.
parse arg tb al, blobMax
sd = sqlDescribeTable(tb)
bs = ''
lst = ''
if al \== '' & right(al, 1) \== '.' then
al = al'.'
do sx=1 to m.sd.sqld
if wordPos(m.sd.sx.sqlType, '404 405 408 409 412 413') < 1 then
lst = lst',' al || m.sd.sx.sqlName
else do
bs = bs m.sd.sx.sqlName
if blobMax >= 0 then
lst = lst', length('al || m.sd.sx.sqlName')' ,
m.sd.sx.sqlName'Len' ,
|| ', substr('al || m.sd.sx.sqlName ,
|| ', 1,' blobMax')' m.sd.sx.sqlName
end
end
m.sd.colList = substr(lst, 3)
m.sd.blobs = strip(bs)
return substr(lst, 3)
endProcedure sqlColList
/*--- use describe output to generate column names,
'' use names from ca (rexxified)
nms+ use names, check ca for null values
?('?'?nm)+ use names, check for null if preceeded by ?
:... use string as is
fetchVariables and sqlNull names --------------------*/
sqlFetchVars: procedure expose m.
parse arg cx, src, cd
if abbrev(src, ':') then do
m.sql.cx.fetchVars = src
m.sql.cx.fetchCode = cd
m.sql.cx.fetchFlds = ''
return
end
if src <> '' then do
ff = src
end
else do
ff = ''
do kx=1 to m.sql.cx.d.sqlD
ff = sqlNiceVarsApp(ff, m.sql.cx.d.kx.sqlName)
end
end
m.sql.cx.fetchFlds = ff
if m.sql.cx.d.sqlD <> words(ff) then
call err 'sqlFetchVars sqlD='m.sql.cx.d.sqlD ,
'<>' words(ff) 'fields of' ff
sNu = ''
sFe = ''
do kx=1 to m.sql.cx.d.sqlD
nm = word(ff, kx)
sFe = sFe', :m.dst.'nm
if m.sql.cx.d.kx.sqlType // 2 then do
sFe = sFe' :m.dst.'nm'.sqlInd'
sNu = sNu 'if m.dst.'nm'.sqlInd < 0 then' ,
'm.dst.'nm '= m.sqlNull;'
end
end
m.sql.cx.fetchVars = substr(sFe, 3)
m.sql.cx.fetchCode = sNu cd
return
endProcedure sqlFetchVars
/*--- append next column name
ensure name is unique and rexx compatible -----------------*/
sqlNiceVarsApp: procedure expose m.
parse arg old, nx rest
upper nx
cx = verifId(nx)
if cx > 0 then /* avoid bad characters for classNew| */
nx = left(nx, cx-1)
if nx <> '' & wordPos(nx, old) < 1 then
return old nx
else
return old 'COL' || (words(old) + 1)
endProcedure sqlNiceVarsApp
/*--- set one value in a DA, handle nulls ---------------------------*/
sqlDASet: procedure expose m.
parse arg cx, da, ix, val
m.sql.cx.da.ix.sqlData = val
m.sql.cx.da.ix.sqlInd = - (val == m.sqlNull)
/* data types schienen einmal nicht zu funktionieren .......
if wordPos(m.da.ix.sqlType, '384 385 388 389 392 393') > 0 then
m.da.ix.sqlType = 448 + (m.da.ix.sqlType // 2) */
return
endProcedure sqlDASet
sqlCommit: procedure expose m.
return sqlExec0('commit')
endProcedure sqlCommit
/*** sql.4: diverse helpers ******************************************/
/*-- fetch all rows to stem and close -------------------------------*/
sqlFetch2St: procedure expose m.
parse arg cx, dst, retOK
do sx=1 while sqlFetch(cx, dst'.'sx)
end
res = sx-1
m.dst.0 = sx-1
call sqlClose cx
return m.dst.0
endProcedure sqlFetch2St
/*-- execute a query, copy result to stem ---------------------------*/
sql2St: procedure expose m.
parse arg src, dst, feVa, retOK
cx = m.sql_defCurs
res = sqlQuery(cx, src, feVa, retOk)
return sqlFetch2St(cx, dst, retOk)
endProcedure sql2St
/*-- return first column of the only row and close ------------------*/
sqlFetch2One: procedure expose m.
parse arg cx, dst, retNone
f1 = sqlFetch(cx, dst)
if f1 == 1 then
f2 = sqlFetch(cx, dst'.2')
if f1 >= 0 then
call sqlClose cx
else do
say 'sqlFetch2One sqlCode='f1
call sqlClose cx, '*'
end
if f1 \== 1 then
if retNone \== '' then
return substr(retNone, 2)
else
call err 'sqlFetch2One: no row returned'
else if f2 == 1 then
call err 'sqlFetch2One: more than 1 row'
else if f2 \== 0 then
call err 'sqlFetch2One second fetch sqlCode='f2
if m.sql.cx.fetchFlds == '' then do
c1 = substr(word(m.sql.cx.fetchVars, 1), 2)
res = value(c1)
return res
end
c1 = word(m.sql.cx.fetchFlds, 1)
return m.dst.c1
endProcedure sqlFetch2One
/*-- execute a query and return first column of the only row
if > 1 row fail, if 0 rows return arg(3) or fail ---------*/
sql2One: procedure expose m.
parse arg src, dst, feVa, retOk, retNone
cx = m.sql_defCurs
call sqlQuery cx, src, feVa, retOk
return sqlFetch2One(cx, dst, retNone)
endProcedure sql2One
/*--- execute the given sql plus a commit
until no more rows are updated -----------------------------*/
sqlUpdComLoop: procedure expose m.
parse arg src, retOk
cx = m.sql_defCurs
upds = 0
if retOk == '' then
retOk = 100
do coms=0
cd = sqlExecute(crs, src, retOk)
if m.sql.crs.updateCount < 1 then do
return sqlMsgLine( , upds, src, coms 'commits')
end
upds = upds + m.sql.crs.updateCount
call sqlCommit
if coms // 20 = 19 then
say sqlMsgLine(time(), upds, src, (coms+1) 'commits')
end
endProcedure sqlUpdComLoop
/*** sql.5: manage cursors *******************************************/
/*--- return a free cursor ------------------------------------------*/
sqlGetCursor: procedure expose m.
parse arg rng
if rng == '' then
return sqlGetCursorRng(rng, 10, 48)
else if rng == 'h' then
return sqlGetCursorRng(rng, 60, 99)
else
call err 'bad cursor range' rng
endProcedure sqlGetCursor
sqlGetCursorRng: procedure expose m.
parse arg rng, fr, to
cx = pos(' ', m.sql_cursors, fr)
if cx < fr & cx > to then
call err "no more '"rng"' cursors between" fr "and" to,
":"m.sql_cursors
m.sql_cursors = overlay('u', m.sql_cursors, cx)
return cx
endProcedure sqlGetCursorRNG
/*--- mark a cursor as closed ---------------------------------------*/
sqlFreeCursor: procedure expose m.
parse arg cx
if substr(m.sql_cursors, cx, 1) \== 'u' then
call err 'sqlFreeCursor('cx') not in use :'m.sql_cursors
m.sql_cursors = overlay(' ', m.sql_cursors, cx)
return
endProcedure sqlFreeCursor
/* copy sql end ****************************************************/
/* copy dsnList begin *************************************************
csi interface: see dfs managing catalogs chapt. 11
returncode/reason see message IDC3009I
**********************************************************************/
/*--- specify dsn mask and fields to start a csi catalog search -------
arguments:
m objectPointer
dsnMask specifies the dsns with wildcards:
% 1 character
* 0 - n character in one level
** 0 - n levels
fields a (space separated) list of field names ------------*/
csiOpen: procedure expose m.
parse arg m, dsnMask, fields
m.m.fld.0 = words(fields)
ffix = d2c(m.m.fld.0, 2)
do x=1 to m.m.fld.0
m.m.fld.x = translate(word(fields, x))
ffix = ffix || left(m.m.fld.x, 8)
end
if dsnMask \== '' & right(dsnMask, 1) \== ' ' ,
& pos('*', dsnMask) < 1 & length(dsnMask) < 42 then
dsnMask = dsnMask'.**'
m.m.filt = left(dsnMask, 149) ,
|| left('Y', 3) , /* resume offset 149 */
|| ffix /* csiNumEn offset 152 */
WORKLEN = 1024 * 64
m.m.work = D2C(WORKLEN,4) || COPIES('00'X,WORKLEN-4)
m.m.pos = workLen + 1
return
endProcedure csiOpen
/*--- put the next dsn into m.o and m.o.* (for other fields)
return 1 if next dsn exists 0 otherwise -----------------------*/
csiNext: procedure expose m.
parse arg m, o
usedL = C2D(SUBSTR(m.m.work,9,4)) /* GET AMOUNT OF WORK AREA USED*/
px = m.m.pos
do forever
if px > usedL then do
if substr(m.m.filt, 150, 1) \== 'Y' then do
m.m.pos = px
m.o = ''
return 0
end
reason = left('', 4)
ADDRESS LINKPGM 'IGGCSI00 reason m.'m'.filt m.'m'.work'
if rc == 0 & substr(reason, 3, 2) == '0000'x then
nop
else if rc == 4 & substr(reason, 3, 2) == '0464'x then
say 'data set entry with error'
else
call err 'call csi returns' rc,
'rc' c2d(substr(reason, 4,1)),
'reason' c2d(substr(reason, 3,1)),
'module' substr(reason, 1,2)
usedL = C2D(SUBSTR(m.m.work,9,4)) /* GET WORK AREA USED */
numFD = C2D(SUBSTR(m.m.work,13,2)) /* no flds + 1 */
if numFd <> m.m.fld.0 + 1 then
call err 'csiNumFd' numFd 'not' m.m.fld.0 '+' 1
px = 15
iterate
end
eType = substr(m.m.work, px+1, 1)
m.o = strip(substr(m.m.work, px+2, 44), 't')
flag = substr(m.m.work, px, 1)
/* say 'eType' eType m.o 'flag' c2x(flag) */
if eType == '0' then do
if flag \== '00'x & flag \== '40'x then
call err 'flag' c2x(flag) 'for catalog' m.o
px = px + 50 /* length of catalog entry */
iterate
end
else do
if \ abbrev(x2b(c2x(flag)), '101') then
call err 'call csi entry flag' x2b(c2x(flag)),
'rc' c2d(substr(m.m.work, px+49,1)),
'reason' c2d(substr(m.m.work, px+48,1)),
'module' substr(m.m.work, px+46, 2),
'for entry' m.o,
'see qw IDC3009I'
py = px + 46
tl = c2d(substr(m.m.work, py, 2))
pl = py + 4
pf = py + m.m.fld.0 * 2 + 4
do fx = 1 to m.m.fld.0
fi = m.m.fld.fx
fl = c2d(substr(m.m.work, pl, 2))
m.o.fi = substr(m.m.work, pf, fl)
if fi = 'MGMTCLAS' then
m.o.fi = substr(m.o.fi, 3, c2d(left(m.o.fi ,2)))
else if wordPos(fi, 'COMUDSIZ NOBYTTRK') > 0 then
m.o.fi = utc2d(m.o.fi)
pf = pf + fl
pl = pl + 2
end
if py + tl <> pf then
call err 'length mismatch for entry' m.o
m.m.pos = pf
return 1
end
end
endProcedure csiNext
/*--- if dsn is arcived return 'arcive'
if dsn is tape return 'tape'
otherwise return managment class ------------------------------*/
csiArcTape: procedure expose m.
parse arg vo, cl, dt, dsn
if vo = '' then
say err '||| no volume for dsn' dsn
else if vo = 'ARCIVE' | vo = 'MIGRAT' then
res = 'arcive'
else if cl <> '' then
res = cl
else if abbrev(vo, 'SHR') then
res = 'SHR'
else
res = 'tape'
if res = 'arcive' then
return res
/*if abbrev(res, 'ar') \= abbrev(dt, '00'x) , */
if abbrev(res, 'ta') \= abbrev(c2x(left(dt, 1)), '7') ,
| (left(res, 1) >= 'A') \= abbrev(dt, '30'x) then
say '||| mismatch cl' cl 'vo' vo 'dt' c2x(dt) 'dsn' dsn
return res
endProcedure csiArcTape
/*--- 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
/*--- dsnList: csi or csm to stem -----------------------------------*/
dsnList: procedure expose m.
parse arg oo, aMsk, rzPref
parse value dsnCsmSys(aMsk) with rz '/' msk
if msk \== '' & right(msk, 1) \== ' ' ,
& pos('*', msk) < 1 & length(msk) < 42 then
msk = msk'.**'
if rz == '*' then do
call csiOpen dsnList_csi, msk
do ox=1 while csiNext(dsnList_csi, oo'.'ox)
end
end
else do
pre = copies(rz'/', rzPref \== 0)
call adrCsm 'dslist system('rz') dsnMask('msk') short', 4
do ox=1 to stemSize
m.oo.ox = pre || dsName.ox
end
end
m.oo.0 = ox-1
return m.oo.0
endProcedure dsnList
/*--- mbrList with listDS or csm to stem ----------------------------*/
mbrList: procedure expose m.
parse arg m, pds
parse value dsnCsmSys(translate(dsn2jcl(pds))) with sys '/' dsn
msk = strip(dsnGetMbr(dsn))
if msk == '*' then
msk = ''
dsn = dsnSetMbr(dsn)
if sys \== '*' then
return csmMbrList(m, sys, dsn, msk)
if adrTso(listDS "'"dsn"'" members, 8) <> 0 then
mx = -99
else if m.tso_trap.1 <> dsn then
call err 'mbrList dsn='dsn '<> trap.1='m.tso_trap.1
else if m.tso_trap.2 <> '--RECFM-LRECL-BLKSIZE-DSORG' then
call err 'mbrList dsn='dsn 'trap.2='m.tso_trap.2
else do
parse var m.tso_trap.3 ,
m.m.RECFM m.m.LRECL m.m.BLKSIZE m.m.DSORG .
oy = m.tso_trap.0 + 99
mFound = 0
mx = 0
do ox=4 to m.tso_trap.0
if mFound then do
if msk \== '' then
if \ match(strip(m.tso_trap.ox), msk) then
iterate
mx = mx + 1
m.m.mx = strip(m.tso_trap.ox)
end
else
mFound = m.tso_trap.ox == '--MEMBERS--'
end
if \ mFound then
mx = -98
end
m.m.0 = mx
return mx
endProcedure mbrList
/*--- return whether a dsn exists -----------------------------------*/
dsnExists: procedure expose m.
parse upper arg aDsn
parse value dsnCsmSys(aDsn) with rz '/' dsn
if rz == '*' then
return sysDsn("'"dsn"'") == 'OK'
else if dsnGetMbr(dsn) <> '' then
return csmMbrList(tso_dsnExits, rz, dsnSetMbr(dsn) ,
, dsnGetMbr(dsn)) == 1
else do
lc = adrCsm('dslist system('rz') dsnMask('dsn') short', 4)
if stemsize = 0 | stemSize = 1 then
return stemSize
call err 'csmExists stemSize='stemsize 'for dsn='aDsn
end
endProcedure dsnExists
/*--- copy members / datasets ---------------------------------------
fr, to from or to dsn with or without member
mbrs: space separated list of mbr or old>new
opts
* all members from lib to lib
& members as defined in mbrs argument
- sequentiel (or library WITH member)
*- if * fails then do - from fr to to
&- if & fails then do - from fr(mbr) to to
---------------------------------------------------------------------*/
dsnCopy: procedure expose m.
parse upper arg fr opt . , to toPl, mbrs
op1 = '?'
if opt \== '' then do
parse upper arg opt fr .
if pos(left(opt, 1), 'WTC?') > 0 then
parse var opt op1 2 opt
end
if opt == '-' then do
if mbrs \== '' then
call err 'op1 - but mbrs not empty' mbrs
end
else do
fMb = dsnGetMbr(fr)
fr = dsn2jcl(dsnSetMbr(fr))
tMb = dsnGetMbr(to)
to = dsn2jcl(dsnSetMbr(to))
if mbrs = '' then
if fMb = '' then
to = dsnSetMbr(to, tMb)
else if tMb = '' then
mbrs = fMb
else
mbrs = fMb'>'tMb
else if fMb \== '' | tMb \== '' then
call err 'fr='fr 'to='to 'but with mbrs='mbrs
if mbrs = '' then
o2 = left('*', tMb = '')'-'
else if words(mbrs) = 1 & pos('>', mbrs) < 1 then
o2 = if(verify(mbrs, '*?', 'm') > 0, '*', '&')'-'
else
o2 = '&'
if opt == '' then
opt = o2
else if pos(opt, o2) == 0 then
call 'bad opt' opt 'not in' o2
end
if abbrev(opt, '*') then do
mbrs = ''
do mx=1 to mbrList(tso_dsnCopy, fr'('fMb')')
mbrs = mbrs m.tso_dsnCopy.mx
end
if m.tso_dsnCopy.0 > 0 then
opt = '&'
else if m.tso_dsnCopy.0 = 0 then do
say 'nothing copied, no members in' fr
return
end
else if substr(opt, 2, 1) == '-' then
opt = '-'
else
return err(fr 'is not a library')
end
/* currently we use csm, which calls IBM Utilities
for us, which seems not to be easy do to directly */
if op1 == 'C' | op1 == '?' then do
r = csmCop2(op1 opt, fr, to toPl, mbrs)
if datatype(r, 'n') then
return r
op1 = r
end
if op1 == 'W' | op1 == 'T' then /* use read and write,
allows reformatting */
return dsnCopW(op1 opt, fr, to toPl, mbrs)
call err 'dsnCopy bad opt' op1 opt
endProcedure dsnCopy
dsnCopW: procedure expose m. i.
parse arg o1 o2, fr, to tPl, mbrs
if words(mbrs) > 1 then do
do mx=1 to words(mbrs)
call dsnCopW o1 o2, fr, to tPl, word(mbrs, mx)
end
return words(mbrs)
end
parse var tPl tA1 ':' tA2
if \ abbrev(o2, '&') then do
parse value dsnAlloc(fr, , 'readDD') with fDD fFr
tAt = strip(tA1 ':'firstNS(tA2, ':D'fDD))
parse value dsnAlloc(to tAt, , 'writeDD') with tDD tFr
end
else do
parse value strip(mbrs) with fMb '>' tMb
fr = dsnSetMbr(fr, fMb)
parse value dsnAlloc(fr, , 'readDD') with fDD fFr
tAt = strip(tA1 ':'firstNS(tA2, ':D'fDD))
to = dsnSetMbr(to, firstNS(tMb, fMb))
parse value dsnCsmSys(to) with rz '/' .
if o2 = '&-' & rz == '*' then do
r2 = sysDsn("'"to"'")
if r2 == 'OK' | r2 == 'MEMBER NOT FOUND' ,
| r2 == 'DATASET NOT FOUND' then
nop
else if r2 ,
== 'MEMBER SPECIFIED, BUT DATASET IS NOT PARTITIONED' then
to = dsnSetMbr(to)
else
call err 'sysDsn(to='to')' r2
end
parse value dsnAlloc(to tAt, , 'writeDD') with tDD tFr
if o2 = '&-' & rz \== '*' then do
if m.tso_dsorg.tDD <> 'PO' then do
call tsoFree tFr
to = dsnSetMbr(to)
parse value dsnAlloc(to tAt, , 'writeDD') with tDD tFr
end
end
end
cnt = 0
trunc = 0
do while readDD(fDD, i., 500)
cnt = cnt + i.0
call writeDD tDD, i., , o1 == 'T'
if m.tso_rc then
trunc = 1
end
call tsoClose fDD
if cnt = 0 then
call tsoOpen tDD, 'W'
call tsoClose tDD
call tsoFree fFr tFr
say 'copied' cnt 'recs from' fr 'to' to copies('truncation',trunc)
return cnt
endProcedure dsnCopW
dsnDel: procedure expose m.
parse upper arg aDsn, aMbrs
parse value dsnCsmSys(dsn2jcl(aDsn)) with sys '/' dsn
mbrs = dsnGetMbr(dsn) aMbrs
dsn = dsnSetMbr(dsn)
if sys \== '*' then
return csmDel(sys, dsn, mbrs)
if mbrs = '' then do
dRc = adrTso("delete '"dsn"'", 8)
end
else do
call dsnAlloc 'dd(deldd)' dsn
do mx=1 to words(mbrs)
m1 = word(mbrs, mx)
dRc = adrTso("delete '"dsn"("m1")' file(delDD)", 8)
if dRc <> 0 then do
if pos('IDC3330I **' m1' ', m.tso_trap) < 1 then
leave
say 'member not found and not deleted:' dsn'('m1')'
dRc = 0
end
end
call tsoFree deldd
end
if dRc = 0 then
return 0
if pos('IDC3012I ENTRY' dsn 'NOT FO', m.tso_trap) >= 1 then do
say 'dsn not found and not deleted:' dsn
return 4
end
call err 'adrTso rc='m.tso_rc 'stmt='m.tso_stmt m.tso_trap
return 8
endProcedure dsnDel
/* copy dsnList end ************************************************/
/* copy csm begin *****************************************************
interface to csm,
it is integrate with adrTso, eg. dsnAlloc , 'RZ3/..' uses csm
**********************************************************************/
/*--- execute a single csmExec command ------------------------------*/
adrCsm:
if wordPos(translate(word(arg(1), 1)), 'COPY MBRLIST') > 0 then
ggTO = ''
else if symbol('m.csm_timeOut') == 'VAR' then
ggTO = 'timeout('m.csm_timeOut')'
else
ggTO = 'timeout(30)'
ggStart = time()
if adrTso('csmExec' arg(1) ggTO, '*') == 0 then
return 0
if pos('CSMXC43E NO CONNECTION TO S', m.tso_trap) > 0 ,
| pos('CSMXC36E TIMEOUT LIMIT EXCEEDED DURING LOGON TO' ,
, m.tso_trap) > 0 then
/* CSMXC43E NO CONNECTION TO SYSPLEX:RR2 AVAILABLE
CSMXC36E TIMEOUT LIMIT EXCEEDED DURING LOGON TO SYS*/
m.csm_err = 'noConn'
else if pos('IKJ56225I', m.tso_trap) > 0 ,
& ( pos('ALREADY IN USE', m.tso_trap) > 0 ,
| pos('CATED TO ANOTH', m.tso_trap) > 0) then
/* 5 IKJ56225I DATA SET A540769.TMP.TEXT ALREADY IN USE,
6 IKJ56225I DATA SET IS ALLOCATED TO ANOTHER JOB */
m.csm_err = 'inUse'
else
m.csm_err = ''
m.csm_errMsg = strip('csmExec' m.csm_err) 'rc='m.tso_rc ,
'\nstmt='subWord(m.tso_stmt, 2) m.tso_trap ,
'\nend of csmExec, time='ggStart '-' time()
if pos('*', arg(2)) <= 0 & wordPos(m.tso_rc, arg(2)) <= 0 then
call err m.csm_errMsg
return m.tso_rc
endProcedure adrCsm
csmDel: procedure expose m.
parse upper arg rz, dsn, aMbrs
mbrs = dsnGetMbr(dsn) aMbrs
lib = dsnSetMbr(dsn)
dd = tsoDD(csmDel, 'a')
if mbrs = '' then do
dRc = adrCsm("allocate system("rz") dataset('"lib"')" ,
"disp(del) ddname("dd")", 8)
end
else do
dRc = adrCsm("allocate system("rz") dataset('"lib"')" ,
"disp(shr) ddname("dd")", 8)
if dRc == 0 then do
do mx=1 to words(mbrs)
m1 = word(mbrs, mx)
dRc = adrCsm("mDelete ddName("dd") member("m1")", 8)
if dRc <> 0 then do
if pos('CSMEX77E Member:'m1 'not f', m.tso_trap) ,
< 1 then
leave
say 'member not found, not deleted:' rz'/'dsn'('m1')'
dRc = 0
end
end
end
end
if dRc = 0 then
return tsoFree(dd)
if pos('CSMSV29E DATA SET' lib 'NOT IN CAT', m.tso_trap) >0 then do
say 'dsn not found and not deleted:' rz'/'dsn
call tsoFree dd
return 4
end
eMsg = 'rc='m.tso_rc 'stmt='m.tso_stmt':' m.tso_trap
call tsoFree dd
return err('csmDel' eMsg)
endProcedure csmDel
/*--- copy members / datasets
Vorlage: csrxUtil ---------------------------------------------*/
csmCopy: procedure expose m.
parse upper arg fr, to, mbrs
say 'please use dsnCopy instead of depreceated csmCopy'
return dsnCopy(fr, to, mbrs)
csmCop2: procedure expose m.
parse upper arg o1 o2, fr, to tA1 ':' tA2, mbrs
frDD = tsoDD('csmFrDD', 'a')
tAt = strip(tA1 firstNS(tA2, ':D'frDD))
toDD = tsoDD('csmToDD', 'a')
mbr1 = abbrev(o2, '&') & words(mbrs) = 1
if mbr1 then do
parse value strip(mbrs) with fMb '>' tMb
call csmAlloc fr'('fMb')', frDD, 'shr'
tM2 = firstNS(tMb, copies(fMb, o2 <> '&-'))
call csmAlloc dsnSetMbr(to, tM2), toDD, 'shr', , tAt
end
else do
call csmAlloc fr, frDD, 'shr'
call csmAlloc to, toDD, 'shr', , tAt
end
if m.tso_recFM.frDD <> m.tso_recFM.toDD ,
| m.tso_lRecL.frDD <> m.tso_lRecL.toDD then do
call tsoFree frDD toDD
return if(m.tso_lRecL.frDD <= m.tso_lRecL.toDD, 'W', 'T')
end
inDD = tsoDD('csmInDD', 'a')
i.0 = 0
if abbrev(o2, '&') & \ mbr1 then do
i.0 = words(mbrs)
do mx=1 to i.0
parse value word(mbrs, mx) with mF '>' mT
if mF = '' then
call err 'bad mbr or mbrOld>mbrNew' word(mbrs, mx),
'in csmCopy('fr',' to','mbrs')'
else if mT = '' then
i.mx = ' S M='mF
else
i.mx = ' S M=(('mF','mT'))'
end
end
if i.0 <= 0 then do
call adrTso 'alloc dd('inDD') dummy'
end
else do
call tsoAlloc ,inDD, 'NEW', , ':F'
call writeDD inDD, 'I.', i.0
call tsoCLose inDD
end
outDD = tsoDD('csmOuDD', 'a')
call dsnAlloc('dd('outDD') new ::V137')
cmdu = 'CSMUTIL CSM,COPYREPLACE,DD(,,,,'inDD','outDD ,
|| ',,'frDD','toDD'),MARC(0)'
cRc = adrTso(cmdU, '*')
if cRc <> 0 then do
call readDD outDD, o.
call tsoClose outDD
say 'rc='cRc',' o.0 'outputlines for' cmdU
do ox=1 to o.0
say o.ox
end
end
call tsoFree frDD toDD inDD outDD
if cRc <> 0 then
call err 'csmCopy rc='cRc
return cRc
endProcedure csmCopy
csmAlloc: procedure expose m.
parse arg sysDsn, dd, disp, rest, nn, retRc
upper dd disp
parse value dsnCsmSys(sysDsn) with sys '/' dsn
m.tso_dsn.dd = sys'/'dsn
if disp = '' then
disp = 'shr'
else if words(disp) = 2 then
disp = word(disp, 2)
a1 = "SYSTEM("sys") DDNAME("dd")"
if dsn == 'INTRDR' then do
a1 = a1 'sysout(T) writer(intRdr)'
end
else do
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")"
end
nAtts = wordPos(disp, 'NEW MOD CAT') > 0 & nn \== ''
if nAtts then
rest = dsnCreateAtts('-'dsn , nn) rest
cx = pos(' UCOUNT(', ' 'translate(rest))
if cx > 0 then do
rest = left(rest, cx) || 'nitCnt(' || substr(rest, cx+7)
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)
end
cx = pos(' CYLINDERS ', ' 'translate(rest)' ')
if cx > 0 then do
rest = delStr(rest, cx+8, 1)
end
cx = pos(' CYL ', ' 'translate(rest)' ')
if cx > 0 then
rest = insert('inder', rest, cx+2)
noRetry = retRc <> '' | nAtts | nn == ''
alRc = adrCsm('allocate' a1 rest, if(noRetry, retRc, '*'))
m.tso_dsorg.dd = subsys_dsOrg
m.tso_recFM.dd = subsys_recFM
m.tso_blkSize.dd = subsys_blkSize
m.tso_lRecL.dd = subsys_lRecL
if alRc = 0 then
return 0
m.tso_dsnNF.dd = pos('CSMSV29E DATA SET' dsnSetMbr(dsn) ,
'NOT IN CATALOG', m.tso_trap) > 0
if noRetry | \ m.tso_dsnNF.dd then
if pos('*', retRc) > 0 | wordPos(alRc, retRc) > 0 then
return alRc
else
return err(m.csm_errMsg)
say 'csmAlloc rc' alRc 'for' a1 rest '...trying to create'
call csmAlloc sysDsn, dd, 'CAT', rest ,nn
call adrTso 'free dd('dd')'
return adrCsm('allocate' a1 rest)
endProcedure csmAlloc
csmLikeAtts: procedure expose m.
parse upper arg rz '/' dsn
lc = adrCsm('dslist system('rz') dsnMask('dsnSetMbr(dsn)')')
if stemsize <> 1 then
call err 'csmLikeAtts stemSize='stemsize 'for dsn='dsn
if abbrev(dsOrg.1, 'PO') then
r = 'dsorg(po) dsnType(library)'
else if abbrev(dsOrg.1, 'PS-') then
r = 'dsorg(PS)'
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('fUnit2I('b', tracksused.1) ,
|| ',' fUnit2I('b', 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 */
return r
endProcedure csmLikeAtts
csmMbrList: procedure expose m.
parse arg m, sys, dsn, msk
/* attention mbrList dataset(....)
does not cleanup proberly if dsn is NOT PO
and much later on follow errors appear
which are hard to debug| */
if dataType(dsnAlloc(sys'/'dsn, , mbrLisDD, 8), 'n') then do
say sys dsn
say m_tso_trap
m.m.dsnNF = m.tso_dsnNF.mbrLisDD
if \ m.m.dsnNF then
call err m.csm_errMsg
m.m.0 = -99
end
else do
m.m.dsnNF = 0
m.m.RECFM = m.tso_RECFM.mbrLisDD
m.m.LRECL = m.tso_LRECL.mbrLisDD
m.m.BLKSIZE = m.tso_BLKSIZE.mbrLisDD
m.m.DSORG = m.tso_DSORG.mbrLisDD
if m.m.DSORG \== 'PO' then
m.m.0 = -98
else do
if msk <> '' then
msk = 'member('translate(msk, '%', '?')')'
call adrCsm "mbrList ddName(mbrLisDD)" msk ,
"index(' ') short"
m.m.0 = mbr_name.0
do mx=1 to mbr_name.0
m.m.mx = strip(mbr_name.mx)
end
end
call tsoFree mbrLisDD
end
return m.m.0
endProcedure csmMbrList
/*--- 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
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, cmd, keepTsPrt, retOk
do cx=1 to (length(cmd)-1) % 68 /* split tso cmd in linews */
cmd.cx = substr(cmd, 68*cx-67,68)'-'
end
cmd.cx = substr(cmd, 68*cx-67)
cmd.0 = cx
/* alloc necessary dd */
call dsnAlloc rz"/"proc "dd(rmSyPro) rmtDDn(sysProc)"
call dsnAlloc rz"/tmp.tsin new dd(rmTsIn) rmtDdn(sysTsIn) ::f "
call tsoOpen rmTsIn, 'w' /* write tso cmd */
call writeDD rmTsIn, cmd.
call tsoClose rmtsin
call dsnAlloc rz"/tmp.tsPrt new dd(rmtTsPrt) rmtDdn(sysTsPrt)",
"::v"
call dsnAlloc rz"/tmp.rmt new dd(rmtSys)"
tsoRc = adrtso("csmappc start pgm(csmexec)" ,
"parm('select tsocmd(''csmappc allocate plu(*.rmtSys)" ,
"tpname(sysikj) dealloc '')')", "*")
if tsoRc <> 0 then
m.csm_exRxRc = tsoRc
else
m.csm_exRxRc = appc_rc
m.csm_exRx.0 = 0
if m.csm_exRxRc <> 0 then do /* handle csm error */
call mAdd csm_exRx, 'csmExRx tsoRc='tsoRc 'appc_rc='appc_rc ,
, ' rexx rz='rz 'proc='proc'\n cmd='cmd ,
, ' appc_rc='appc_rc 'reason='appc_reason ,
'state_c='appc_state_c appc_state_f ,
, ' SUBSYS_TSR15='subsys_tsr15 'tsRc='SUBSYS_TSRC ,
'abend='subsys_tsAbend 'reason='subsys_tsReason
do ix=1 to appc_msg.0
call mAdd csm_exRx, ' ' appc_msg.ix
end
if tsoRc = 0 then
call mAdd csm_exRx ' rc=0 for tsoCmd' m.tso_stmt
else
call splitNl csm_exRx, m.csm_exRx.0,
, 'adrTso rc='m.tso_rc 'stmt='m.tso_stmt m.tso_trap
call readDD 'rmtTsPrt', 'M.CSM_TSPRT.', '*'
call tsoClose rmtTsPrt
call mAdd csm_exRx, left('remote sysTsPrt' ,
m.csm_tsprt.0 'lines begin ', 79, '-')
call mAddSt csm_exRx, csm_tsprt
call mAdd csm_exRx, left('remote sysTsPrt' ,
m.csm_tsprt.0 'lines end ', 79, '-')
/* call mStrip csm_exRx, 't'
call saySt csm_exRx */
end
call tsoFree rmSyPro rmtSys rmtsIn copies(rmtTsPrt, keepTsPrt\==1)
if pos(m.csm_exRxRc, 0 4) < 1 then do /* handle csm error */
if pos('*', retOk) > 0 | wordPos(m.csm_exRxRc, retOk) > 0 then
call saySt csm_exRx
else
call csmExRxErr
end
return m.csm_exRxRc
endProcedure csmExRx
/*--- error for last csmExRx ----------------------------------------*/
csmExRxErr: procedure expose m.
call outSt csm_exRx
call err m.csm_exRx.1
return
endProcedure csmExRxErr
csmExWsh: procedure expose m.
parse arg rz, rdr, opt
w = oNew(m.class_csmExWsh, rz, rdr, opt)
call pipeWriteAll w
return
csmExWshOpen: procedure expose m.
parse arg m, opt
rz = m.m.rz
if opt \== '<' then
call err 'csmExWshOpen('opt') not read'
a1 = dsnAlloc(rz"/tmp.wsh new dd(rmtWsh) rmtDdn(wsh) ::v",,, '*')
if datatype(a1, 'n') then do
call sayNl 'adrTso rc='a1 'stmt='m.tso_stmt m.tso_trap
say 'trying to free'
call tsoFree 'rmtSys rmTsPrt rmTsIn rmSyPro rmTsPrt ' ,
'rmtwsh rmtOut'
call dsnAlloc rz"/tmp.wsh new dd(rmtWsh) rmtDdn(wsh) ::v"
end
wsh = jOpen(file('dd(rmtWsh)'), '>')
call jWriteNow wsh, in2file(m.m.rdr)
call jClose wsh
parse var m.m.wOpt oOpt wSpec
if wSpec = '' then
wSpec = '@'
o2 = firstNS(oOpt, 'v')
if oOpt == 'e' then do
o2 = 'v'
wSpec = '$#outFmt e $#'wSpec
end
if o2 == 'p' then do
fo = file('dd(rmtTsPrt)')
end
else do
if length(o2) > 1 then do
/* without blkSize csm will fail to read for rec < 272 */
parse upper var o2 oA 2 oB
if datatype(oB, 'n') then do
blk = 32760
if oA == 'F' then
blk = blk - blk // oB
say '???? ::'o2 '==> blkSize('blk')'
o2 = o2 'blkSize('blk')'
end
end
call dsnAlloc rz"/tmp.out new dd(rmtOut) rmtDdn(out) ::"o2
fo = file('dd(rmtOut)')
end
if oOpt == 'e' then
m.m.deleg = csvIntRdr(csvF2VRdr(fo))
else
m.m.deleg = fo
say 'cmsExWsh sending to' rz wSpec
if abbrev(m.myLib, A540769) then
m.m.exRxRc = csmExRx(rz, m.myLib, m.myWsh wSpec,
, o2 == 'p' , '*')
else
m.m.exRxRc = csmExRx(rz, 'DSN.DB2.EXEC', 'WSH' wSpec,
, o2 == 'p' , '*')
call tsoFree 'rmtWsh'
call jOpen m.m.deleg, opt
m.fo.free = m.fo.dd
return m
endProcedure csmExWshOpen
csmIni: procedure expose m.
if m.csm_ini == 1 then
return
m.csm_ini = 1
call catIni
call classNew 'n CsmExWsh u JRWDeleg', 'm' ,
, "jReset m.m.deleg = ''; m.m.rz = arg; m.m.rdr = arg2" ,
"; m.m.wOpt = arg(4)" ,
, "jOpen call csmExWshOpen m, opt" ,
, "jClose call jClose m.m.deleg;" ,
"if pos(m.m.exRxRc, 0 4) < 1 then call csmExRxErr;" ,
"else say 'csm execute wsh rc =' m.m.exRxRc"
return
endProcedure csmIni
/*--- execute a single csmAppc command ------------------------------*/
csmAppc:
return adrTso('csmAppc' arg(1), arg(2))
endProcedure csmAppc
/* copy csm end ******************************************************/
/* copy timing begin *************************************************/
timing: procedure expose m.
parse arg typ, c2, txt
e1 = time('E')
c1 = strip(sysvar('syscpu'))
s1 = sysvar('syssrv')
if typ == '' then
return strip(f('%c ela=%5i cpu=%8.3i su=%9i' ,
, time(), e1, c1, s1) txt)
if symbol('m.timing_ela') \== 'VAR' then
call err 'timing('typ',' c2',' txt') ohne ini'
if symbol('m.timing.typ.ela') \== 'VAR' then do
m.timing.typ.ela = 0
m.timing.typ.cpu = 0
m.timing.typ.su = 0
m.timing.typ.cnt = 0
m.timing.typ.cn2 = 0
if symbol('m.timing_types') == 'VAR' then
m.timing_types = m.timing_types typ
else
m.timing_types = typ
if symbol('m.timing_say') \== 'VAR' then
m.timing_say = 0
end
m.timing.typ.ela = m.timing.typ.ela + e1 - m.timing_ela
m.timing.typ.cpu = m.timing.typ.cpu + c1 - m.timing_cpu
m.timing.typ.su = m.timing.typ.su + s1 - m.timing_su
m.timing.typ.cnt = m.timing.typ.cnt + 1
if c2 \== '' then
m.timing.typ.cn2 = m.timing.typ.cn2 + c2
m.timing_ela = e1
m.timing_cpu = c1
m.timing_su = s1
if m.timing_say then
say left(typ, 10)right(m.timing.typ.cn2, 10) ,
'ela='m.timing.typ.ela ,
'cpu='m.timing.typ.cpu 'su='m.timing.typ.su txt
return
endProcedure timing
timingSummary: procedure expose m.
say 'timing summary' time()
do tx = 1 to words(m.timing_types)
typ = word(m.timing_types, tx)
say left(typ, 10)right(m.timing.typ.cnt, 7) ,
|| right(m.timing.typ.cn2, 7) ,
'cpu='right(m.timing.typ.cpu, 10) ,
'su='right(m.timing.typ.su, 10)
end
return
endProcedure timingSummary
/* copy timing end *************************************************/
/* copy ii begin ********* Installation Info *************************/
iiini: procedure expose m.
if m.ii_ini == 1 then
return
m.ii_ini = 1
m.ii_ds.org = ORG.U0009.B0106.MLEM43
m.ii_ds.db2 = DSN.DB2
m.ii_rz = ''
i = 'RZ0 0 T S0 RZ1 1 A S1' ,
'RZX X X X2 RZY Y Y Y2 RZZ Z Z Z2' ,
'RQ2 Q Q Q2 RR2 R R R2 RZ2 2 B S2 RZ4 4 D S4'
do while i <> ''
parse var i rz ch pl sys i
if rz <> RZ0 & rz <> RZ1 then
m.ii_rz = strip(m.ii_rz rz)
m.ii_rz2c.rz = ch
m.ii_c2rz.ch = rz
m.ii_rz2plex.rz = pl
m.ii_plex2rz.pl = rz
m.ii_rz2Sys.rz = sys
m.ii_sys2rz.sys = rz
end
i = 'DBTF T DTF DVTB V DTB DBOC C DOC DBTC B DBT DBIA A DIA' ,
'DE0G E DE0 DEVG M DEV DPXG I DPX DX0G X DX0' ,
'DPYG Y DPY DPZG N DPZ' ,
'DBOF F DOF DVBP P DBP DP2G Q DP2 DBOL O DOL DP4G U DP4'
do while i <> ''
parse var i db ch mbr i
m.ii_db2c.db = ch
m.ii_c2db.ch = db
m.ii_mbr2db.mbr = db
m.ii_db2mbr.db = mbr
m.ii_db2Elar.db = wordPos(db, 'DVTB DVBP DEVG') > 0
end
m.ii_rz2db.rz0 = 'DBTC DBIA'
m.ii_rz2db.rz1 = 'DBTF DVTB DBOC'
m.ii_rz2db.rzx = 'DE0G DEVG DX0G DPXG'
m.ii_rz2db.rzy = 'DE0G DEVG DPYG'
m.ii_rz2db.rzz = 'DE0G DEVG DPZG'
m.ii_rz2db.rq2 = 'DBOF DVBP DP2G'
m.ii_rz2db.rr2 = 'DBOF DVBP DP2G'
m.ii_rz2db.rz2 = 'DBOF DVBP DP2G'
m.ii_rz2db.rz4 = 'DP4G DBOL'
m.ii_rzDbCsmF = 'RZ2/DVBP RR2/DVBP RQ2/DVBP' ,
'RZZ/DEVG RZY/DEVG RZX/DEVG'
m.ii_rzDbCsmT = 'S25/DVBP R25/DVBP Q25/DVBP' ,
'Z25/DEVG Y25/DEVG X25/DEVG'
i = ''
do rx=1 to words(m.ii_rz)
rz = word(m.ii_rz, rx)
i = i repAll(' 'space(m.ii_rz2db.rz, 1), ' ', ' 'rz'/')
end
m.ii_rzDb = space(i, 1)
return
endProcedure iiIni
iiDS: procedure expose m.
parse arg nm
return iiGet(ds, nm)
iiMbr2DbSys: procedure expose m.
parse arg mbr
return iiGet(mbr2db, left(mbr, 3))
iiRz2C: procedure expose m.
parse arg rz
return iiGet(rz2c, rz)
iiRz2P: procedure expose m.
parse arg rz
return iiGet(rz2plex, rz)
iiRz2Dsn: procedure expose m.
parse arg rz
return overlay('Z', rz, 2)
iiDBSys2C: procedure expose m.
parse arg db
return iiGet(db2c, db)
iiSys2RZ: procedure expose m.
parse arg sys
return iiGet(sys2rz, left(sys, 2))
iiRz2Sys: procedure expose m.
parse arg rz
return iiGet(rz2sys, rz)
iiGet: procedure expose m.
parse upper arg st, key, ret
s2 = 'II_'st
if symbol('m.s2.key') == 'VAR' then
return m.s2.key
if m.ii_ini == 1 then
if abbrev(ret, '^') then
return substr(ret, 2)
else
return err('no key='key 'in II_'st, ret)
call iiIni
return iiGet(st, key, ret)
endProcedure iiGet
iiPut:procedure expose m.
parse upper arg rz '/' db
rz = strip(rz)
db = strip(db)
call vPut 'rz', rz
call vPut 'rzC', iiRz2C(rz)
call vPut 'rzP', iiRz2P(rz)
call vPut 'rzD', iiRz2Dsn(rz)
call vPut 'dbSys', db
if db <> '' then do
call vPut 'dbSysC', iidbSys2C(db)
call vPut 'dbSysElar', iiGet(db2Elar, db)
end
return 1
endProcedure iiPut
iiIxPut:procedure expose m.
parse arg ix
if ix > words(m.ii_rzDb) then
return 0
else
return iiPut(word(m.ii_rzDb, ix))
endProcedure iiIxPut
ii2RzDb:procedure expose m.
parse arg a, forCsm
r = ii2rzDbS(a, forCsm)
if r \== '' then
return r
else
return err('i}no rz/dbSys for' a)
ii2RzDbS:procedure expose m.
parse upper arg a, forCsm
if pos('/', a) > 0 then
parse var a r '/' d
else if length(a) == 2 then
parse var a r 2 d
else
parse var a d r
myRz = sysvar(sysnode)
call iiIni
if r == '' then
r2 = myRz
else if length(r) <> 1 then
r2 = r
else do
r2 = iiGet(plex2rz, r, '^')
if r2 == '' then
r2 = iiGet(c2rz, r, '^')
end
if length(d) == 4 then
d2 = d
else do
if symbol('m.ii_rz2db.r2') \== 'VAR' then
return ''
if d == '' then do
if myRz == 'RZ4' then
d2 = 'DP4G'
else if sysvar(sysnode) == 'RZX' then
d2 = 'DX0G'
else
return ''
end
else do
x = pos(d, m.ii_rz2db.r2)
if x < 1 then
return ''
d2 = substr(m.ii_rz2db.r2,
, lastPos(' ', m.ii_rz2db.r2, x)+1,4)
end
end
if r2 = myRz then
return '*/'d2
res = translate(r2'/'d2)
if forCsm \==1 | wordPos(res, m.ii_rzDbCsmF) < 1 then
return res
else
return word(m.ii_rzDbCsmT, wordPos(res, m.ii_rzDbCsmF))
endProcedure ii2RzDbS
/* copy ii end ********* Installation Info *************************/
/* copy adrIsp begin *************************************************/
/*--- address ispf with error checking ------------------------------*/
adrIsp:
parse arg ggIspCmd, ggRet
address ispexec ggIspCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr ispExec rc' rc 'in' ggIspCmd':' strip(zerrlm)
endSubroutine adrIsp
/*--- address editor with error checking ----------------------------*/
adrEdit:
parse arg ggEditCmd, ggRet
address isrEdit ggEditCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr isrEdit rc' rc 'for' ggEditCmd
endSubroutine adrEdit
/* copy adrIsp end *************************************************/
/* copy adrTso begin *************************************************/
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet --*/
adrTso:
parse arg m.tso_stmt, ggRet
call outtrap m.tso_trap.
address tso m.tso_stmt
m.tso_rc = rc
call outtrap off
if m.tso_rc == 0 then
return 0
m.tso_trap = ''
do ggXx=1 to min(7, m.tso_trap.0)
m.tso_trap = m.tso_trap'\n'strip(m.tso_trap.ggXx)
end
if m.tso_trap.0 > 7 then do
if m.tso_trap.0 > 14 then
m.tso_trap = m.tso_trap'\n............'
do ggXx=max(8, m.tso_trap.0-6) to m.tso_trap.0
m.tso_trap = m.tso_trap'\n'strip(m.tso_trap.ggXx)
end
end
m.tso_errL1 = 'adrTso rc='m.tso_rc 'stmt='m.tso_stmt
if ggRet <> '*' & wordPos(m.tso_rc, ggRet) <= 0 then
call err m.tso_errL1 m.tso_trap
return m.tso_rc
endSubroutine adrTso
/*--- format dsn from tso format to jcl format
replace any ~ by syspref or userid and necessary dots ---------*/
dsn2jcl: procedure expose m.
parse upper arg dsn ., addPrefix
if left(dsn,1) = "'" then /* only remove apostrophs */
return strip(dsn, 'b', "'")
cx = pos('~', dsn)
if cx < 1 then
if addPrefix \== 1 then
return dsn
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
if cx < 1 then
return sp'.'dsn
do until cx == 0
le = left(dsn, cx-1)
if le \== '' & right(le, 1) \== '.' & right(le, 1) \== '/' then
le = le'.'
if cx == length(dsn) then
return le || sp
else
dsn = le || sp'.' ,
|| substr(dsn, cx + 1 + (substr(dsn, cx+1, 1) == '.'))
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 lib '(' . , mbr .
if mbr = '' then
return strip(lib)
else
return strip(lib)'('mbr')'
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn '(' mbr ')'
if mbr = '' then
return arg(2)
else
return strip(mbr)
endProcedure dsnGetMbr
dsnCsmSys: procedure expose m.
parse upper arg dsn, withStar
if pos('/', dsn) < 1 then
return copies('*/', withStar \== 0)dsn
parse var dsn sys '/' d2
if sys = '' | sys = sysvar(sysnode) then
return copies('*/', withStar \== 0)d2
else
return dsn
endProcedure dsnCsmSys
/**********************************************************************
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 dd '(open)')
return /* end tsoOpen */
/*--- close dd -----------------------------------------------------*/
tsoClose: procedure expose m.
parse upper arg dd
return adrTso('execio 0 diskR' dd '(finis)')
endProcedure tsoClose
/*--- read from DD ggDD into ggSt, return false at eof --------------*/
readDD:
parse arg ggDD, ggSt, ggCnt, ggRet
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskR' ggDD '(stem' ggSt')', 2 ggRet
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- write to gg ggDD from stem ggSt, ggCnt records ----------------*/
writeDD:
parse arg ggDD, ggSt, ggCnt, ggRetDD
if ggCnt == '' then
ggCnt = value(ggst'0')
if adrTso('execio' ggCnt 'diskW' ggDD '(stem' ggSt')',
, 1 ggRetDD) = 1 then
if wordPos(1, ggRetDD) < 1 then
call err 'truncation on write dd' ggDD
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 readNxBegin
/*--- return the stem of the next line, or '' at end ----------------*/
readNx: procedure expose m.
parse arg m
if m.m.cx < m.m.0 then do
m.m.cx = m.m.cx + 1
return m'.'m.m.cx
end
m.m.buf0x = m.m.buf0x + m.m.0
m.m.cx = 1
if \ readDD(m.m.dd, 'M.'m'.', m.m.cnt) then
return ''
return m'.1'
endProcedure readNx
/*--- 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
if m.m.cx > m.m.0 then
return 'line' (m.m.buf0x + m.m.cx)':after EOF'
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 readNxEnd
/*--- 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 arg m, spec
upper spec
m.m.dsn = ''
m.m.dd = ''
m.m.disp = ''
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w,'SYSO') then
m.m.disp = w
else if abbrev('CATALOG', w, 3) | abbrev(DELETE, w, 3) then
m.m.disp = di left(w, 3)
else if abbrev(w, 'DD(') then
m.m.dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
m.m.dsn = dsn2Jcl(substr(w, 5, length(w)-5))
else if m.m.dsn == '' & (w = 'INTRDR' ,
| verify(w, ".~'/", 'm') > 0) then
m.m.dsn = dsn2jcl(w)
else if pos('(', w) > 0 then
leave
else if m.m.dd == '' then
m.m.dd = w
else
leave
end
if pos('/', m.m.dsn) < 1 then
m.m.sys = ''
else do
parse var m.m.dsn m.m.sys '/' m.m.dsn
if m.m.sys == '*' | m.m.sys = sysvar(sysnode) then
m.m.sys = ''
end
parse value subword(spec, wx) with at ':' nw
m.m.attr = strip(at)
m.m.new = strip(nw)
return m
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, dDi, dDD, timeOut
x = max(1, arg() - 1)
do rt=0
res = dsnAlloc(spec, dDi, dDD, '*')
if \ datatype(res, 'n') then
return res
if rt > timeOut & timeOut \== '' then
return err('timeout allocating' spec time() '\n'm.tso_trap)
if pos('DATA SET IS ALLOCATED TO ANOTHER', m.tso_trap) < 1 then
return err('allocating' spec'\n'm.tso_trap)
say time() 'sleep and retry alloc' spec
call sleep 1, 0
end
endProcedure dsnAllocWait
/*--- alloc a dsn or a dd
spec dsnSpec
dDi default disposition
dDD 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, dDi, dDD, retRc
return dsnAllo2(dsnSpec(dsn_alloc, spec), dDi, dDD, retRc)
/*--- alloc a dsn or a dd, dsnSpec analysed in m --------------------*/
dsnAllo2: procedure expose m.
parse upper arg m, dDi, dDD, retRc
m.tso_dsn.dd = ''
if m.m.dd \== '' then
dd = m.m.dd
else if dDD \== '' then
dd = dDD
else
dd = 'DD*'
if m.m.dsn == '' & m.m.disp == '' & m.m.attr = '' then
return dd /* already allocated only use dd */
dd = tsoDD(dd, 'a') /* ensure it is free'd by errCleanup */
if m.m.disp \== '' then
di = m.m.disp
else if dDi \== '' then
di = dDi
else
di = 'SHR'
if pos('(', m.m.dsn) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if m.m.sys == '' then
rx = tsoAlloc(m.m.dsn, dd, di, m.m.attr, m.m.new, retRc)
else
rx = csmAlloc(m.m.sys'/'m.m.dsn,dd, di, m.m.attr,m.m.new,retRc)
if rx = 0 then
return dd dd
call tsoFree dd, 1, 1 /* over careful? would tsoDD , - suffice? */
return rx
endProcedure dsnAlloc
/*--- find a free dd with prefix dd ---------------------------------*/
tsoDD: procedure expose m.
parse upper arg dd, f, noErr
if m.err_ini \== 1 then
call errIni /* initialises tso_ddAll */
if f == '-' then do
ax = wordPos(dd, m.tso_ddAll)
if ax > 0 then
m.tso_ddAll = delWord(m.tso_ddAll, ax, 1)
else if noErr \== 1 then
call err 'tsoDD dd' dd 'not used' m.tso_ddAll
end
else if f <> 'A' then
call err 'tsoDD bad fun' f
else do
if right(dd, 1) = '*' then do
d0 = left(dd, length(dd)-1) || m.err_screen
dd = d0
do dx=1 while wordPos(dd, m.tso_ddAll) > 0
dd = d0 || dx
end
end
else if pos('?', dd) > 0 then
dd = repAll(dd, '?', m.err_screen)
if wordPos(dd, m.tso_ddAll) < 1 then
m.tso_ddAll = strip(m.tso_ddAll dd)
m.tso_dsn.dd = ''
m.tso_dsOrg.dd = ''
end
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_dsn.dd = ''
else if na \== 'INTRDR' then do
c = c "DSN('"na"')"
m.tso_dsn.dd = na
end
else do
c = c "sysout(*) writer(intRdr)"
m.tso_dsn.dd = '*intRdr'
end
if wordPos(disp, 'NEW MOD') > 0 & nn \== '' then
c = c dsnCreateAtts(,nn)
if adrTso(c rest, '*') = 0 then
return 0
if pos('IKJ56246I', m.tso_trap) > 0 then
if pos('TED, FILE IN USE', m.tso_trap) > 0 then do
/* IKJ56246I DATA SET A540769.WK.REXX NOT ALLOCATED, FILE IN USE*/
say 'tsoAlloc dd' dd 'already in use:' substr(m.tso_trap, 3)
say '.... trying to free'
call tsoFree dd, 1
say '.... retrying to allocate' c rest
if adrTso(c rest, '*') = 0 then
return 0
end
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& pos('IKJ56228I', m.tso_trap) > 0 ,
& pos(' NOT IN CATALOG ', m.tso_trap) > 0 then do
/* IKJ56228I DATA SET A540769.XY.REXX NOT IN CATALOG OR CATAL*/
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
if pos('*', retRc) < 1 & wordPos(m.tso_rc, retRc) < 1 then
call err 'tsoAlloc rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
call sayNl 'tsoAlloc rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
return m.tso_rc
endProcedure tsoAlloc
dsnLikeAtts: procedure expose m.
parse upper arg dsn, isFile
if isFile then do
ddDsn = m.tso_dsn.dsn
if lastPos('/', m.tso_dsn.dsn, 4) < 1 then
return tsoLikeAtts(dsn, 1)
dsn = m.tso_dsn.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, tryClose, silent
do dx=1 to words(ddList)
dd = word(ddList, dx)
if adrTso('free dd('dd')', '*') <> 0 then do
if pos('IKJ56861I', m.tso_trap) > 0 & tryClose == 1 then
if pos('NOT FREED, DATA SET IS OPEN', m.tso_trap),
> 0 then do
/* IKJ56861I FILE A1 NOT FREED, DATA SET IS OPEN */
say 'dataset open:' substr(m.tso_trap, 3)
say '.... trying to close'
if adrTso('execio 0 diskR' dd '(finis)', '*') = 0 then
call adrTso 'free dd('dd')', '*'
end
if m.tso_rc \== 0 then
if silent \== 1 ,
| \ (pos('IKJ56247I FILE',m.tso_trap) > 0 ,
& pos('NOT FREED, IS NOT ALLOCATED' ,
, m.tso_trap) > 0) then
call sayNl m_tso_errL1 m.tso_trap
end
call tsoDD dd, '-', 1
end
return 0
endProcedure tsoFree
dsnCreateAtts: procedure expose m.
parse arg dsn, atts
res = ''
if dsn \== '' & \ abbrev(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 = 32755 /* 32756 gives bad values in ListDSI | */
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 'dsnCreateAtt bad :' a1
end
aU = ' 'translate(atts)
hasOrg = pos(' DSORG(', aU) > 0 | pos(' DSNTYPE(', aU) > 0
hasMbr = pos('(', dsn) > 0
if hasMbr & \ hasOrg then
atts = atts 'dsorg(po) dsntype(library)'
if hasOrg | hasMbr then do
ww = DSORG DSNTYPE
do wx=1 to words(ww)
do forever
cx = pos(' 'word(ww, wx)'(', ' 'translate(res))
if cx == 0 then
leave
cy = pos(')', res, cx)
res = delstr(res, cx, cy+1-cx)
end
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(1, 50) cylinders'
return res
endProcedure dsnCreateAtts
/*--- 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
tsoDsiMaxl:
rc = listDsi(arg(1) 'FILE')
if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
return SYSLRECL - 4 * abbrev(sysRecFm, 'V')
endSubroutine tsoDsiMaxL
/* copy adrTso end ***************************************************/
/* copy csv begin ****************************************************/
/**** csvRdr reads a text file, in csv format
and creates a class from column head in first line
csvRdr#jRead returns the create objects ************************/
csv2ObjRdr: procedure expose m.
parse arg rdr, opt
return oNew(jClassNew1sRdr('Csv2ObjRdr', 'm.m.opt = arg2' ,
, 'call csv2ObjBegin m' ,
, 'call csv2Obj m, rStem, $i'), rdr, opt)
csv2ObjBegin: procedure expose m.
parse arg m
m.m.class = ''
return m
csvRdrOpenFinish: procedure expose m.
parse arg m, ff
if m.m.opt == 'u' then
upper ff
m.m.class = classNew("n* CsvF u f%v" ff)
call classMet m.m.class, 'new'
call classMet m.m.class, 'oFldD'
return m
endProcedure csvRdrOpenFinish
csv2Obj: procedure expose m.
parse arg m, wStem, li
if m.m.class == '' then
return csvRdrOpenFinish(m, space(translate(li, ' ', ','), 1))
call mAdd wStem, csv2O(mNew(m.m.class), m.m.class, li)
return
endProcedure csv2Obj
/*--- convert csv line into object of class cl ----------------------*/
csv2o: procedure expose m.
parse arg m, cl, src
ff = classMet(cl, 'oFldD')
s = csv_2o_SCAN
call scanSrc s, src
do fx=1 to m.ff.0
f1 = m || m.ff.fx
if scanString(s, '"') then
m.f1 = m.s.val
else do
call scanUntil s, ','
m.f1 = m.s.tok
end
if scanEnd(s) then
leave
if \ scanLit(s, ',') then
call scanErr s, ',' expected
end
return csv2Ofinish(m, cl, fx+1)
endProcedure csv2o
/*--- clear remaining fields and stems and mutate -------------------*/
csv2Ofinish: procedure expose m.
parse arg m, cl, fy
call classClearStems cl, oMutate(m, cl)
do fx=fy to m.cl.fldd.0
f1 = m || m.cl.fldd.fx
m.f1 = ''
end
return m
endProcedure csv2Ofinish
/**** csvWordRdr: similar to csvRdr, but input line format
are quoted or unquoted words ****************************/
csvWordRdr: procedure expose m.
parse arg rdr, opt
return oNew(jClassNew1sRdr('CsvWordRdr', 'm.m.opt = arg2' ,
, 'call csvWordBegin m' ,
, 'call csvWord m, rStem, $i'), rdr, opt)
csvWordBegin: procedure expose m.
parse arg m
m.m.class = ''
return m
csvWord: procedure expose m.
parse arg m, wStem, li
if m.m.class == '' then
return csvRdrOpenFinish(m, space(li, 1))
call mAdd wStem, csvWord2O(mNew(m.m.class), m.m.class, li)
return
endProcedure csvWord
csvWord2O: procedure expose m.
parse arg m, cl, src
ff = cl'.FLDD'
s = csv_2o_SCAN
call scanSrc s, src
do fx=1 to m.ff.0
call scanSpaceOnly s
if \ scanWord(s) then
leave
f1 = m || m.ff.fx
m.f1 = m.s.val
end
return csv2Ofinish(m, cl, fx)
endProcedure csvWord2O
/**** csvColRdr: similar to csvRdr, but input format
are fixed width columns *********************************/
/*--- create object for fixLenColumns format ------------------------*/
csvColRdr: procedure expose m.
parse arg rdr, opt
return oNew(jClassNew1sRdr('CsvColRdr', 'm.m.opt = arg2' ,
, 'call csvColBegin m' ,
, 'call csvCol m, rStem, $i'), rdr, opt)
csvColBegin: procedure expose m.
parse arg m
m.m.class = ''
return m
csvCol: procedure expose m.
parse arg m, wStem, li
if m.m.class == '' then do
s = scanSrc(csv_colOpen, li)
ff = ''
do cx=1
call scanWhile s, ' <>'
if scanEnd(s) then
leave
call scanUntil s, ' <>'
ff = ff m.s.tok
call scanSpaceOnly s
m.m.pEnd.cx = m.s.pos + (scanLook(s, 1) == '>')
end
m.m.pEnd.0 = cx-1
call csvRdrOpenFinish m, ff
return
end
call mAdd wStem, csvCol2O(m, mNew(m.m.class), m.m.class, li)
return
endProcedure csvCol
csvCol2O: procedure expose m.
parse arg oo, m, cl, src
ff = cl'.FLDD'
cx = 1
do fx=1 to m.oo.pEnd.0 - 1
f1 = m || m.ff.fx
m.f1 = strip(substr(src, cx, m.oo.pEnd.fx - cx))
cx = m.oo.pEnd.fx
end
f1 = m || m.ff.fx
m.f1 = strip(substr(src, cx))
return csv2Ofinish(m, cl, fx+1)
endProcedure csvCol2O
/*--- csv4obj add a header line
and objects of the same class in csv format ---------------*/
csv4ObjRdr: procedure expose m.
parse arg rdr, opt
return oNew(jClassNew1sRdr('Csv4ObjRdr', ,
, 'call csv4ObjBegin m' ,
, 'call csv4Obj m, rStem, $i'), rdr, opt)
csv4ObjBegin: procedure expose m.
parse arg m
m.m.class = ''
return m
endProcedure csv4ObjBegin
csv4Obj: procedure expose m.
parse arg m, wStem, o
if o == '' then do
if m.m.class \== '' then
call mAdd wStem, ''
return
end
cl = objClass(o)
if cl \== m.m.class then do
if m.m.class \== '' then
return err('class('o')='cl '<>' m.m.class)
m.m.class = cl
ff = classMet(cl, 'oFlds')
if m.ff.0 < 1 then
return err('no fields in' cl)
t = ''
do fx=1 to m.ff.0
t = t','m.ff.fx
end
call mAdd wStem, substr(t, 2)
m.m.oFldD = classMet(cl, 'oFldD')
end
call mAdd wStem, csv4O(o, m.m.oFldD, 0)
return
endProcedure csv4Obj
/*--- return the csv string for an object ---------------------------*/
csv4o: procedure expose m.
parse arg o, ff, hasNull, oNull
res = ''
do fx=1 to m.ff.0
of1 = o || m.ff.fx
v1 = m.of1
if hasNull & v1 == oNull then
res = res','
else if pos(',', v1) > 0 | pos('"', v1) > 0 | v1 == '' then
res = res','quote(v1, '"')
else
res = res','v1
end
return substr(res, 2)
endProcedure csv4o
/*--- fill empty fieldds with value of previous row -----------------*/
csvE2PrevRdr: procedure expose m.
parse arg rdr, opt
return oNew(jClassNew1sRdr('CsvE2PrevRdr', 'm.m.opt = arg2' ,
, "m.m.prev = ''" ,
, 'call csvE2Prev m, rStem, $i'), rdr, opt)
/*--- externalize o and add to wStem --------------------------------*/
csvE2Prev: procedure expose m.
parse arg m, wStem, o
if o == '' then
return
ff = oFldD(o)
hasData = 0
do fx=1 to m.ff.0
f1 = o || m.ff.fx
if m.f1 \== '' then do
hasData = 1
iterate
end
if m.m.prev == '' then
iterate
p1 = m.m.prev || m.ff.fx
m.f1 = m.p1
end
if \ hasData then
return
call mAdd wStem, o
m.m.prev = o
return
endProcedure csvE2Prev
csvColBegin: procedure expose m.
/**** csvExt externalises object into csvExt format
including object cycles and classes
csv+ protocoll, first field contains meta info ---------------------
v,text null or string
w,text w-string
c name classAdr,flds class definition
b name classAdr, class forward declaration
m name adr,text method
o classAdr adr,flds object definition and output
d classAdr adr,flds object definition wihtout output
f classAdr adr, object forward declaration
r adr, reference = output of already defined objects
* text unchanged text including ' " ...
* flds csv flds
**********************************************************************/
csvExtRdr: procedure expose m.
parse arg rdr, opt
return oNew(jClassNew1sRdr('CsvExtRdr', ,
, 'call csvExtBegin m',
, 'call csvExt m, rStem, $i'), rdr, opt)
csvExtBegin: procedure expose m.
parse arg m
d = m'.DONE'
call mapReset d, 'K'
call mapPut d, m.class_class, 'class'
call mapPut d, m.class_v, 'v'
call mapPut d, m.class_w, 'w'
call mapPut d, m.class_o, 'o'
return m
endProcedure csvExtBegin
/*--- externalize o and add to wStem --------------------------------*/
csvExt: procedure expose m.
parse arg m, wStem, o
c = objClass(o)
if c == m.class_W then
return mAdd(wStem, 'w,'substr(o, 2))
if oKindOfString(o) then
return mAdd(wStem, 'v,'o)
if c == m.class_class then
call csvExtClass m, wStem, o
if m.m.done.o == 0 then do
m.m.done.o = 1
call mAdd wStem, 'f' csvExtClass(m, wStem, c) o','
end
if symbol('m.m.done.o') == 'VAR' then
return mAdd(wStem, 'r' o',')
return mAdd(wStem, 'o' c o || csvExtObjTx(m, wStem, o))
endProcedure csvExt
csvExtObjTx: procedure expose m.
parse arg m, wStem, o
call mapAdd m'.DONE', o, 0
c = objClass(o)
if c \== m.class_class & pos(m.m.done.c, 12) < 1 then
call csvExtClass m, wStem, c
ff = classMet(c, 'oFldD')
r = ''
do fx=1 to m.ff.0
c1 = m.ff.fx.class
f1 = o || m.ff.fx
v1 = m.f1
if m.c1 == 'r' then do
c2 = objClass(v1)
if c2 == m.class_S then do
v1 = s2o(v1)
end
else if \ (c2 == m.class_N | c2 == m.class_W) then do
if m.m.done.v1 == 0 then do
m.m.done.v1 = 1
call mAdd wStem, 'f' c2 v1','
end
if symbol('m.m.done.v1') \== 'VAR' then
call mAdd wStem, 'd' c2 v1 ,
|| csvExtObjTx(m, wStem, v1)
end
end
if pos(',', v1) > 0 | pos('"', v1) > 0 then
r = r','quote(v1, '"')
else
r = r','v1
end
m.m.done.o = 2
return r
endProcedure csvExtObjTx
csvExtClass: procedure expose m.
parse arg m, wStem, c
res = mapGet(m'.DONE', c, '-')
if res == 0 then do
m.m.done.c = 1
call mAdd wStem, 'b' if(m.c.name == '', '-', m.c.name) c','
return c
end
if res == 1 then
return c
if res \== '-' then
return res
call mapAdd m'.DONE', c, 0
ty = m.c
res = if(m.c.name == '', '-', m.c.name) c
if ty == 'u' then do
res = 'c' res',u'
if m.c.0 > 0 then do
r = ''
do cx=1 to m.c.0
r = r','csvExtClassEx(m, wStem, m.c.cx)
end
res = res substr(r, 2)
end
end
else if ty == 'm' & m.c.0 == 0 then
res = 'm' res','m.c.met
else
res = 'c' res','csvExtClassEx(m, wStem, c)
call mAdd wStem, res
call mapPut m'.DONE', c, c
return c
endProcedure csvExtClass
csvExtClassEx: procedure expose m.
parse arg m, wStem, c
res = ''
ch = c
do forever
g = mapGet(m'.DONE', c, '-')
if g \== '-' then
return strip(res g)
else if m.ch == 'u' | m.ch == 'm' then
return strip(res csvExtClass(m, wStem, ch))
else if \ (length(m.ch) == 1 & pos(m.ch, 'fscr') >= 1,
& m.ch.0 <= 1 & m.ch.met == '') then
return err('csvExtClassEx bad cl' ch 'ty='m.ch,
'name='m.ch.name '.0='m.ch.0 'met='m.ch.met)
res = strip(res m.ch m.ch.name)
if m.ch.0 = 0 then
return res
ch = m.ch.1
end
endProcedure csvExtClassEx
/*--- convert variable len recs to fixLen
& = continuation, | end (to protect ' &|') -------------------*/
csvV2FRdr: procedure expose m.
parse arg rdr, arg
return oNew(jClassNew1sRdr('CsvV2FRdr', 'm.m.maxLen = arg2',
, 'call csvV2FBegin m, m.m.maxLen',
, 'call csvV2F m, rStem, $i'), rdr, arg)
csvV2FBegin: procedure expose m.
parse arg m, maxL
m.m.maxLen = word(maxL 55e55, 1)
return m
endProcedure csvV2FBegin
csvV2F: procedure expose m.
parse arg m, wStem, line
if line \== '' & pos(right(line, 1), ' &|') > 0 then
line = line'|'
if length(line) <= m.m.maxLen then
return mAdd(wStem, line)
do cx=1 by m.m.maxLen-1 to length(line)-m.m.maxLen
call mAdd wStem, substr(line, cx, m.m.maxLen-1)'&'
end
return mAdd(wStem, substr(line, cx))
endProcedure csvV2F
/*--- f2v fixLen to variable len lines: &=continuation |=endMark ----*/
csvF2VRdr: procedure expose m.
parse arg rdr, arg
return oNew(jClassNew1sRdr('CsvF2VRdr', ,
, 'call csvF2VBegin m' ,
, 'call csvF2V m, rStem, $i' ,
, 'call csvF2VEnd m'), rdr, arg)
csvF2VBegin: procedure expose m.
parse arg m
m.m.strt = ''
return m
endProcedure csvF2VBegin
csvF2V: procedure expose m.
parse arg m, wStem, aLi
li = strip(aLi, 't')
if right(li, 1) == '&' then do
m.m.strt = m.m.strt || left(li, length(li) - 1)
return
end
if right(li, 1) == '|' then
call mAdd wStem, m.m.strt || left(li, length(li) - 1)
else
call mAdd wStem, m.m.strt || li
m.m.strt = ''
return
endProcedure csvF2V
csvF2VEnd: procedure expose m.
parse arg m
if m.m.strt \== '' then
return err("csvF2vEnd but strt='"m.m.strt"'")
return m
endProcedure csvF2VEnd
/*--- internalize objects in ext format -----------------------------*/
csvIntRdr: procedure expose m.
parse arg rdr, opt
return oNew(jClassNew1sRdr('CsvIntRdr', ,
, 'call csvIntBegin m',
, 'call csvInt m, rStem, $i'), rdr, opt)
csvIntBegin: procedure expose m.
parse arg m
m.m.forward = ''
d = m'.DONE'
call mapReset d, 'K'
return
endProcedure csvIntBegin
csvInt: procedure expose m.
parse arg m, wStem, line
parse var line hd ',' rest
parse var hd h1 h2 h3 hr
d = m'.DONE'
if pos(h1, 'vwr') > 0 then do
if m.m.forward \== '' then
return err('csvInt: forward='m.m.forward 'not empty:' line)
if h1 == 'v' & h2 == '' then
return mAdd(wStem, rest)
if h1 == 'w' & h2 == '' then
return mAdd(wStem, m.o_escW || rest)
if h1 \== 'r' | h2 == '' | h3 \== '' | rest \== '' then
return err('csvInt: bad line' line)
r = mapGet(d, h2, '')
if r == '' then
return err('csvInt: undefined reference' line)
return mAdd(wStem, r)
end
if h3=='' | hr\=='' | length(h1)\==1 | pos(h1, 'bcmdfo') < 1 then
return err('csvInt: bad line' line)
if h1 == 'b' | h1 == 'f' then do
if symbol('m.d.h3') == 'VAR' then
return err('csvInt: forward already defined:' line)
if h1 == 'b' then do
if h2 == '-' then
h2 = 'CsvForward'
n = classNew('n' h2 || (m.class.0+1) 'u')
m.n.met = h2'*'
end
else do
cl = mapGet(d, h2, '')
if cl == '' then
return err('csvInt: undefined class:' line)
n = mNew(cl)
end
call mapAdd d, h3, n
m.m.forward = m.m.forward h3
return
end
if h1 == 'm' then do
n = classNew('m' h2 rest)
return mapAdd(d, h3, n)
end
if h1 == 'c' then do
rx = 1
rr = ''
do while rx <= length(rest)
ry = pos(',', rest, rx+1)
if ry < 1 then
ry = length(rest)+1
r1 = substr(rest, rx, ry-rx)
rI = wordIndex(r1, words(r1))
if rI == 1 & abbrev(r1, ',') then
rI = 2
rL = strip(substr(r1, rI))
if length(rL) \== 1 | pos(rL, 'vwor') < 1 then do
rL = mapGet(d, rL, '')
if rL == '' then
return err('csvInt undef class' rL 'line:' line)
end
rr = rr || left(r1, rI-1)rL
rx = ry
end
end
fx = wordPos(h3, m.m.forward)
if fx > 0 then do
m.m.forward = strip(delWord(m.m.forward, fx, 1))
n = mapGet(d, h3)
if h1 == 'c' then do
call classNew 'n=' m.n.name rr
call classMet n, 'new'
return
end
cl = 'CLASS'substr(n, 2, pos('.', n, 3)-2)
if cl \== mapGet(d, h2) then
return err('csvInt: forward class' cl 'mismatches' line)
end
else do
if mapHasKey(m, d, h3) then
return err('already defined:' line)
if h1 == 'c' then do
do while datatype(right(h2, 1), 'n')
h2 = left(h2, length(h2)-1)
end
if h2 == '-' then
h2 = 'CsvForward'
s = ''
cl = classNew(copies('n*' h2' ', h2 \== '-')rr)
call classMet cl, 'new'
return mapAdd(d, h3, cl)
end
cl = mapGet(d, h2, '')
if cl == '' then
return err('undefined class:' line)
n = mNew(cl)
call mapAdd d, h3, n
end
call csv2o n, cl, rest
ff = classFldD(cl)
do fx=1 to m.ff.0
f1 = n || m.ff.fx
c1 = m.ff.fx.class
if m.c1 \== 'r' | m.f1 == '' | abbrev(m.f1, m.o_escW) then
iterate
t1 = mapGet(d, m.f1, '')
if t1 == '' then
return err('missing reference' fx m.f1 'in' line)
m.f1 = t1
end
if h1 == 'o' then do
if m.m.forward \== '' then
call err 'forward not empty:' line
call mAdd wStem, n
end
return
endProcedure csvInt
/* copy csv end ****************************************************/
/* copy j begin *******************************************************
the j framework
jReset
jOpen
jClose
jRead
jWrite
**********************************************************************/
jRead: procedure expose m.
parse arg m
ix = m.m.readIx + 1
if ix > m.m.buf.0 then do
if m.m.jReading \== 1 then
return err('jRead('m') but not opened r')
if \ jReadBuf(m, m'.BUF') then
return 0
ix = 1
end
m.m.readIx = ix
m.m = m.m.buf.ix
return 1
endProcedure jRead
jReadBuf: procedure expose m.
parse arg m, rStem
interpret objMet(m, 'jRead')
m.m.bufI0 = m.m.bufI0 + m.rStem.0
return m.rStem.0 > 0
endProcedure jReadBuf
jReadVar: procedure expose m.
parse arg m, var
if arg() > 2 then call err '??? old interface' / 0
if \ jRead(m) then
return 0
m.var = m.m
return 1
endProcedure jReadVar
/*--- read next NonEmpty line ---------------------------------------*/
jReadNE: procedure expose m.
parse arg m
do while jRead(m)
if m.m <> '' then
return 1
end
return 0
endProcedure jReadNE
/*--- read next lines to stem ---------------------------------------*/
jReadSt: procedure expose m.
parse arg m, st
sx = 0
if m.m.readIx >= m.m.buf.0 then do
if jReadBuf(m, st) then
return 1
m.st.0 = 0
return 0
end
do rx = m.m.readIx+1 to m.m.buf.0
sx = sx + 1
m.st.sx = m.m.buf.rx
end
m.m.readIx = m.m.buf.0
m.st.0 = sx
return sx > 0
endProcedure jReadSt
jReadObRe: procedure expose m.
parse arg m
if arg() > 1 then call err '??? old interface' / 0
if jRead(m) then
return m.m
else
return ''
endProcedure jReadObRe
jReadO: procedure expose m.
parse arg m
if arg() > 1 then call err '??? old interface' /0
return jRead(m)
endProcedure jReadO
jWrite: procedure expose m.
parse arg m, line
ix = m.m.buf.0 + 1
m.m.buf.0 = ix
m.m.buf.ix = line
if ix > m.m.bufMax then
call jWriteBuf m
return
endProcedure jWrite
/*--- write the buf to destination ----------------------------------*/
jWriteBuf: procedure expose m.
parse arg m
if \ m.m.jWriting then
return err('jWrite('m') but not opened w')
wStem = m'.BUF'
interpret objMet(m, 'jWriteMax')
return
endProcedure jWriteBuf
jWriteSt: procedure expose m.
parse arg m, qStem
interpret objMet(m, 'jWriteSt')
return
endProcedure jWriteSt
jPosBefore: procedure expose m.
parse arg m, lx
interpret objMet(m, 'jPosBefore')
return m
endProcedure jPosBefore
jWriteAll: procedure expose m.
parse arg m, rdr
rdr = o2file(rdr)
met = objMet(m, 'jWriteAll')
if \ m.m.jWriting then
return err('jWriteAll('m',' rdr') but not opened w')
interpret met
return
endProcedure jWriteAll
jWriteNow: procedure expose m.
parse arg m, rdr
rdr = o2file(rdr)
interpret objMet(m, 'jWriteNow')
return
endProcedure jWriteNow
jCat: procedure expose m.
parse arg opt m
if m = '' then do
m = opt
opt = m.j.cWri
end
call jOpen m, opt
do ax=2 to arg()
call jWriteAll m, arg(ax)
end
call jClose m
return m
endProcedure jCat
jWriteNowImpl: procedure expose m.
parse arg m, rdr
call jOpen rdr, m.j.cRead
do while jRead(rdr)
if m.rdr.readIx == 1 then do
call jWriteSt m, rdr'.BUF'
m.rdr.readIx = m.rdr.buf.0
end
else
call jWrite m, m.rdr
end
call jClose rdr
return
endProcedure jWriteNow
/*--- reset JRW: fail if open, initialise ---------------------------*/
jReset0: procedure expose m.
parse arg m
if m.m.jReading == 1 | m.m.jWriting == 1 then
return err('still open jReset0('m')')
m.m.jUsers = 0
m.m.buf.0 = 0
m.m.wriMax = 0
call jCloseSet m
return m
endProcedure jReset0
jCloseSet: procedure expose m.
parse arg m
m.m.jReading = 0
m.m.jWriting = 0
m.m.readIx = 55e55
m.m.bufMax = -55e55
return m
endProcedure jCloseSet
jReset: procedure expose m.
parse arg m, arg, arg2
interpret objMet(m, 'oResetNoMut')
return m
endProcedure jReset
jOpen: procedure expose m.
parse arg m, opt
met = objMet(m, 'jOpen')
oUsers = m.m.jUsers
if opt = m.j.cRead then do
if m.m.jReading then
nop
else if m.m.jWriting then
return err('already opened for writing jOpen('m',' opt')')
else do
m.m.readIx = 0
m.m.bufI0 = 0
interpret met
m.m.jReading = 1
end
end
else if \ abbrev('>>', opt, 1) then do
return err('bad option' opt 'in jOpen('m',' opt')')
end
else do
if m.m.jWriting then
nop
else if m.m.jReading then
return err('already opened for reading jOpen('m',' opt')')
else do
m.m.bufI0 = 0
m.m.bufMax = m.m.wriMax
interpret met
m.m.jWriting = 1
end
end
m.m.jUsers = oUsers + 1
return m
endProcedure jOpen
/*--- close JRW flush buffer if writing ... -------------------------*/
jClose: procedure expose m.
parse arg m
oUsers = m.m.jUsers
if oUsers = 1 then do
if m.m.jWriting then do
wStem = m'.BUF'
interpret objMet(m, 'jWriteFlu')
end
interpret objMet(m, 'jClose')
call jCloseSet m
end
else if oUsers < 1 then
call err 'jClose' m 'but already closed'
m.m.jUsers = oUsers - 1
return m
endProcedure jClose
/*--- force physical close for errCleanup ---------------------------*/
jCloseClean: procedure expose m.
parse arg m
if m.m.jUsers = 0 then
return
m.m.jUsers = 1
return jClose(m)
endProcedure jCloseClean
/*--- cat the lines of the file together, with mid between lines,
fail if not all lines are strings -------------------*/
jCatLines: procedure expose m.
parse arg m, fmt
if abbrev(fmt, '-sql') then do
call err '-sql in jCatLines'
end
f2 = '%##fCatFmt' fmt
call jOpen m, m.j.cRead
if \ jRead(m) then do
call jClose m
return f(f2'%#0')
end
res = f(f2'%#1', m.m)
do while jRead(m)
res = res || f(f2, m.m)
end
call jClose m
return res || f(f2'%#r')
endProcedure jCatLines
jIni: procedure expose m.
if m.j.ini == 1 then
return
m.j.ini = 1
m.j.cRead = '<'
m.j.cWri = '>'
m.j.cApp = '>>'
call classIni
am = "call err 'call of abstract method"
cLa= classNew('n JRWLazy u LazyRun', 'm',
, "oReset" m.class_lazyRetMutate,
"'call jReset0 m;' classMet(cl, 'jReset')",
, "jWriteMax return classMet(cl, 'jWrite') '; m.m.buf.0 = 0'" ,
, "jWriteFlu return classMet(cl, 'jWriteMax')",
, "jWriteSt return 'if m.m.buf.0 <> 0" ,
"| m.qStem.0 < m.m.bufMax / 2 then do;" ,
"call mAddSt m''.BUF'', qStem;" ,
"if m.m.buf.0 > m.m.bufMax then do;'" ,
"classMet(cl, 'jWriteMax')'; end; end;",
"else do; wStem = qStem;' classMet(cl, 'jWrite') ';end'",
)
c1 = classNew('n JRW u ORun, f JREADING v, f JWRITING v', 'm',
, "METHODLAZY" cLa,
, "jReset" ,
, "jRead" am "jRead('m')'" ,
, "jWrite" am "jWrite('m',' wStem')'" ,
, "jWriteAll call jWriteNowImpl m, rdr",
, "jWriteNow call jWriteNowImpl m, rdr",
, "jOpen" am" jOpen('m',' opt')'" ,
, "jClose" ,
, "oRun call pipeWriteAll m",
, "o2String return jCatLines(m, fmt)",
, "o2File return m")
call classNew 'n JRWDelegOC u JRW', 'm',
, "jReset m.m.deleg = arg;" ,
, "jOpen call jOpen m.m.deleg, opt" ,
, "jClose call jClose m.m.deleg"
call classNew 'n JRWDeleg u JRWDelegOC', 'm',
, "jRead if \ jReadSt(m.m.deleg, rStem) then return 0",
, "jWrite call jWriteSt m.m.deleg, wStem" ,
am = "call err 'call errObject"
call classNew 'n JRWErr u JRW', 'm',
, "jWriteAll" er "jWriteAll 'm', rdr'",
, "jWriteNow" er "jWriteNow 'm', 'rdr'",
, "jClose" er "jClose 'm'"
call classNew 'n JSay u JRW', 'm',
, "jWrite do wx=1 to m.wStem.0;say o2Text(m.wStem.wx,157);end",
, "jOpen if \ abbrev(opt, m.j.cWri) then",
"call err 'can only write JSay#jOpen('m',' opt')';"
call classNew 'n JRWEof u JRW', 'm',
, "jRead return 0",
, "jOpen if opt \=='<' then call err 'JRWEof#open('m',' opt')'"
m.j.in = jOpen(oNew('JRWEof'), m.j.cRead)
m.j.out = jOpen(oNew('JSay'), '>')
m.j.say = m.j.out
m.j.errRead = "return err('jRead('m') but not opened r')"
m.j.errWrite = "return err('jWrite('m',' line') but not opened w')"
call classNew "n JBuf u JRW, f BUF s r", "m",
, "jReset call jBufReset m, arg, arg2" ,
, "jOpen call jBufOpen m, opt",
, "jRead return 0",
, "jWriteMax call err 'buf overflow'",
, "jWriteFlu ",
, "jWriteSt call mAddSt m'.BUF', qStem" ,
, "jWrite call mAddSt m'.BUF', wStem;" ,
"if m.m.buf.0 > m.m.bufMax then call err 'buf overflow'",
, "jPosBefore m.m.readIx = m.m.readIx+0;m.m.readIx = lx-1"
return
endProcedure jIni
/*--- return a JRW from rdr or in -----------------------------------*/
in2File: procedure expose m.
parse arg m
interpret objMet(m, 'in2File')
return err('in2File did not return')
endProcedure in2File
/* jstr is part of out interface --> in2Str */
in2Str: procedure expose m.
parse arg m, fmt
interpret objMet(m, 'in2Str')
return err('in2Str did not return')
endProcedure in2Str
in2Buf: procedure expose m.
parse arg m
interpret objMet(m, 'in2Buf')
return err('in2Buf did not return')
endProcedure in2Buf
in: procedure expose m.
if arg() > 0 then call err '??? old interface'
r = m.j.in
m.in_ret = jRead(r)
m.in = m.r
return m.in_ret
endProcedure in
inVar: procedure expose m.
parse arg var
return jReadVar(m.j.in, var)
endProcedure inVar
inObRe: procedure expose m.
if arg() > 0 then call err '??? old interface'
return jReadObRe(m.j.in)
endProcedure inObRe
inO: procedure expose m.
if arg() > 0 then call err '??? old interface'
return in()
endProcedure inO
out: procedure expose m.
parse arg line
call jWrite m.j.out, line
return 0
endProcedure out
/*--- 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
outX: procedure expose m.
parse arg line
if symbol('m.tst_m') \== 'VAR' then
call jWrite m.j.out, line
else
call tstOut m.tst_m, line
return 0
endProcedure out
outO: procedure expose m.
parse arg arg
call out arg
return
endProcedure outO
/*--- jBuf: buffer read or write (supports datataypes) --------------*/
jBuf: procedure expose m.
m = oNew(m.class_jBuf) /* calls jBufReset */
do ax=1 to arg()
m.m.buf.ax = arg(ax)
end
m.m.buf.0 = ax-1
return m
endProcedure jBuf
/*--- jText: write text to deleg ------------------------------------*/
jText: procedure expose m.
parse arg rdr, opt
return oNew(jClassNew1sRdr('JText', 'm.m.maxL = arg2' , ,
, 'call mAdd rStem, o2Text($i, m.m.maxL)'),rdr, opt)
jBufReset: procedure expose m.
parse arg m
call oMutate m, m.class_jBuf
do ax=1 to arg() - 1
m.m.buf.ax = arg(ax+1)
end
m.m.buf.0 = ax-1
m.m.wriMax = 1e30
return m
endProcedure jBufReset
jBufOpen: procedure expose m.
parse arg m, opt
if opt == m.j.cRead then do
m.m.readIx = 0
return m
end
if opt == m.j.cWri then
m.m.buf.0 = 0
else if opt \== m.j.cApp then
call err 'jBufOpen('m',' opt') with bad opt'
return m
endProcedure jBufOpen
jBufCopy:
parse arg rdr
b = jOpen(jBuf(), m.j.cWri)
call jWriteNow b, rdr
return jClose(b)
endProcedure jBufCopy
jSingle: procedure expose m.
parse arg m
call jOpen m, '<'
one = jRead(m)
two = jRead(m)
call jClose m
if \ one then
if arg() < 2 then
call err 'empty file in jSingle('m')'
else
return arg(2)
if two then
call err '2 or more recs in jSingle('m')'
return m.m
endProcedure jSingle
/*--- lazily create a reader class for 1s protocol ------------------*/
jClassNew1sRdr: procedure expose m.
parse arg cla, reset, op, rd, cls
return classNew('n?' cla 'u JRWDelegOC', 'm',
, 'jReset m.m.delegSp = in2file(arg);' reset ,
, 'jOpen m.m.deleg = in2file(m.m.delegSp);' ,
'call jOpen m.m.deleg, opt;' op ,
, 'jRead if \ jRdr1sRead(m, rStem,' ,
quote(repAll(rd, '$i', 'm.dg.buf.ix'), '"'),
') then return 0' ,
, 'jWrite call jRdr1sWrite m, wStem,' ,
quote(repAll(rd, '$i', 'm.wStem.wx'), '"'),
, 'jClose' cls||left(';', cls <> '') 'call jClose m.m.deleg')
endProcedure jNewClassRdr1s
jRdr1sRead: procedure expose m.
parse arg m, rStem, add1s
m.rStem.0 = 0
dg = m.m.deleg
do while jRead(dg)
do ix = m.dg.readIx to m.dg.buf.0
interpret add1s
end
m.dg.readIx = ix - 1
if m.rStem.0 >= 100 then
return 1
end
return m.rStem.0 > 0
endProcedure jRdr1sRead
jRdr1sWrite: procedure expose m.
parse arg m, wStem, add1s
dg = m.m.deleg
rStem = dg'.BUF'
do wx=1 to m.wStem.0
interpret add1s
end
if m.rStem.0 > m.dg.bufMax then
call jWriteBuf dg
return
endProcedure jRdr1sWrite
/* copy j end ********************************************************/
/* copy o begin *******************************************************
an object is register for a class in o2c
a class has a list of parents in cParent
a class has a methodTable cMet with lazy initialization
a method generator
otherwise an existing method is simply copied
**********************************************************************/
classInheritsOf: procedure expose m.
parse arg cl, sup
cl = class4name(cl)
sup = class4name(sup)
if m.cl.inheritsOf \== 1 then do
m.cl.inheritsOf = 1
call classInheritsOfAdd cl, cl'.INHERITSOF'
end
return m.cl.inheritsOf.sup == 1
endProcedure classInheritsOf
classInheritsOfAdd: procedure expose m.
parse arg cl, trg, pa
pa = classCycle(cl, pa)
m.trg.cl = 1
call assert "m.cl == 'u'"
do cx=1 to m.cl.0
c1 = m.cl.cx
if m.c1 == 'u' then
call classInheritsOfAdd c1, trg, pa
end
return
endProcedure classInheritsOf
classClear: procedure expose m.
parse arg cl, m
do fx=1 to m.cl.fldd.0
f1 = m || m.cl.fldd.fx
m.f1 = ''
end
return classClearStems(cl, m)
endProcedure classClear
classClearStems: procedure expose m.
parse arg cl, m
do sx=1 to m.cl.stmD.0
s1 = m || m.cl.stmD.sx
m.s1.0 = 0
end
return m
endProcedure classClearStems
classCopy: procedure expose m.
parse arg cl, m, t
do fx=1 to m.cl.fldd.0
ff = m || m.cl.fldd.fx
tf = t || m.cl.fldd.fx
m.tf = m.ff
end
do sx=1 to m.cl.stmD.0
call classCopyStem m.cl.stmD.sx.class,
, m || m.cl.stmD.sx, t || m.cl.stmD.sx
end
return t
endProcedure classCopy
classCopyStem: procedure expose m.
parse arg cl, m, t
m.t.0 = m.m.0
do sx=1 to m.t.0
call classCopy cl, m'.'sx, t'.'sx
end
return 0
endProcedure classCopyStem
/*--- return true if src is a rexxVariable a, m.a.c etc. ------------*/
rxIsVar: procedure expose m.
parse arg src
if pos(left(src, 1), m.ut_rxN1) > 0 then
return 0
else
return verify(src, m.ut_rxId) = 0
endProcedure rxIsVar
/*--- return true if src is a rexxConstant rerpresenting its value --*/
rxIsConst: procedure expose m.
parse arg src, vars c
if \ rxIsVar(src) then
return 0
srU = translate(src)
if srU \== src then
return 0
srU = '.'srU'.'
if pos('.GG', srU) > 0 then
return 0
if vars == '' then
return 1
upper vars
do vx=1 to words(vars)
if pos('.'word(vars, vx)'.', vars) > 0 then
return 0
end
return 1
endProcedure rxIsConst
/*--- return rexx code m.cc or mGet('cc') ---------------------------*/
rxMGet: procedure expose m.
parse arg v1, cc, vars
if cc == '' then
return 'm.'v1
else if rxIsConst(cc, vars) then
return 'm.'v1'.'cc
else
return 'mGet('v1 || quote('.'cc, "'")')'
endProcedure rxMGet
/*--- print object --------------------------------------------------*/
objOut: procedure expose m.
parse m, pr, p1
return classOutDone(m.class_O, m, pr, p1)
/*--- recursively output (with outX:) object a with class t ---------*/
classOut: procedure expose m.
parse arg t, a, pr, p1
return classOutDone(if(t=='',m.class_O, t), a, pr, p1)
/*--- ouput object a with class t and stopper done ------------------*/
classOutDone: procedure expose m. done.
parse arg t, a, pr, p1
if p1 == '' then
p1 = pr
if right(p1, 1) \== ' ' then
p1 = p1' '
if done.ini \== 1 then do
done.ini = 1
t = class4Name(t, t)
p1 = p1'@'a' '
end
if done.t.a == 1 then do;
if t = m.class_o then
t = objClass(a)
return outX(p1'done :'className(t) '@'a)
end
done.t.a = 1
if t = m.class_O then do
if a == '' then
return outX(p1'obj null')
t = objClass(a)
if t = m.class_N | t = m.class_S then
return outX(p1'obj has no class @'m.a)
else
return classOutDone(t, a, pr, p1'isA')
end
if t == m.class_V then
return outX(p1'=' m.a)
if t == m.class_W == 'w' then
return outX(p1'}' substr(a, 2))
if m.t == 'f' then
return classOutDone(m.t.1, a'.'m.t.name, pr, p1'.'m.t.name)
if m.t == 'r' then do
if m.a == '' then
return outX(p1'refTo :'className(m.t.1) '@null@')
else
return classOutDone(m.t.1, m.a, pr,
, p1'refTo @'m.a)
end
if m.t = 'u' then do
t1 = m.t.1
vv = m.t.0 > 0 & m.t.1 == m.class_V
call outX p1 || if(m.t.name == '', 'union', ':'m.t.name),
|| copies(' =' m.a, vv)
do ux=1+vv to m.t.0
call classOutDone m.t.ux, a, pr' '
end
return 0
end
if m.t = 's' then do
call outX p1'stem' m.a.0
do ux=1 to m.a.0
call classOutDone m.t.1, a'.'ux, pr' ', pr' .'ux
end
return 0
end
if m.t = 'c' then do
if m.t.name = m.a then
call classOutDone m.t.1, a, pr, p1'choice' m.a
return 0
end
if m.t = 'm' then
return 0
return err('bad class type' m.t)
endProcedure classOutDone
/*--- mutate and reset an object for a class -----------------------*/
oReset: procedure expose m.
parse arg m, cl, arg, arg2
interpret classMet(class4name(cl), 'oReset')
return m
endProcedure oReset
/*--- create an an object of the class cl and reset it --------------*/
oNew: procedure expose m.
parse arg cl, arg, arg2
interpret classMet(class4name(cl), 'new')
return m
endProcedure oNew
/*--- return the class of object obj --------------------------------*/
objClass: procedure expose m.
parse arg m
if arg() > 1 then
return err('old objClass') / 0
if symbol('m.o.o2c.m') == 'VAR' then
return m.o.o2c.m
else if abbrev(m, m.o_escW) then
return m.class_w
else if m \== '' then
return m.class_S
else
return m.class_N
endProcedure objClass
oKindOf: procedure expose m.
parse arg obj, sup
return classInheritsOf(objClass(obj), sup)
/*--- return the code of method met of object m ---------------------*/
objMet: procedure expose m.
parse arg m, met
if symbol('m.o.o2c.m') == 'VAR' then
cl = m.o.o2c.m
else if abbrev(m, m.o_escW) then
cl = m.class_w
else if m \== '' then
cl = m.class_S
else
cl = m.class_N
if symbol('m.cl.method.met') == 'VAR' then
return m.cl.method.met
else
return classMet(cl, met) /* will do lazy initialisation */
endProcedure objMet
/*--- return true if obj is kind of string -------------------------*/
oKindOfString: procedure expose m.
parse arg obj
return objMet(obj, 'oKindOfString')
/*--- if obj is kindOfString return string
otherwise return arg(2) or fail ---------------------------*/
oAsString: procedure expose m.
parse arg m
interpret objMet(m, 'oAsString')
/*--- return the stem of fieldnames of object m ---------------------*/
oFlds: procedure expose m.
parse arg m
return objMet(m, 'oFlds')
endProcedure oFlds
oFldD: procedure expose m.
parse arg m
return objMet(m, 'oFldD')
endProcedure oFlds
oClear: procedure expose m.
parse arg m
interpret objMet(m, 'oClear')
return m
endProcedure oClear
/*--- copy object m of class cl to t --------------------------------*/
oClaCopy: procedure expose m.
parse arg cl, m, t
interpret "drop cl;" classMet(cl, 'oCopy')
endProcedure oClaCopy
/*--- copy object m to t / create a new object if t=='' -------------*/
oCopy: procedure expose m.
parse arg m, t
interpret objMet(m, 'oCopy')
endProcedure oCopy
oCopyGen: procedure expose m.
parse arg cl
if cl == m.class_N | cl == m.class_S | cl == m.class_W then
return 'return m'
call classMet cl, 'new'
do sx=1 to m.cl.stms.0
s1 = m.cl.stms.sx
call classMet m.cl.s2c.s1, 'oCopy'
end
return "if t=='' then t = mNew('"cl"');" ,
"call oMutate t, '"cl"';" ,
"return classCopy('"cl"', m, t)"
endProcedure oCopyGen
/*--- return a new instance of a subclass of Run
with code code in method oRun -------------------------------*/
oRunner: procedure expose m.
parse arg code
return oNew(classNew('n* ORun u ORun, m oRun' code))
endProcedure oRunner
/*--- run method oRun of object m -----------------------------------*/
oRun: procedure expose m.
parse arg m, arg, arg2
interpret objMet(m, 'oRun')
return
endProcedure oRun
/*--- run method oRun of object m No Procedure:
??? optimize: class only run ???
use from caller unprotected---------------------------------*/
oRunNP: procedure expose m.
interpret objMet(arg(1), 'oRun')
return
endProcedure oRunNP
/*--- run method oRun and return output in new JBuf -----------------*/
oRun2File: procedure expose m.
parse arg rn
b = jBuf()
call pipe '+F' , b
call oRun rn
call pipe '-'
return b
endProcedure oRun2File
/*--- cast the object to a file -------------------------------------*/
o2File: procedure expose m.
parse arg m
interpret objMet(m, 'o2File')
call err 'o2file did not return' / 0
endProcedure o2File
/*--- cast the object to a String -----------------------------------*/
o2String: procedure expose m.
parse arg m, fmt
if arg() = 1 then
fmt = ' '
interpret objMet(m, 'o2String')
return err('o2String did not return')
endProcedure o2String
/*--- return a short string representation of an object o=¢...! -----*/
o2Text: procedure expose m.
parse arg m, maxL, fmt
if maxL == '' then
maxL = 75
interpret objMet(m, 'o2Text')
endProcedure o2Text
/*--- return a short string representation of the fields of an obj --*/
o2TexLR: procedure expose m.
parse arg m, maxL, le, ri
if maxL == '' then
maxL = 75
interpret objMet(m, 'o2TexLR')
endProcedure o2TexLR
o2TextFlds: procedure expose m.
parse arg m, cl, maxL
maxL = maxL - 3
r = ''
do fx=1 to m.cl.fldd.0
c1 = m.cl.fldd.fx.class
r = r || left(' ', fx > 1)substr(m.cl.fldd.fx, 2)
if c1 = m.class_V then
r = r'='
else if m.c1 == 'r' then
r = r'=>'
else
r = r'=?'c1'?'
a1 = m || m.cl.fldd.fx
r = r || m.a1
if length(r) > maxL then
return left(r, maxL)'...'
end
return r
endProcedure o2TextFlds
o2TextGen: procedure expose m.
parse arg cl, le, ri
m1 = classMet(cl, 'o2String', '-')
if m1 \== '-' then do
if translate(word(m1, 1)) \== 'RETURN' then
call err 'o2TextGen' className(cl)'#o2String return?:' m1
return '__r = strip('subword(m1, 2)', "t");',
'if length(__r) <= maxL then return __r;' ,
'else return left(__r, maxL-3)"..."'
end
call classMet cl, 'oFlds'
if le = '' & ri = '' then
return "return o2TextFlds(m, '"cl"', maxL)"
else
return "return" le "|| o2TextFlds(m, '"cl"'" ,
", maxL - length("le") - length("ri")) || "ri
endProcedure o2TextGen
o2TextStem: procedure expose m.
parse arg st, to, maxL
do sx=1 to m.st.0
m.to.sx = o2Text(m.st.sx, maxL)
end
m.to.0 = m.st.0
return to
endProcedure o2TextStem
/*--- cast a String to an object -----------------------------------*/
s2o: procedure expose m.
parse arg str
return m.o_escW || str
endProcedure s2o
/* copy o end ********************************************************/
/* copy class begin **************************************************
a class has fields and methods,
the class module handles only the metadata,
object handling (instanciation, methodcalls etc.) is in O
classes are represented by a metadata tree,
its nodes of class class have diffenrent types:
class subTypes (implemented as choices)
'u' = union: NAME -> name of class if <> '',
stem -> references component classes
'f' = field: NAME -> fieldName (x.name),
CLASS -> reference to class of fieldValue
's' = stem: class -> ref to class at each stem element
'c' = choice: NAME -> selection value,
CLASS -> ref to class of choice
'm' = method: NAME -> methodName,
MET -> rexxCode
'r' = reference CLASS -> ref to type at reference
special classes
'v' = Value String Value
'w' = ValueAsA StringValue packed into an address (prefix escW)
'o' = AnyClass any class with dynamic classLookup on object
formal definition, see classIni
class expression (ce) allow the following syntax
ce = className | classAdr | 'n'('?','*','|')? name union | union
| 'f' name ce | 's' ce | 'c' name ce | 'm' name code | r ce?
union = 'u' (cu (',' cu)*)?
cu = ce | c1* '%' c1* '%'? name+ (same type for each name)
the modifiers of 'n' means
none: create new class, fail if name already defined
'?': create new class or return old of that name
'*': use an exisiting class of that definition
or create new class with a unique name
'|': create a new class with a unique name
'm' extends to then end of the ce (line)
'u' allows several components, in classNew also multiple args
Achtung, aber NICHT rekursiv|
**********************************************************************/
classIni: procedure expose m.
if m.class.ini == 1 then
return
m.class.ini = 1
m.o_escW = '!'
call mapIni
m.class.0 = 0
call mapReset class_n2c /* name to class */
m.class_V = classNew('n v u', 'm',
, "asString return m.m" ,
, "o2File return file(m.m)")
m.class_W = classNew('n w u', 'm' ,
, "asString return substr(m, 2)" ,
, "o2File return file(substr(m,2))")
m.class_O = classNew('n o u')
m.class_C = classNew('n class u')
call classNew 'n= class u v' ,
, 'c u u f NAME v', /* union or class */
, 'c f u f NAME v', /* field */
, 'c s u' , /* stem */
, 'c c u f NAME v', /* choice */
, 'c r u' , /* reference */
, 'c m u f NAME v, f MET v', /* method */
, 's r class'
m.class_lazyRetMutate = "return 'call oMutate m, '''cl''';'"
m.class_lazyRoot = classNew('n LazyRoot u', 'm',
, "METHODLAZY" ,
, "f2c call classMet cl, 'oFlds'; return cl'.F2C'" ,
, "f2x call classMet cl, 'oFlds';",
"call mInverse cl'.FLDS', cl'.F2X';" ,
"return cl'.F2X'" ,
, "oFlds call classFldGen cl; return cl'.FLDS'" ,
, "oFldD call classMet cl, 'oFlds'; return cl'.FLDD'" ,
, "o2Text return o2textGen(cl, 'm''=¢''', '''!''')",
, "o2TexLR return o2textGen(cl, 'le', 'ri')",
, "s2c call classMet cl, 'oFlds'; return cl'.S2C'" ,
, "stms call classMet cl, 'oFlds'; return cl'.STMS'" ,
, "in2Str return classMet(cl, 'o2String')" ,
, "in2File return classMet(cl, 'o2File')" ,
, "in2Buf return 'return jBufCopy('" ,
"classMetRmRet(cl,'o2File')')'",
, "oKindOfString return classMet(cl, 'asString', '\-\')" ,
"\== '\-\'" ,
, "oAsString if classMet(cl, 'oKindOfString')" ,
"then return classMet(cl, 'asString');",
"else return 'if arg() >= 2 then return arg(2)" ,
"; else return err(m ''is not a kind of string" ,
"but has class' className(cl)''')'" ,
, "o2String return classMet(cl,'asString','\-\')" ,
, "new call mNewArea cl, 'O.'substr(cl,7);" ,
"return 'm = mNew('''cl''');'" ,
"classMet(cl,'oReset')",
)
call classNew 'n= LazyRoot u', 'm',
, "oReset call classMet cl, 'oClear';" m.class_lazyRetMutate,
"'call classClear '''cl''', m;'" ,
, "oResetNoMut return classRmFirstmt(" ,
"classMet(cl, 'oReset'), 'call oMutate ');" ,
, "oClear call classMet cl, 'oFlds'" ,
"; return 'call classClear '''cl''', m'",
, "oCopy return oCopyGen(cl)"
m.class_S = classNew('n String u', 'm',
, 'asString return m' ,
, 'in2Str return m' ,
, 'in2File return jBuf(m)',
, 'in2Buf return jBuf(m)')
m.class_N = classNew('n Null u', 'm',
, "asString return ''",
, 'in2Str return o2String(m.j.in, fmt)',
, "o2Text return ''",
, 'in2File return m.j.in',
, 'in2Buf return jBufCopy(m.j.in)')
call classNew 'n LazyRun u LazyRoot', 'm',
, "o2Text return 'return m''=¢'className(cl)'!'''"
call classNew 'n ORun u', 'm',
, 'METHODLAZY' m.class_lazyRun,
, 'oRun call err "call of abstract method oRun"',
, 'o2File return oRun2File(m)',
, 'o2String return jCatLines(oRun2File(m), fmt)'
call mPut class_inheritMet'.'m.class_V, 0
call mPut class_inheritMet'.'m.class_W, 0
call mPut class_inheritMet'.'m.class_O, 0
call mPut class_inheritMet'.'m.class_S, 0
call mPut class_inheritMet'.'m.class_N, 0
return
endProcedure classIni
/*--- remove first statement if src starts with strt ----------------*/
classRmFirStmt: procedure expose m.
parse arg src, strt
if \ abbrev(src, strt) then
return src
return substr(src, pos(';', src)+2)
classNe1: procedure expose m.
parse arg n, ty, nm, refs, io
ky = ty','nm','space(refs, 1)','strip(io)
if ty == 'f' & abbrev('=', nm) then do
if words(refs) = 1 & io == '' then
return strip(refs)
else
call err 'bad field name:' ky
end
if n then
if symbol('m.class_k2c.ky') == 'VAR' then
return m.class_k2c.ky
m.class.0 = m.class.0 + 1
n = 'CLASS.'m.class.0
call mapAdd class_n2c, n, n
m.n = ty
m.n.met = strip(io)
if ty \== 'm' & io <> '' then
call err "io <> '' ty: classNe1("ky")" /0
if ty = 'u' then do
m.n.met = nm
if right(nm, 1) == '*' then
nm = left(nm, length(nm)-1)substr(n, 7)
end
m.n.name = nm
m.n.0 = words(refs)
do rx=1 to m.n.0
m.n.rx = word(refs, rx)
end
if length(ty) \== 1 | pos(ty, 'ufscrm') < 1 then
call err 'bad type' ty': classNe1('ky')' /0
else if nm == '' & pos(ty, 'm') > 0 then
call err 'empty name: classNe1('ky')'
else if nm \== '' & ty \== 'c' & verifId(nm) > 0 then
call err 'bad name' nm': classNe1('ky')'
else if nm \= '' & pos(ty, 'rs') > 0 then
call err 'name for type' ty': classNe1('ky')'
else if (pos(ty, 'fcsr') > 0 & m.n.0 \== 1) ,
| ( ty == 'm' & m.n.0 \== 0) then
call err m.n.0 'bad ref count in classNe1('ky')'
return n
endProcedure classNe1
classNew: procedure expose m.
parse arg clEx 1 ty rest
n = ''
nm = ''
io = ''
refs = ''
if wordPos(ty, 'n n? n* n=') > 0 then do
nmTy = right(ty, 1)
parse var rest nm ty rest
if nmTy = '=' then do
if \ mapHasKey(class_n2c, nm) then
call err 'class' nm 'not defined: classNew('clEx')'
n = mapGet(class_n2c, nm)
end
if ty \== 'u' then
call err 'class name' nm 'without u: classNew('clEx')'
if nmTy == '?' then do
if mapHasKey(class_n2c, nm) then
return mapGet(class_n2c, nm)
end
else if nmTy == '*' & arg() == 1 then do
if mapHasKey(class_n2c, clEx) then
return mapGet(class_n2c, clEx)
end
end
else do
nmTy = ''
if arg() == 1 then
if mapHasKey(class_n2c, clEx) then
return mapGet(class_n2c, clEx)
if length(ty) <> 1 | pos(ty, 'ufscmr') < 1 then
return err('bad type' ty': classNew('clEx')')
if pos(ty, 'fcm') > 0 then
parse var rest nm rest
if ty == 'm' then
io = rest
else if pos(ty, 'fsc') > 0 | (ty == 'r' & rest \== '') then
refs = classNew(strip(rest))
else if ty == 'r' then
refs = m.class_O
end
if ty == 'u' then do
lx = 0
do while lx < length(rest)
t1 = word(substr(rest, lx+1), 1)
cx = pos(',', rest, lx+1)
if cx <= lx | t1 == 'm' then
cx = length(rest)+1
one = strip(substr(rest, lx+1, cx-lx-1))
lx=cx
if pos('%', word(one, 1)) < 1 then
refs = refs classNew(one)
else do
parse value translate(word(one, 1), ' ', '-') ,
with wBe '%' wAf '%' ww
do wx=2 to words(one)
refs = refs classNew(wBe word(one, wx) wAf)
end
end
end
pref = ''
do ax=2 to arg()
if length(arg(ax)) == 1 & arg(ax) \== ' ' then
pref = arg(ax)' '
else
refs = refs classNew(pref || arg(ax))
end
end
if nmTy == '=' then do
if m.n \== ty | ty \== 'u' then
call err 'n= mismatch'
do ux=1 to words(refs)
call mAdd n, word(refs, ux)
end
end
else if nmTy == '*' then
n = classNe1(0, ty, nm'*', refs, io)
else
n = classNe1(nmTy == '', ty, nm, refs, io)
if arg() == 1 then
call mapAdd class_n2c, clEx, n
/* if nmTy == '*' & m.n.name == nm'*' then
m.n.name = nm || substr(n, 6) ??????? */
if nmTy \== '' & nmTy \== '=' then
call mapAdd class_n2c, m.n.name, n
if nmTy == 'n' | nmTy == '?' then do
v = 'CLASS_'translate(nm)
if symbol('m.v') == 'VAR' then
call err 'duplicate class' v
m.v = n
end
return n
endProcedure classNew
/*--- return the name of a class if it exists otherwise the class ---*/
className: procedure expose m.
parse arg cl
if \ mapHasKey(class_n2c, cl) then
return 'notAClass:' cl
c2 = mapGet(class_n2c, cl)
if m.c2 = 'u' & m.c2.name \= '' then
return m.c2.name
else
return cl
endProcedure className
/*--- return class of given name or class ---------------------------*/
class4Name: procedure expose m.
parse arg nm
if symbol('m.class_n2c.nm') == 'VAR' then
return m.class_n2c.nm
if arg() > 1 then
return arg(2)
call err 'no class' nm
endProcedure class4Name
/*--- mutate object m to the class cl -------------------------------*/
oMutate: procedure expose m.
parse arg m, cl
m.o.o2c.m = cl
return m
endProcedure oMutate
/*--- mutate object m to the class named name -----------------------*/
oMutatName: procedure expose m.
parse arg m, nm
m.o.o2c.m = class4Name(nm)
return m
endProcedure oMutatName
/*--- find the code for a met in a class ---------------------------*/
classMet: procedure expose m.
parse arg cl, met
if symbol('m.cl.method.met') == 'VAR' then
return m.cl.method.met
if symbol('m.cl.method.methodLazy') == 'VAR' then do
/* build lazy method */
m.cl.method.met = "call err 'building lazy method" cl"#"met"'"
m.cl.method.met = classMetLazy(m.cl.method.methodLazy, cl, met)
if m.cl.method.met \== '\-\' then
return m.cl.method.met
drop m.cl.method.met
if arg(3) \== '' then
return arg(3)
else
return err('no method' met 'in class' className(cl))
end
if symbol('m.class_n2c.cl') \== 'VAR' then
call err 'no class classMet('cl',' met')'
if cl \== m.class_n2c.cl then
return classMet(m.class_n2c.cl, met)
if m.cl == 'u' then
call classMetGen cl, cl'.'method
if symbol('m.cl.method.methodLazy') \== 'VAR' then
m.cl.method.methodLazy = m.class_lazyRoot
return classMet(cl, met, arg(3))
endProcedure classMet
classMetLazy: procedure expose m.
parse arg build, cl, met
if build = '' then
return '\-\'
cd = classMet(build, met, '\-\')
if abbrev(cd, '?') then
return err('? met' cd 'b='build cl'#'met) / 0
else if cd \== '\-\' then
interpret cd
else
return cd
endProcedure classMetLazy
classMetRmRet: procedure expose m.
parse arg cl, met
cd = classMet(cl, met)
if word(cd, 1) == 'return' then
return subword(cd, 2)
else
return cd
endProcedure classMetRmRet
/*--- generate all methods for a class recursively ------------------*/
classMetGen: procedure expose m.
parse arg aC, trg, pa
pa = classCycle(aC, pa)
if m.aC \== 'u' then
call err 'cl not u:' m.aC aC
do cx=1 to m.aC.0 /* methods directly in cl */
cl = m.aC.cx
if pos(m.cl, 'ufscr') > 0 then
iterate
if m.cl \== 'm' then
call err 'bad cla' cl m.cl
m1 = m.cl.name
if symbol('m.trg.m1') == 'VAR' then
nop
else
m.trg.m1 = m.cl.met
end
do cx=1 to m.aC.0 /* inherited methods */
cl = m.aC.cx
if m.cl == 'u' & m.class_inheritMet.cl \== 0 then
call classmetGen cl, trg, pa
end
return
endProcedure classmetGen
classCycle: procedure expose m.
parse arg cl, pa
if wordPos(cl, pa) < 1 then
return pa cl
call err classCycle cl pa / 0
endProcedure classCycle
classFlds: procedure expose m.
parse arg cl
return classMet(cl, 'oFlds')
endProcedure classFlds
classFldD: procedure expose m.
parse arg cl
return classMet(cl, 'oFldD')
endProcedure classFldD
classFldGen: procedure expose m.
parse arg cl
m.cl.fldS.0 = 0
m.cl.fldS.self = 0
m.cl.fldD.0 = 0
m.cl.stmS.0 = 0
m.cl.stmS.self = 0
m.cl.stmD.0 = 0
return classFldAdd(cl, cl)
endPorcedure classFldGen
/*--- add the the fields of class cl to stem f ----------------------*/
classFldAdd: procedure expose m.
parse arg f, cl, nm, pa
pa = classCycle(cl, pa)
if cl == m.class_V | cl == m.class_W | cl == m.class_O ,
| m.cl == 'r' then
return classFldAdd1(f'.FLDD', f'.FLDS', f'.F2C', cl, nm,
, if(cl=m.class_W, m.o_escW, ''))
if m.cl = 's' then do
if m.cl.1 == '' then
call err 'stem null class'
return classFldAdd1(f'.STMD', f'.STMS', f'.S2C', m.cl.1, nm, 0)
end
if m.cl = 'f' then
return classFldAdd(f, m.cl.1, nm ,
|| left('.', m.cl.name \== '' & nm \== '') || m.cl.name, pa)
do tx=1 to m.cl.0
call classFldAdd f, m.cl.tx, nm, pa
end
return 0
endProcedure classFldAdd
classFldAdd1: procedure expose m.
parse arg fd, fs, f2, cl, nm, null
if symbol('m.f2.nm') == 'VAR' then
if m.f2.nm == cl then
return 0
else
return err('f2 mismatch f2='f2 Nm 'cl='cl 'old='m.f2.nm)
m.f2.nm = cl
cc = mAdd(fd, left('.', nm \== '')nm)
m.cc.class = cl
if nm == '' then do
m.fs.self = 1
m.fs.self.class = cl
/* call mMove fa, 1, 2
m.fa.1 = ''
call mPut fa'.SELF', 1 */
end
else do
cc = mAdd(fs, nm)
m.cc.class = cl
end
return 0
endProcedure classFldAdd1
/* copy class end **************************************************/
/* copy mapExp begin *************************************************/
mapVia: procedure expose m.
parse arg a, ky
sx = pos('|', ky)
if sx < 1 then
return mapGet(a, ky)
via = mapGet(a, left(ky, sx-1))
do while sx <= length(ky)
fx = sx+1
sx = pos('|', ky, fx)
if sx < 1 then
sx = length(ky) + 1
if sx = fx then do
if symbol('m.via') \== 'VAR' then
call err 'missing m.'via 'at' sx 'in mapVia('a',' ky')'
via = m.via
end
else do
f = substr(ky, fx, sx - fx)
if symbol('m.via.f') \== 'VAR' then
call err 'missing m.'via'.'f ,
'at' sx 'in mapVia('a',' ky')'
via = m.via.f
end
end
return via
endProcedure mapVia
mapExpAt: procedure expose m.
parse arg a, src, sx
m.map.ExpAt = 0
cx = pos('$', src, sx)
if cx < 1 then
return substr(src, sx)
res = substr(src, sx, cx-sx)
do forever
if substr(src, cx+1, 1) = '{' then do
ex = pos('}', src, cx+2)
if ex < 1 then
call err 'missing } after' substr(src, cx) 'in' src
res = res || mapVia(a, strip(substr(src, cx+2, ex-cx-2)))
ex = ex + 1
end
else do
ex = verify(src, m.ut_alfDot, 'n', cx+1)
if ex < 1 then
return res || mapVia(a, substr(src, cx+1))
if ex = cx+1 then do
m.map.ExpAt = cx
return res
end
res = res || mapVia(a, substr(src, cx+1, ex-cx-1))
end
cx = pos('$', src, ex)
if cx < 1 then
return res || substr(src, ex)
res = res || substr(src, ex, cx-ex)
end
endProcedure mapExpAt
mapExp: procedure expose m.
parse arg a, src
res = mapExpAt(a, src, 1)
if m.map.ExpAt \== 0 then
call err 'mapExp stopped at' substr(src, map.ExpAt) 'in' src
return res
endProcedure mapExp
mapExpAllAt: procedure expose m.
parse arg a, dst, src, sx, cx
do while sx <= m.src.0
li = mapExpAt(a, m.src.sx, cx)
dx = m.map.ExpAt
if (cx=1 & dx = 0) | li \= '' then
call mAdd dst, li
if dx = 0 then do
cx = 1
sx = sx+1
end
else do
return sx dx
end
end
return ''
endProcedure mapExpAllAt
mapExpAll: procedure expose m.
parse arg a, dst, src
sto = mapExpAllAt(a, dst, src, 1, 1)
if sto == '' then
return
lx = word(sto, 1)
call err 'mapExpAll stopped at' sto':' m.src.lx
endProcedure mapExpAll
/* copy mapExp end ***************************************************/
/* copy map begin *****************************************************
a map stores values at keys
it may also maintain a list of keys
the basic ideas are similar to the java Interface java.util.Map
contrary to stems we also handle keys longer then 250 bytes
**********************************************************************/
/*--- initialize the module -----------------------------------------*/
mapIni: procedure expose m.
if m.map_ini = 1 then
return
m.map_ini = 1
call mIni
m.map.0 = 0
m.map_inlineSearch = 1
call mapReset map_inlineName, map_inline
return
endProcedure mapIni
mapInline: procedure expose m.
parse arg pName, opt
if mapHasKey(map_inlineName, pName) then do
im = mapGet(map_inlineName, pName)
if pos('l', opt) < 1 & symbol('m.im.0') \== 'VAR' then do
m.im.0 = m.im.lEnd - m.im.lBegin - 1
do ix=1 to m.im.0
m.im.ix = strip(sourceline(ix+m.im.lBegin), 't')
end
end
return im
end
name = '/'
do lx = m.map_inlineSearch to sourceline()
if \ abbrev(sourceline(lx), '$') then
iterate
li = sourceline(lx)
s1 = pos('/', li)+ 1
if s1 < 3 | s1 > 4 then
iterate
s2 = pos('/', li, s1)
if s2 <= s1 then
iterate
if s1 == 3 then do
if name \== substr(li, s1, s2-s1) then
iterate
im = 'map_inline.' || (m.map_inline.0+1)
call mapAdd map_inlineName, name, im
m.im.lBegin = lBeg
m.im.lEnd = lx
m.im.mark = mrk
if name == pName then do
m.map_inlineSearch = lx+1
return mapInline(pName)
end
name = '/'
end
else if \ mapHasKey(map_inlineName,
, substr(li, s1, s2-s1)) then do
lBeg = lx
mrk = substr(li, 2, s1-3)
name = substr(li, s1, s2-s1)
end
else do
name = '/'
end
end
if pos('r', opt) > 0 then
return ''
return err('no inline data /'pName'/ found')
endProcedure mapInline
/*--- create a new map ----------------------------------------------*/
mapNew: procedure expose m.
parse arg opt
m.map.0 = m.map.0 + 1
return mapReset('MAP.'m.map.0 , opt)
endProcedure mapNew
/*--- make an empty map, if opt <> '' maintain stem of keys
('K' in map_keys, '=' in a else in opt) -------------*/
mapReset: procedure expose m.
parse arg a, opt
if symbol('m.map_keys.a') == 'VAR' then
call mapClear a
if opt = '=' then
st = a
else if translate(opt) = 'K' then
st = 'MAP_KEYS.'a
else
st = opt
m.map_keys.a = st
if st \== '' then
m.st.0 = 0
return a
endProcedure
/*--- add a new key value pair to the map ---------------------------*/
mapAdd: procedure expose m.
parse arg a, ky, val
vv = mapAdr(a, ky, 'a')
if vv == '' then
return err('duplicate in mapAdd('a',' ky',' val')')
m.vv = val
return val
endProcedure mapAdd
/*--- change the value at a key or add key value --------------------*/
mapPut: procedure expose m.
parse arg a, ky, val
vv = mapAdr(a, ky, 'p')
m.vv = val
return val
endProcedure mapPut
/*--- return 1 if key ky exists in map a, 0 otherwise ---------------*/
mapHasKey: procedure expose m.
parse arg a, ky
return mapAdr(a, ky, 'g') \== ''
endProcedure mapHasKey
/*--- return the value of key ky in map a if it exists,
else if called with a third argument return third argument
else issue an error ---------------------------------------*/
mapGet: procedure expose m.
parse arg a, ky
vv = mapAdr(a, ky, 'g')
if vv \== '' then
return m.vv
else if arg() > 2 then
return arg(3)
else
return err('missing key in mapGet('a',' ky')')
endProcedure mapGet
/*--- return a stem of all keys -------------------------------------*/
mapKeys: procedure expose m.
parse arg a
if m.map_keys.a == '' then
call err 'mapKeys('a') with no keys'
return m.map_keys.a
endProcedure mapKeys
/*--- remove a key from the map, do nothing if it is missing --------*/
mapRemove: procedure expose m.
parse arg a, ky
vv = mapAdr(a, ky, 'g')
if vv == '' then
return ''
if m.map_keys.a \== '' then do
trace ?R /* not tested yet ???wkTest */
k = m.map_keys.a
mx = m.k.0
do i=1 to mx
if m.k.i == ky then do
m.k.i = m.k.mx
m.k.0 = mx - 1
return
end
end
end
val = m.vv
drop m.a.ky
return val
endProcedure mapRemove
/*--- remove all entries --------------------------------------------*/
mapClear: procedure expose m.
parse arg a
st = mapKeys(a)
liLe = 247 - length(a)
do kx=1 to m.st.0
ky = m.st.kx
drop m.st.kx
if length(ky) < liLe then do
drop m.a.ky
end
else do
adr = mapAdr(a, ky, 'g')
if adr \== '' then do
ha = left(adr, length(adr) - 2)
do i = 1 to m.ha.0
vv = ha'v'i
drop m.ha.i m.vv
end
drop m.ha.0
end
end
end
m.st.0 = 0
return a
endProcedure mapClear
/*--- return the value pointer for a key, '' if non existing
f = 'g' return address if exists otherwise ''
'p' return address if exists otherwise newly added address
'a' return '' if exists otherwise newly added address --*/
mapAdr: procedure expose m.
parse arg a, ky, f
if length(ky) + length(a) < 247 then do
res = a'.'ky
if symbol('m.res') == 'VAR' then
return copies(res, f \== 'a')
else if f == 'g' then
return ''
end
else do
len = length(ky)
q = len % 2
ha = a'.'len || left(ky, 80) || substr(ky,
, len % 2 - 40, 85-length(len)-length(a)) || right(ky, 80)
if symbol('M.ha.0') == 'VAR' then do
do i=1 to m.ha.0
if m.ha.i == ky then
return copies(ha'v'i, f \== 'a')
end
end
else do
i = 1
end
if f == 'g' then
return ''
if i > 9 then
call err 'overflow long key' y 'in map' a 'hash' ha'.K.'i
m.ha.0 = i
m.ha.i = ky
res = ha'v'i
end
if m.map_keys.a \== '' then
call mAdd m.map_keys.a, ky
return res
endProcedure mapAdr
/* copy map end ******************************************************/
/* copy m begin *******************************************************
we use variables as follows
m. stem m: all global data and object data that must survive
a procedure call (m for memory in Memoria of B5000)
m.<mbr>.** and m.<mbr>_**: every rexx Module (copy) should only
allocate these addresses to avoid address conficts
with <mbr> the name of therexx module
we pass parameters around (e.g. a=address, m=memory, st=stem)
and the called function may use m.a or m.a.subField etc.
gg*: local variable in subroutines without procedure
everything else: temporary data within procedure
every subroutine is declared as procedure expose m.
(also if no m. variable is used, because e.g. of error handling)
the few subroutines that cannot use procedure, should use only
variables starting with gg
**********************************************************************/
/*---make an area -----*/
mNewArea: procedure expose m.
parse arg nm, adr
ax = m.m_area.0 + 1
m.m_area.0 = ax
m.m_area.ax = nm
if adr == '=' then
adr = nm
else if adr == '' then
adr = 'M.'ax
if symbol('m.m_2a.nm') == 'VAR' then
call err 'area name' nm 'already used'
if symbol('m.m_2a.adr') == 'VAR' then
call err 'adr' adr 'for area' nm 'already used'
m.m_2a.adr = adr
m.m_2a.nm = adr
m.adr.0 = 0
m.m_free.adr.0 = 0
return nm
endProcedure mNewArea
mNew: procedure expose m. ggArea
parse arg name
if symbol('m.m_2a.name') \== 'VAR' then
call err 'area' name 'does not exists'
adr = m.m_2a.name
if m.m_free.adr.0 > 0 then do
fx = m.m_free.adr.0
m.m_free.adr.0 = fx-1
return m.m_free.adr.fx
end
m.adr.0 = m.adr.0 + 1
return adr'.'m.adr.0
endProcedure mNew
mFree: procedure expose m.
parse arg m
adr = left(m, lastPos('.', m)-1)
fx = m.m_free.adr.0 + 1
m.m_free.adr.0 = fx
m.m_free.adr.fx = m
return ''
endProcedure mFree
/*--- iterate over all allocate elements of an area -----------------*/
mIterBegin: procedure expose m.
parse arg nm
return m.m_2a.nm'.0'
endProcedure mIterBegin
mIter: procedure expose m.
parse arg cur
if cur == '' then
return ''
lx = lastPos('.', cur)
adr = left(cur, lx-1)
ix = substr(cur, lx+1)
do ix=ix+1 to m.adr.0
n = adr'.'ix
do fx=1 to m.m_free.adr.0 while m.m_free.adr.fx \== n
end
if fx > m.m_free.adr.0 then
return n
end
return ''
endProcedure mIter
/*--- get m.a -------------------------------------------------------*/
mGet: procedure expose m.
parse arg a
return m.a
endProcedure mGet
/*--- put value v into m.a ------------------------------------------*/
mPut: procedure expose m.
parse arg a, v
m.a = v
return v
endProcedure mPut
/*--- cut stem a to length len --------------------------------------*/
mCut: procedure expose m.
parse arg a, len
m.a.0 = len
return a
endProcedure mCut
/*--- add one or several arguments to stem m.a ----------------------*/
mAdd: procedure expose m.
parse arg a
ix = m.a.0
do ax = 2 to arg()
ix = ix + 1
m.a.ix = arg(ax)
end
m.a.0 = ix
return a'.'ix
endProcedure mAdd
/*--- pop last element from stem m.a --------------------------------*/
mPop: procedure expose m.
parse arg a
ix = m.a.0
if ix < 1 then
call err 'pop from empty stem' a
m.a.0 = ix-1
return m.a.ix
endProcedure mPop
/*--- create the inverse map of a stem ------------------------------*/
mInverse: procedure expose m.
parse arg a, i
do x=1 to m.a.0
v = m.a.x
m.i.v = x
end
return m.a.0
endProcedure inverse
/*--- add to m.dst.* a (sub)sequence of m.src.* ---------------------*/
mAddSt: procedure expose m.
parse arg dst, src, fx , tx
dx = m.dst.0
if fx == '' then
fx = 1
if tx == '' then
tx = m.src.0
do sx = fx to tx
dx = dx + 1
m.dst.dx = m.src.sx
end
m.dst.0 = dx
return dst
endProcedure mAddSt
/*--- find position of first occurrence of ele in stem m,
return 0 if nonemove a part of a stem -----------------------*/
mPos: procedure expose m.
parse arg m, ele, sx
if sx == '' then
sx = 1
do x=sx to m.m.0
if m.m.x = ele then
return x
end
return 0
endProcedure mPos
/*--- move a part of a stem -----------------------------------------*/
mMove: procedure expose m.
parse arg m, sx, dx
if dx < sx then do
y = dx
do x=sx to m.m.0
m.m.y = m.m.x
y = y + 1
end
end
else if dx > sx then do
y = m.m.0 + dx - sx
do x=m.m.0 by -1 to sx
m.m.y = m.m.x
y = y - 1
end
end
m.m.0 = m.m.0 + dx - sx
return
endProcedure mMove
/*--- insert a stem into another ------------------------------------*/
mInsert: procedure expose m.
parse arg m, tx, st
call mMove m, tx, tx+m.st.0
do sx=1 to m.st.0
dx = tx-1+sx
m.m.dx = m.st.sx
end
return
endProcedure mInsert
/*--- strip all elements of a stem ----------------------------------*/
mStrip: procedure expose m.
parse arg st, opt
if opt == '' then
opt = 'b'
do x=1 to m.st.0
m.st.x = strip(m.st.x, opt)
end
return st
endProcedure mStrip
/* cat the lines of a stem with separator ---------------------------*/
mCat: procedure expose m.
parse arg st, sep
if m.st.0 < 1 then
return ''
res = m.st.1
do sx=2 to m.st.0
res = res || sep || m.st.sx
end
return res
endProcedure mCat
mIni: procedure expose m.
if m.m_ini == 1 then
return
m.m_ini = 1
call utIni
m.m_area.0 = 0
call mNewArea
return
endProcedure mIni
/* copy m end ********************************************************/
/* copy fTab begin ****************************************************
output Modes: t = tableMode 1 line per object with fixed colums th
c = colMode 1 line per column/field of object
we build a format for each column
and a set of title lines, one sequence printed before
, one sequence printed after
lifeCycle fTab sql
fTabReset sqlFTabReset
fTabAdd * fTabAdd * add col info
sqlFTabOthers ?
fTabGenTab or fTabGenCol
fTabBegin header lines
fTab1 * / tTabCol *
fTabEnd trailer lines
primary data for each col
.col : column (rexx) name plus aDone
.done : == 0 sqlFtabOthers should add it again
.fmt : format
.labelLo : long label for multi line cycle titles
.labelSh : short label for singel title line (colwidth)
.tit.* : title line piece for this col
**********************************************************************/
fTabIni: procedure expose m.
if m.fTab_ini == 1 then
return
m.fTab_ini = 1
call classIni
m.fTab_class = classNew("n FTab u ORun, m oRun call fTab m")
return
endProcedure fTabIni
fTabReset: procedure expose m.
parse arg m, m.m.titBef, m.m.titAft, m.m.opt
call fTabIni
if m.m.titBef == '' & m.m.titaft == '' then do
m.m.titBef = 'c 1'
m.m.titAft = '1 c'
end
if m.m.titBef == '-' then
m.m.titBef = ''
if m.m.titAft == '-' then
m.m.titAft = ''
m.m.generated = ''
m.m.verbose = pos('s', m.m.opt) < 1 /* not silent */
m.m.0 = 0
m.m.set.0 = 0
return fTabResetCols(oMutate(m, m.fTab_class))
endProcedure fTabReset
/*--- clean out all cols of ftab, but keep settings -----------------*/
fTabResetCols: procedure expose m.
parse arg m
m.m.0 = 0
return m
/*--- for column cx set title tx ------------------------------------*/
fTabSetTit: procedure expose m.
parse arg m, cx, tx, t1
m.m.generated = ''
if tx > m.m.cx.tit.0 then do
do xx=m.m.cx.tit.0+1 to tx-1
m.m.cx.tit.xx = ''
end
m.m.cx.tit.0 = tx
end
m.m.cx.tit.tx = t1
return m
endProcedure fTabSetTit
/*--- set default atts for a col name ------------------------------*/
fTabSet: procedure expose m.
parse arg m, c1 aDone, f1, sh, lo
sx = m.m.set.0 + 1
m.m.set.0 = sx
m.m.set.sx = c1 aDone
m.m.set.sx.fmt = f1
m.m.set.sx.labelSh = sh
m.m.set.sx.labelLo = lo
m.m.set.c1 = sx
return
endProcedure fTabSet
/*--- add a column --------------------------------------------------
m, rexxName done, fmt, labelShort, labelLong, titles... ------*/
fTabAdd: procedure expose m.
parse arg m, rxNm aDone
m.m.generated = ''
cx = m.m.0 + 1
m.m.0 = cx
cc = m'.'cx
m.cc.col = rxNm
m.cc.done = aDone \== 0
parse arg , , m.cc.fmt, m.cc.labelSh, m.cc.labelLo
if rxNm == '=' | rxNm == 0 | rxNm == 1 then
call err 'bad rxNm' rxNm
if \ (aDone == '' | aDone == 0 | aDone == 1) then
call err 'bad aDone' aDone
m.cc.tit.0 = max(arg()-4, 1)
m.cc.tit.1 = ''
do tx=2 to m.cc.tit.0
m.cc.tit.tx = arg(tx+4)
end
return cc
endProcedure fTabAdd
/*--- complete column info-------------------------------------------*/
fTabColComplete: procedure expose m.
parse arg m
do cx=1 to m.m.0
nm = m.m.cx.col
f1 = m.m.cx.fmt
if f1 = '' then
m.m.cx.fmt = '@.'nm'%-8C'
else do
px = pos('%', f1)
ax = pos('@', f1)
if px > 0 & (ax <= 0 | ax >= px) then
m.m.cx.fmt = left(f1, px-1)'@.'nm || substr(f1, px)
end
if m.m.cx.labelLo = '' then
if nm = '' then
m.m.cx.labelLo = '='
else
m.m.cx.labelLo = nm
if m.m.cx.labelSh = '' then
m.m.cx.labelSh = m.m.cx.labelLo
end
return
endProcedure fTabColComplete
/*--- generate line formats and title lines -------------------------*/
fTabGenTab: procedure expose m.
parse arg m, sep
if m.m.generated == '' then
call fTabColComplete m
m.m.tit.0 = words(m.m.titBef m.m.titAft) + 5
do tx=1 to m.m.tit.0
m.m.tit.tx = ''
end
f = ''
tLen = 0
do kx=1 to m.m.0
rxNm = m.m.kx.col
call mPut 'F_TEMP'left('.', rxNm\=='')rxNm, m.m.kx.labelSh
t1 = f(m.m.kx.fmt, 'F_TEMP')
m.m.kx.len = length(t1)
if pos(strip(t1), m.m.kx.labelSh) < 1 then /* corrupted| */
t1 = left(left('', max(0, verify(t1, ' ') -1)) ,
|| m.m.kx.labelSh, length(t1))
m.m.kx.tit.1 = t1
if kx = 1 then do
f = m.m.kx.fmt
end
else do
tLen = tLen + length(sep)
f = f || sep || m.m.kx.fmt
end
m.m.kx.start = tLen+1
do tx=1 to m.m.kx.tit.0
if m.m.kx.tit.tx \== '' then
if tx > 1 | pos('-', m.m.opt) < 1 then
m.m.tit.tx = left(m.m.tit.tx, tLen) ,
|| strip(m.m.kx.tit.tx, 't')
else if \ abbrev(m.m.kx.tit.tx, ' ') then
m.m.tit.tx = left(m.m.tit.tx, tLen, '-') ,
|| strip(m.m.kx.tit.tx, 't')
else
m.m.tit.tx = left(m.m.tit.tx, tLen, '-') ,
|| right(strip(m.m.kx.tit.tx),
, length(m.m.kx.tit.tx), '-')
end
tLen = tLen + m.m.kx.len
end
m.m.len = tLen
if pos('-', m.m.opt) > 0 then
m.m.tit.1 = left(m.m.tit.1, tLen +3, '-')
m.m.fmt = fGen('%>', f)
cSta = m.m.tit.0+3 /* compute cycle titles */
cycs = ''
cyEq = 1
do cEnd=cSta until kx > m.m.0
/*try with cycle lines for cSta to cEnd */
cycs = cycs cEnd
cx = cSta
firstRound = 1
do kx=1 to m.m.0
if firstRound then
m.m.tit.cx = left('', m.m.kx.start-1)m.m.kx.labelLo
else if length(m.m.tit.cx) <= m.m.kx.start - 2 then
m.m.tit.cx = left(m.m.tit.cx, m.m.kx.start - 1) ,
|| m.m.kx.labelLo
else
leave
if cyEq then
cyEq = translate(m.m.kx.labelLo) ,
= translate(m.m.kx.labelSh)
cx = cx + 1
if cx > cEnd then do
cx = cSta
firstRound = 0
end
end
end
m.m.cycles = strip(cycs)
if cyEq & words(cycs) <= 1 then
m.m.cycles = ''
m.m.generated = m.m.generated't'
return
endProcedure fTabGenTab
/*--- generate column format ----------------------------------------*/
fTabGenCol: procedure expose m.
parse arg m
if m.m.generated == '' then
call fTabColComplete m
do kx=1 to m.m.0
t = m.m.kx.labelLo
l = if(m.m.kx.labelSh == t, , m.m.kx.labelSh)
f = lefPad(lefPad(strip(l), 10) t, 29)
if length(f) > 29 then
if length(l || t) < 29 then
f = l || left('', 29 - length(l || t))t
else
f = lefPad(strip(l t), 29)
g = strip(m.m.kx.fmt)
o = right(g, 1)
if pos(o, 'dief') > 0 then
f = f '@'m.m.kx.col'%12e @'m.m.kx.col'%18c'
else if o = 'C' then
f = f left(g, length(g)-1)'c'
else
f = f g
m.m.kx.colFmt = f
end
m.m.generated = m.m.generated'c'
return
endProcedure fTabGenCol
/*--- output all of rdr in tab format -------------------------------*/
fTab: procedure expose m.
parse arg m, rdr
if pos('a', m.m.opt) < 1 then
i = rdr
else do
i = in2Buf(rdr)
if m.i.buf.0 > 0 then
call fTabDetect m, i'.BUF'
end
if pos('o', m.m.opt) > 0 then do
call pipeWriteAll i
end
else if pos('c', m.m.opt) > 0 then do
if pos('c', m.m.generated) < 1 then
call fTabGenCol m
i = jOpen(in2file(i), '<')
do rx=1 while jRead(i)
call out left('--- row' rx '', 80, '-')
call fTabCol m, m.i
end
call out left('--- end of' (rx-1) 'rows ', 80, '-')
call jClose i
end
else do
call fTabBegin m
call fAll m.m.fmt, i
return fTabEnd(m)
end
return m
endProcedure fTab
/*--- output object i in col format ---------------------------------*/
fTabCol: procedure expose m.
parse arg m, i
do cx=1 to m.m.0
call out f(m.m.cx.colFmt, i)
end
return 0
endProcedure fTabCol
fTabBegin: procedure expose m.
parse arg m
if pos('t', m.m.generated) < 1 then
call fTabGenTab m, ' '
return fTabTitles(m, m.m.titBef)
endProcedure fTabBegin
fTabEnd: procedure expose m.
parse arg m
return fTabTitles(m, m.m.titAft)
fTabTitles: procedure expose m.
parse arg m, list
list = repAll(list, 'c', m.m.cycles)
do tx=1 to words(list)
t1 = word(list, tx)
call out m.m.tit.t1
end
return m
endProcedure fTabTitles
/*--- auto tables detect format from data ---------------------------*/
/*--- detect fmt from a rdr and write it formatted to stdOut --------*/
fTabAuto: procedure expose m.
parse arg m, rdr
if m == '' then
m = fTabReset(f_auto, 1, , 'a')
else if pos('a', m.m.opt) < 1 then
m.m.opt = 'a'm.m.opt
return fTab(m, rdr)
endProcedure fTabAuto
/*--- generate format for all fields of a stem of objects -----------*/
fTabDetect: procedure expose m.
parse arg m, b
do cx=1 to m.m.0
rxNm = m.m.cx.col
done.rxNm = m.m.cx.done
if m.m.cx.fmt == '' then
m.m.cx.fmt = fTabDetectFmt(b, left('.', rxNm \== '')rxNm)
end
ff = oFldD(m.b.1)
do fx=1 to m.ff.0
rxNm = substr(m.ff.fx, 2)
if done.rxNm \== 1 then do
cc = fTabAdd(m, rxNm)
m.cc.fmt = fTabDetectFmt(b, left('.', rxNm \== '')rxNm)
end
end
return
endProcedure fTabDetect
/*--- detect format for one field in stem st ------------------------*/
fTabDetectFmt: procedure expose m.
parse arg st, suf
lMa = -1
rMa = -1
bMa = -1
aDiv = 0
nMi = 9e999
nMa = -9e999
eMi = 9e999
eMa = -9e999
eDa = 2
dMa = -9e999
do sx=1 to m.st.0
v = mGet(m.st.sx || suf)
lMa = max(lMa, length(strip(v, 't')))
rMa = max(rMa, length(strip(v, 'l')))
bMa = max(bMa, length(strip(v, 'b')))
if \ dataType(v, 'n') then do
if length(v) > 100 then
aDiv = 99
else if aDiv <=3 then
if aDiv.v \== 1 then do
aDiv.v = 1
aDiv = aDiv + 1
end
iterate
end
v = strip(v)
nMi = min(nMi, v)
nMa = max(nMa, v)
ex = verify(v, 'eEfF', 'm')
if ex > 0 then do
eMa = max(eMa, substr(v, ex+1))
eMi = min(eMi, substr(v, ex+1))
v = left(v, ex-1)
do while pos(left(v,1), '+-0') > 0
v = substr(v, 2)
end
eDa = max(eDa, length(v) - (pos('.', v) > 0))
end
dx = pos('.', v)
if dx > 0 then do
do while right(v, 1) == 0
v = left(v, length(v)-1)
end
dMa = max(dMa, length(v)-dx)
end
end
if nMi > nMa | aDiv > 3 then
newFo = '-'max(1, (lMa+0))'C'
else if eMi <= eMa then do
newFo = ' ' || (eDa+max(length(eMa), length(eMi))+3) ,
|| '.'||(eDa-1)'e'
end
else do
be = max(length(trunc(nMi)), length(trunc(nMa)))
if dMa <= 0 then
newFo = max(be, bMa)'I'
else
newFo = max(be+1+dMa, bMa)'.'dMa'I'
end
return '%'newFo
endProcedure fTabDetectFmt
/* copy fTab end ***************************************************/
/* copy f begin ******************************************************/
/*--- format with the given format ggA1, ggA2, etc. -----------------*/
f: procedure expose m.
parse arg ggFmt, ggA1, ggA2
if symbol('M.f_gen.ggFmt') \== 'VAR' then
call fGen ggFmt, ggFmt
interpret m.f_gen.ggFmt
endProcedure f
fImm: procedure expose m.
parse arg ggFmt, ggA1
interpret m.f_gen.ggFmt
endProcedure fImm
fCache: procedure expose m.
parse arg a, fmt
if a \== '%>' then do
if symbol('M.f_gen.a') == 'VAR' then
if m.f_gen.a \== fmt then
call err 'fCache('a',' fmt') already' m.f_gen.a
end
else do
if symbol('m.f_gen0') == 'VAR' then
m.f_gen0 = m.f_gen0 + 1
else
m.f_gen0 = 1
a = '%>'m.f_gen0
end
m.f_gen.a = fmt
return a
endProcedure fCache
/*--- compile format fmt put in the cache with address a
this procedure handles precompile and calls fGenF ---------*/
fGen: procedure expose m.
parse arg a, fmt
if a \== '%>' then
if symbol('M.f_gen.a') == 'VAR' then
return a
r3 = right(fmt, 3)
if abbrev(r3, '%#') then do
if substr(r3, 3) = '' then
call err 'fGen bad suffix' fmt
if right(a, 3) \== r3 then
call err 'adr fmt mismatch' a '<->' fmt
fmt = left(fmt, length(fmt) - 3)
a = left(a, length(a) - 3)
if symbol('m.a') == 'VAR' then
call err 'base already defined' arg(2)
end
if \ abbrev(fmt, '%##') then
return fCache(a, fGenF(fmt))
parse var fmt '%##' fun ' ' rest
interpret 'return' fun'(a, rest)'
endProcedure fGen
/*--------------------------------------------------------------------
Format generator should be compatible with fPrint|
<<<< + extension of fPrint, - in fPrint but not implemented
%% %@ the escaped char
('@' argN? '.'? field)?'%' flags? width? ('.' precision)? specifier
specifier: is the most significant one and defines the type
- c Character rigPad or lefPad, prec ==> substr(..., prec)
- C Cut %-nC = left(v,n), %nC = right(v,n) %n.mC = substr(m, n)
- hH Characters in hex
- iI Signed decimal integer (padded or cut)
- eE Scientific notation (mantissa/exponent) using e character 3.92e+2
- S Strip (both)
- txy time date formatting from format x to format y see fTstGen
- kx units Formatting x = t=time d=decimal b=binary (k) B=binary (kB)
Flags:
- - Left-justify within the given field width; Right is default
- + print '+' before non negative numbers
-' ' print ' ' before non negative numbers
- / cut to length
preprocessor implemented in fGen
%##fun fmt format by function fun
%> address only
---------------------------------------------------------------------*/
fGenF: procedure expose m.
parse arg fmt
if symbol('m.f_s_0') \== 'VAR' then
m.f_s_0 = 1
else
m.f_s_0 = m.f_s_0 + 1
f_s = 'F_S_'m.f_s_0
call scanSrc f_s, fmt
ax = 0
cd = ''
cp = ''
do forever
txt = fText(f_s)
if txt \== '' then
cd = cd '||' quote(txt, "'")
if scanEnd(f_s) then
leave
if \ scanLit(f_s, '@') then do
ax = ax + 1
af = ''
hasDot = 0
end
else do
if scanWhile(f_s, '0123456789') then
ax = m.f_s.tok
else if ax < 1 then
ax = 1
hasDot = scanLit(f_s, '.')
af = fText(f_s)
end
if \ scanLit(f_s, '%') then
call scanErr f_s, 'missing %'
call scanWhile f_s, '-+ /'
flags = m.f_s.tok
call scanWhile f_s, '0123456789'
len = m.f_s.tok
if \ scanLit(f_s, '.') then
prec = ''
else do
call scanWhile f_s, '0123456789'
prec = m.f_s.tok
end
call scanChar f_s, 1
sp = m.f_s.tok
if ax < 3 | ass.ax == 1 then
aa = 'ggA'ax
else do
aa = 'arg(' || (ax+1) || ')'
if af \== '' then do
cp = cp 'ggA'ax '=' aa';'
aa = 'ggA'ax
ass.ax = 1
end
end
if af \== '' | hasDot then
aa = rxMGet(aa, af)
if sp == 'c' then do
if prec \== '' then
aa = 'substr('aa',' prec')'
if len == '' then
cd = cd '||' aa
else if pos('-', flags) > 0 then
cd = cd '|| lefPad('aa',' len')'
else
cd = cd '|| rigPad('aa',' len')'
end
else if sp == 'C' then do
if prec \== '' then do
cd = cd '|| substr('aa',' prec
if len == '' then
cd = cd')'
else
cd = cd',' len')'
end
else if len == '' then
cd = cd '||' aa
else if pos('-', flags) > 0 then
cd = cd '|| left('aa',' len')'
else
cd = cd '|| right('aa',' len')'
end
else if sp == 'H' then
cd = cd "|| fH("aa"," len',' (pos('-', flags) > 0)')'
else if sp == 'h' then
cd = cd "|| translate(fH("aa", '"siL"'),'abcdef','ABCDEF')"
else if sp == 'i' then
cd = cd "|| fI("aa"," len", '"flags"'," firstNS(prec, 0)")"
else if sp == 'I' then
cd = cd "|| fI("aa"," len", '/"flags"'," firstNS(prec, 0)")"
else if sp == 'E' | sp == 'e' then do
if len == '' then
len = 8
if prec = '' then
prec = len - 6
cd = cd "|| fE("aa"," len"," prec", '"sp"', '"flags"')"
end
else if sp = 'S' then
cd = cd '|| strip('aa')'
else if sp = 't' then do
call scanChar f_s, 2
cd = cd '||' fTstGen(m.f_s.tok, aa)
end
else if sp = 'k' then do
call scanChar f_s, 1
if pos(m.f_s.tok, 'tdbBiI') < 1 then
call scanErr f_s, "bad unit type" m.f_s.tok
if pos('+', flags) > 0 then
pl = ", '+'"
else if pos(' ', flags) > 0 then
pl = ", ' '"
else
pl = ''
cd = cd "|| fUnit('"m.f_s.tok || len"."prec"¢"pl"'," aa")"
end
else if sp == '(' then do
c1 = aa
do until m.f_s.tok = '%)'
sx = m.f_s.pos
do until m.f_s.tok == '%,' | m.f_s.tok == '%)'
call scanUntil f_s, '%'
if \ scanLit(f_s, '%,', '%)', '%') then
call scanErr f_s, '%( not closed'
end
c1 = "fImm('"fGen('%>', substr(m.f_s.src, sx,
, m.f_s.pos - sx - 2))"'," c1")"
end
cd = cd '||' c1
end
else do
call scanErr f_s, 'bad % clause'
call scanBack f_s, '%'sp
leave
end
end
if \ scanEnd(f_s) then
call scanErr f_s, "bad specifier '"m.f_s.tok"'"
m.f_s_0 = m.f_s_0 - 1
if cd \== '' then
return strip(cp 'return' substr(cd, 5))
else
return "return ''"
endProcedure fGenF
fText: procedure expose m.
parse arg f_s
res = ''
do forever
if scanUntil(f_s, '@%') then
res = res || m.f_s.tok
if scanLit(f_s, '%%', '%@') then
res = res || substr(m.f_s.tok, 2)
else if scanLit(f_s, '%>', '%##') then
res = res || m.f_s.tok
else
return res
end
endProcedure fText
fAll: procedure expose m.
parse arg fmt, rdr
i = jOpen(in2File(rdr), '<')
do while jRead(i)
call out f(fmt, m.i)
end
call jClose i
return
endProcedure fAll
/*--- format character2hex (if not sql null) ------------------------*/
fH: procedure expose m.
parse arg v, l, leftJ
if v \== m.sqlNull then
v = c2x(v)
if length(v) > l then
return v
else if leftJ \== 1 then
return right(v, l)
else
return left(v, l)
endProcedure fH
/*--- format integer or fixPoint Decimal ----------------------------*/
fI: procedure expose m.
parse arg v, l, flags, d
if \ datatype(v, 'n') then
return fRigLeft(strip(v), l, flags)
v = format(v, , d, 0)
if pos('+', flags) > 0 then
if \ abbrev(v, '-') then
v = '+'v
if length(v) > l then
if pos('/', flags) > 0 then
return left('', l, '*')
else
return v
return fRigLefPad(v, l, flags)
endProcedure fI
/*--- format with exponent l=total output len
d=number of digits after . in mantissa
c=exponent character
flags: - to ouput text left justified
differences: exponent is always printed but without +
overflow ==> expand exponent, *****, 0e-999 --------*/
fE: procedure expose m.
parse arg v, l, d, c, flags
if \ datatype(v, 'n') then
return fRigLeft(v, l, flags)
if pos(' ', flags) < 1 then
if v >= 0 then
if pos('+', flags) > 0 then
return '+'substr(fE(v, l, d, c, ' 'flags), 2)
else
return substr(fE(v, l+1, d+1, c, ' 'flags), 2)
x = format(v, 2, d, 7, 0)
m = 2 + d + (d>0)
call assert "length(x) == m+9", 'm x length(x)'
if substr(x, m+1) = '' then
return left(x, m)c || left('', l-m-1, 0)
call assert "substr(x, m+1, 1) == 'E'","exponenent in x not at m"
y = verify(x, '0', 'n', m+3)
call assert 'y>0'
if substr(x, m+1, 2) == 'E+' then do
if m+10-y <= l-m-1 then
return left(x,m)c || right(x, l-m-1)
z = l - 4 - (m+10-y)
end
else if substr(x, m+1, 2) == 'E-' then do
if m+10-y <= l-m-2 then
return left(x,m)c'-'right(x, l-m-2)
z = l - 5 - (m+10-y)
end
else
call err 'bad x' x
if z >= -1 & max(0, z) < d then
return fE(v, l, max(0, z), c, flags)
else if substr(x, m+1, 2) == 'E-' then
return left(x,1)'0'c'-'left('', l-4, 9)
else
return left('', l, '*')
endProcedure fE
/*--- right or left with truncation ---------------------------------*/
fRigLeft: procedure expose m
parse arg s, len, flags
if length(s) = len then
return s
else if pos('-', flags) > 0 | length(s) > len then
return left(s, len)
else
return right(s, len)
endProcedure fRigLefPad
/*--- right or left pad without truncation --------------------------*/
fRigLefPad: procedure expose m
parse arg s, len, flags
if pos('-', flags) > 0 then
if length(strip(s, 't')) >= len then
return strip(s, 't')
else
return left(s, len)
else
if length(strip(s, 'l')) >= len then
return strip(s, 'l')
else
return right(s, len)
endProcedure fRigLefPad
/*-- return char i+1 from codes cc ----------------------------------*/
fI2C: procedure expose m.
parse arg i, cc
if i >= length(cc) then
call err 'no code for fI2C('i',' cc')'
return substr(cc, i+1, 1)
/*-- return pos-1 for char c in codes -------------------------------*/
fC2I: procedure expose m.
parse arg c, codes
res = pos(c, codes)
if res > 0 then
return res - 1
call err 'not a code fI2C('c',' codes')'
/*--- generate timestamp format, derive from %t.. ------------------*/
fTstGen: procedure expose m.
parse arg ft, s
fmt = '%t'ft
if symbol('M.f_gen.fmt') \== 'VAR' then
m.f_gen.fmt = 'return' fTstGe2(ft, 'ggA1')
code = m.f_gen.fmt
if \ abbrev(code, 'return ') then
call err 'fTstGen' ft 'bad code' code
if pos('ggA1', code) == lastPos('ggA1', code) ,
| verify(s, '()', 'm') < 1 then
return repAll(substr(code, 8), 'ggA1', s)
else
return "fImm('"fmt"'," s")"
endProcedure fTstGen
/*--- generate timestamp formats: from format c to format d ---------*/
fTstGe2: procedure expose m.
parse arg c 2 d, s
/* special L = LRSN in Hex
l = lrsn (6 or 10 Byte) */
if c == 'L' then
return fTstGen('S'd, 'timeLRSN2LZT('s')')
if c == 'l' then
return fTstGen('S'd, 'timeLRSN2LZT(c2x('s'))')
cd = c || d
if symbol('m.f_tstFo.c') \== 'VAR' ,
| symbol('m.f_tstFo.d') \== 'VAR' then do
if m.f_tstIni == 1 then
call err "bad timestamp from or to format '"cd"'"
m.f_tstIni = 1
m.f_tstScan = 0
a = 'F_TSTFO.'
/* Y: year//25 A = 2000 Y=2024
Z: year//20 A = 2010 deimplement
M: month B=Januar ...,
A: first digit of day A=0, D=30
B: day 1=1 10=A 31=V deimplement
H: hour first digit A=0 B=10 C=20 D=30
I: hour 1=A, 10=K 23=X
qr: minuten//10, sec ==> aa - xy base 25 */
m.f_tstPics = 'yz345678himnstabcdefYZMAHIjJlLuqr'
m.f_tstZero = '00010101000000000000???AAA??00?AA'
m.f_tstN0 = 'yz345678 hi:mn:st'
m.f_tstN = 'yz345678 hi:mn:st.abcdef'
m.f_tstS0 = 'yz34-56-78-hi.mn.st'
m.f_tstS = 'yz34-56-78-hi.mn.st.abcdef'
call mPut a'S', m.f_tstS
call mPut a's', m.f_tstS0
call mPut a' ', m.f_tstS0
call mPut a'D', 'yz345678'
call mPut a'd', '345678'
call mPut a't', 'hi.mn.st'
call mPut a'T', 'hi:mn:st.abcdef'
call mPut a'E', '78.56.yz34'
call mPut a'e', '78.56.34'
call mPut a'Y', 'YM78Imqr'
call mPut a'Z', 'ZM78' /* deimplement */
call mPut a'M', 'M78himns'
/* call mPut a'I', 'M78Imnst' */
call mPut a'A', 'A8himnst'
/* call mPut a'B', 'YMBImnst' */
call mPut a'H', 'Himnst'
call mPut a'n', m.f_tstN0
call mPut a'N', m.f_tstN
call mPut a'j', 'jjjjj' /* julian date 34jjj */
call mPut a'J', 'JJJJJJ' /* day since 1.1.00: 6 digits */
call mPut a'l', copies('l', 10) /*LRSN out 10 Byte, input var*/
call mPut a'L', copies('L', 20) /* LRSN in hex */
call mPut a'u', 'uuuuuuuu' /* Unique */
return fTstGen(cd, s)
end
if c == ' ' then do
if pos(d, 'SN') > 0 then
return fTstGen('N'd, "date('S') time('L')")
else if pos(d, 'sMAn ') > 0 then
return fTstGen('n'd, "date('S') time()")
else if pos(d, 'DdEeY') > 0 then
return fTstGen('D'd, "date('S')")
else if pos(d, 'tH') > 0 then
return ftstGen('t'd, "time()")
else if pos(d, 'T') > 0 then
return fTstGen('T'd, "time('L')")
else
call err "fTstGe2 implement ' '->"d
end
return ftstGFF(m.f_tstFo.c, m.f_tstFo.d, s)
endProcedure fTstGe2
/*--- nest source s into code (at $)
if source is not simpe and used several times then
use fImm to avoid muliple evaluations ---------------------*/
fTstNest: procedure expose m.
parse arg code, s
if pos('$', code) == lastPos('$', code) ,
| verify(s, '(). ', 'm') < 1 then
return repAll(code, '$', s)
a = fCache('%>', 'return' repAll(code, '$', 'ggA1'))
return "fImm('"a"'," s")"
endProcedure fTstFi
/*--- return rexx code for timestamp conversion
from pic f to pic t for source s ------------------------------*/
fTstgFF: procedure expose m.
parse arg f, t, s
if verify(f, 'lLjJu', 'm') > 0 then do /* special cases */
if f == 'l' then do
if t == 'l' then
return 'timeLrsn10('s')'
else if t == 'L' then
return 'c2x(timeLrsn10('s'))'
else if verify(t, 'lL', 'm') = 0 then
return fTstFi(m.fTst_fo.S, t, 'timeLrsn2LZT('s')')
end
call err 'fTstgFF implement' f 'to' t
end
m.f_tstScan = m.f_tstScan + 1
a = f_tstScan || m.f_tstScan
call scanSrc a, t
cd = ''
pc = '' /* permutations and constants */
do until t == ''
c1 = '' /* a rexx function / expression */
p1 = '' /* permutations and constants */
tPos = m.a.pos
call scanChar a, 1
t = m.a.tok
if pos(t, f' .:-') > 0 then do
call scanVerify a, f' .:-', 'n'
p1 = t || m.a.tok /* permutate pics or constants */
end
else if pos(t, m.f_tstPics) <= 0 then do
p1 = m.a.tok /* constants */
end
else if t == 'y' then do /* year */
if scanLit(a, 'z34') then do
if pos('34', f) > 0 then
c1 = "timeYear24(substr("s "," pos('34', f)", 2))"
else if pos('Y', f) > 0 then
c1 = "timeY2Year(substr("s "," pos('Y', f)", 1))"
end
end
else if t == '3' then do
if scanLit(a, '4') then
if pos('Y', f) > 0 then
c1 = "substr(timeY2Year(substr("s,
"," pos('Y', f)", 1)), 3)"
end
else if t == 'Y' then do
if pos('34', f) > 0 then
c1 = "timeYear2Y(substr("s "," pos('34', f)", 2))"
end
else if t == 'Z' then do
if pos('34', f) > 0 then
c1 = "timeYear2Z(substr("s "," pos('34', f)", 2))"
end
else if t == '5' then do /* month */
if scanLit(a, '6') then
if pos('M', f) > 0 then
c1 = "timeM2Month(substr("s"," pos('M', f)", 1))"
end
else if t == 'M' then do
if pos('56', f) > 0 then
c1 = "timeMonth2M(substr("s"," pos('56', f)", 2))"
end
else if t == '7' then do /* day */
if scanLit(a, '8') then
c1 = fTstGetDay(f, s)
end
else if t == 'A' then do
if scanLit(a, '8') then do
c1 = fTstGetDay(f, s)
if c1 \== '' then
c1 = fTstNest("fI2C(left($, 1), 'ABCD')" ,
|| "right($, 1)", c1)
end
end
else if t == 'h' then do /* hour */
if scanLit(a, 'i') then
c1 = fTstGetHour(f, s)
end
else if t == 'n' then do /* hour */
if scanLit(a, 'i') then
c1 = fTstGetHour(f, s)
else if pos('qr', f) > 0 then do
call scanLit a, 'st', '.st', ':st', 's', '.s', ':s'
c1 = "fqr2ms(substr("s"," pos('qr', f)", 2)" ,
|| ", '"left(m.a.tok, abbrev(m.a.tok, '.') ,
| abbrev(m.a.tok, ':'))"')"
if right(m.a.tok, 1) \== 't' then
c1 = "left("c1"," 1 + length(m.a.tok)")"
end
end
else if t == 'H' then do
if scanLit(a, 'i') then do
c1 = fTstGetHour(f, s)
if c1 \== '' then
c1 = fTstNest("fI2C(left($, 1), 'ABC')" ,
|| "right($, 1)", c1)
end
end
else if t == 'I' then do
c1 = fTstGetHour(f, s)
if c1 \== '' then
c1 = "fI2C("c1", m.ut_uc25)"
end
else if t == 'j' then do /* julian */
if scanLit(a, 'jjjj') then
c1 = "time2jul(" fTstGFF(f, 'yz34-56-78', s)")"
end
else if t == 'J' then do /* day since 1.1.1 */
if scanLit(a, 'JJJJJ') then
c1 = "date('B'," fTstGFF(f, 'yz345678', s)", 's')"
end
else if t == 'l' then do /* 10 byte lrsn */
if scanLit(a, copies('l', 9)) then
c1 = "x2c(timeLZT2LRSN("fTstGFF(f, m.f_tstS, s)"))"
end
else if t == 'L' then do /* lrsn in 20 hex */
if scanLit(a, copies('L', 19)) then
c1 = "timeLZT2LRSN("fTstGFF(f, m.f_tstS, s)")"
end
else if t == 'u' then do /* 8 byte utility unique */
if scanLit(a, 'uuuuuuu') then
c1 = "timeLrsn2Uniq(timeLZT2LRSN(",
|| fTstGFF(f, m.f_tstS, s)"))"
end
else if t == 'q' then do /* 8 byte utility unique */
if scanLit(a, 'r') then
if pos('n', f) > 0 then do
c1 = "fms2qr(substr("s"," pos('n', f)", 1),"
if pos('st', f) > 0 then
c1 = c1 "substr("s"," pos('st', f)", 2))"
else if pos('s', f) > 0 then
c1 = c1 "substr("s"," pos('s', f)", 1)'0')"
else
c1 = c1 "0)"
end
end
if c1 == '' & p1 == '' & t \== '' then /* nothing -> zero */
p1 = translate(substr(m.a.src, tPos, m.a.pos-tPos),
, m.f_tstZero, m.f_tstPics)
pc = pc || p1
if (c1 \== '' | t == '') & pc \== '' then do/*append pc to cd*/
if verify(pc, m.f_tstPics, 'm') == 0 then
cd = cd '||' quote(pc, "'")
else if pc == f then
cd = cd '||' s
else if pos(pc, f) > 0 then
cd = cd "|| substr("s"," pos(pc, f)"," length(pc)")"
else
cd = cd "|| translate('"pc"'," s", '"f"')"
pc = ''
end
if c1 \== '' then /* append pc to cd */
cd = cd '||' c1
end
m.f_tstScan = m.f_tstScan - 1
if cd == '' then
return "''"
else
return substr(cd, 5)
endProcedure fTstGFF
/*--- return code for day, d1Only = first digit only ----------------*/
fTstGetDay: procedure expose m.
parse arg f, s
if pos('78', f) > 0 then
return "substr("s"," pos(78, f)", 2)"
if pos('A', f) > 0 then
if pos('8', f) > 0 then
return "fc2i(substr("s"," pos('A', f)", 1), 'ABCD')",
|| "substr("s"," pos('8', f)", 1)"
return ''
endProcedure fTstGetDay
/*--- return code for hour in 2 digits ------------------------------*/
fTstGetHour: procedure expose m.
parse arg f, s
if pos('hi', f) > 0 then
return "substr("s"," pos('hi', f)", 2)"
if pos('Hi', f) > 0 then
return "fC2I(substr("s"," pos('Hi', f)", 1), 'ABC')" ,
|| "substr("s"," pos('Hi', f) + 1", 1)"
if pos('I', f) > 0 then
return "right(fC2I(substr("s"," pos('I', f)", 1)," ,
"m.ut_uc25), 2, 0)"
return ''
endProcedure fTstGetHour
fms2qr: procedure expose m.
parse arg m, s
t = (m // 10) * 60 + s
return substr(m.ut_uc25, t % 25 + 1,1),
|| substr(m.ut_uc25, t // 25 + 1,1)
fqr2ms: procedure expose m.
parse arg q, sep
v = pos(left(q, 1), m.ut_uc25) * 25 ,
+ pos(substr(q, 2, 1), m.ut_uc25) - 26
return (v % 60) || sep || right(v // 60, 2, 0)
fWords: procedure expose m.
parse arg fmt, wrds
f2 = '%##fCatFmt' fmt
if wrds = '' then
return f(f2'%#0')
res = f(f2'%#1', word(wrds, 1))
do wx=2 to words(wrds)
res = res || f(f2, word(wrds, wx))
end
return res || f(f2'%#r')
endProcedure fWords
fCat: procedure expose m.
parse arg fmt, st
return fCatFT(fmt, st, 1, m.st.0)
fCatFT: procedure expose m.
parse arg fmt, st, fx, tx
f2 = '%##fCatFmt' fmt
if tx < fx then
return f(f2'%#0')
res = f(f2'%#1', m.st.fx)
do sx=fx+1 to tx
res = res || f(f2, m.st.sx)
end
return res || f(f2'%#r')
endProcedure fCatFT
fCatFmt: procedure expose m.
parse arg adr, fmt
v.m = '' /* middle */
v.l = '' /* left */
v.r = '' /* right */
v.a = '%c' /* all rows */
nm = M
cx = 1
do forever /* split clauses */
cy = pos('#', fmt, cx)
if cy < 1 then do
v.nm = substr(fmt, cx)
leave
end
v.nm = substr(fmt, cx, cy-cx)
nm = translate(substr(fmt, cy+1, 1))
cx = cy+2
end
if symbol('v.2') \== 'VAR' then /* second and following */
v.2 = v.M || v.a
adr = fGen(adr, v.2)
if symbol('v.0') \== 'VAR' then /* empty */
v.0 = v.l || v.r
call fGen adr'%#0', v.0
if symbol('v.1') \== 'VAR' then /* first row */
v.1 = v.l || v.a
call fGen adr'%#1', v.1
call fGen adr'%#r', v.R
return adr
endProcedure fCatFmt
/*--- format with units seconds ==> 3d13 oder 5.43e6 ==> 5M43 -------*/
fUnit: procedure expose m.
parse arg uFmt, v /* scale, aLen, aPrec, plus */
uF = 'F_UNIT.'uFmt /* address of (global) format */
if symbol('m.uF.0') \== 'VAR' then
call fUnitGen uFmt
if \ dataType(v, 'n') then
return right(v, m.uF.len)
uS = uF'!' || (v >= 0) /* address of signed format */
v = abs(v) /* always get rid also of sign of -0 | */
do fx=11 to m.uF.0-1 while v >= m.uS.fx.lim1 /* search range */
end
if fx = 11 & v <> trunc(v) then do
do fx=10 by -1 to m.uF.min while v < m.uS.fx.lim1
end
fx = fx + 1
end
do fx=fx to m.uF.0 /* try to format */
uU = uS'.'fx
w = format(v * m.uU.fact, , m.uU.prec) /* address of Unit */
if pos('E-', w) > 0 then
w = format(0, , m.uU.prec)
if w < m.uU.lim2 then do
if m.uU.kind == 'r' then
x = m.uS.sign || w || m.uU.unit
else if m.uU.kind == 'm' then
x = m.uS.sign || (w % m.uU.mod) || m.uU.mUnit ,
|| right(w // m.uU.mod, m.uF.len2, 0)
else
call err 'bad kind' m.uU.kind 'in uU' uU
if length(x) <= m.uF.len then
return right(x, m.uF.len)
end
end
return left(m.uS.sign, m.uF.len, '+')
endProcedure fUnit
/*--- generate all format entries for given scale -------------------*/
aLen = total len, pLen =len of +, sLen = len of current sign ---*/
fUnitGen: procedure expose m.
parse arg uFmt
parse arg scale 2 aMid '¢' plus
parse var aMid aLen '.' aPrec
if pos('!', uFmt) > 0 then
call err 'bad fUnit format' uFmt
sc = 'F_SCALE.'scale
uF = 'F_UNIT.'uFmt /* address of (global) format */
if symbol('m.sc.0') \== 'VAR' then do
call fUnitIni
if symbol('m.sc.0') \== 'VAR' then
call err 'bad scale' sc 'for fUnitGen('uFmt')'
end
hasM = scale = 't'
if aPrec == '' then
if scale = 't' then
aPrec = 2
else
aPrec = 0
if aLen = '' then
if scale = 't' then
aLen = length(plus) + 3 + aPrec
else
aLen = aPrec + (aPrec >= 0) + 4 + length(plus)
m.uF.len2 = aPrec
if hasM then
aPrec = 0
m.uF.len = aLen
m.uF.0 = m.sc.0
m.uF.min = m.sc.min
do geq0=0 to 1
uS = uF'!'geq0 /* address of signed format */
if geq0 then do
m.uS.sign = plus
end
else do
m.uS.sign = '-'
end
sLen = length(m.uS.sign)
dLen = aLen - sLen - hasM
limR = '1e' || (aLen -sLen - hasM - (aPrec > 0) - aPrec)
limM = '1e' || (aLen - m.uF.len2 - 1 - sLen)
do ix=m.sc.0 by -1 to m.sc.min
uU = uS'.'ix /* address of one unit */
m.uU.unit = m.sc.ix.unit
m.uU.fact = m.sc.ix.fact
m.uU.val = m.sc.ix.val
m.uU.kind = m.sc.ix.kind
m.uU.Len = aLen
m.uU.prec = aPrec
if m.uU.kind = 'r' then do
m.uU.lim2 = limR
m.uU.lim1 = limR * m.uU.val
end
else do
iy = ix + 1
iz = ix + 2
m.uU.mUnit = m.sc.iy.unit
m.uU.mod = m.sc.iy.val % m.sc.ix.val
m.uU.wid2 = aPrec
if iz <= m.sc.0 & m.sc.iz.kind == 'm' then
m.uU.lim1 = m.sc.iz.val
else
m.uU.lim1 = limM * m.sc.iy.val
m.uU.lim2 = m.uU.lim1 % m.uU.val
end
end
end
return
endProcedure fUnitGen
fUnitIni: procedure expose m.
if m.f_unit_ini == 1 then
return
m.f_unit_ini = 1
/* 0 5 10 5 20 */
iso = ' afpnum kMGTPE '
sB = f_Scale'.b'
sD = f_Scale'.d'
sT = f_Scale'.t'
fB = 1
fD = 1
call fUnitIni2 sB, 11, ' ', 'r', fB
m.sB.0 = 17
m.sB.min = 11
call fUnitIni2 sD, 11, ' ', 'r', fD
m.sD.0 = 17
m.sd.min = 5
do x=1 to 6
fB = fB * 1024
/* call fUnitIni2 sB, (11-x), substr(iso, 11-x, 1), 'r', fB*/
call fUnitIni2 sB, (11+x), substr(iso, 11+x, 1), 'r', 1/fB
fD = fD * 1000
call fUnitIni2 sD, (11+x), substr(iso, 11+x, 1), 'r', 1/fD
call fUnitIni2 sD, (11-x), substr(iso, 11-x, 1), 'r', fD
end
kilo = 'k'
m.sB.u2v.k = m.sB.u2v.kilo
m.sD.u2v.k = m.sD.u2v.kilo
m.sT.0 = 16
m.sT.min = 11
call fUnitIni2 sT, 11, ' ', 'm', 100
call fUnitIni2 sT, 12, 's', 'm', 1
call fUnitIni2 sT, 13, 'm', 'm', 1/60
call fUnitIni2 sT, 14, 'h', 'm', 1/3600
call fUnitIni2 sT, 15, 'd', 'm', 1/3600/24
call fUnitIni2 sT, 16, 'd', 'r', 1/3600/24
return 0
endProcedure fUnitIni
fUnitIni2: procedure expose m.
parse arg sc, ix, u, ki, fa
sb = sc'.'ix
m.sb.kind = ki
m.sb.fact = fa
m.sb.unit = u
m.sb.val = 1 / fa
if m.sb.fact > 1 then
m.sb.fact = format(fa, , 0)
else
m.sb.val = format(m.sb.val, , 0)
m.sc.u2v.u = m.sb.val
return
endProcedure fUnitIni2
fUnitsF1I0: procedure expose m.
parse arg sc, ix
si = sc'.'ix
parse arg , , m.si.kind, aU, m.si.fact,
, m.si.lim2, m.si.len,
, m.si.mod, m.si.len2
m.si.unit = aU
m.sc.u2f.aU = ''
if \ datatype(ix, 'n') then
return si
m.sc.u2f.aU = 1 / m.si.fact
if symbol('m.sc.0') \== 'VAR' then do
m.sc.0 = ix
m.sc.min = ix
end
else do
m.sc.0 = max(ix, m.sc.0)
m.sc.min = min(ix, m.sc.min)
end
return si
endProcedure fUnitsF1I0
fUnit2I: procedure expose m.
parse arg b, v
v = strip(v)
if datatype(v, 'n') then
return v
u = right(v, 1)
key = f_Scale'.' || b'.U2V.'u
if symbol('m.key') == 'VAR' then
return strip(left(v, length(v)-1)) * m.key
if m.f_unit_ini \== 1 then
return fUnit2I(b, v, fUnitIni())
call err 'bad unit' u 'or base' b 'for' v
endProcedure fUnit2I
/* copy f end ******************************************************/
/* copy err begin *** errorhandling, messages, help ***************/
errIni: procedure expose m.
if m.err_ini == 1 then
return
m.err_ini = 1
m.err_saySay = 1
m.err_sayOut = 0
m.err_handler = ''
m.err_handler.0 = 0
m.err_cleanup = '\?'
m.err_opt = ''
m.err_nest = 0
parse source m.err_os .
m.tso_ddAll = ''
m.err_ispf = 0
m.err_screen = 0
if m.err_os \== 'LINUX' then do
address tso 'profile MsgId' /* brauchen wir in tsoAlloc| */
if sysVar('sysISPF') = 'ACTIVE' then do
m.err_ispf = 1
address ispExec 'vget (zScreen zScreenD zScreenW) shared'
m.err_screen = zScreen
m.err_screenD = zScreenD
m.err_screenW = zScreenW
end
end
return
endProcedure errIni
/* configure err ----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err_opt, m.err_handler
upper m.err_opt
call errSetSayOut '-'
m.err_handler.0 = 0
if pos('I', m.err_opt) > 0 & m.err_ispf then
address ispExec 'control errors return'
return
endSubroutine errReset
/*--- set sayOut and sysSay -----------------------------------------*/
errSetSayOut: procedure expose m.
parse upper arg flags
if flags \== '-' then
m.err_opt = space(translate(m.err_opt, ' ' ,'OS')flags, 0)
m.err_sayOut = pos('O', m.err_opt) > 0
m.err_saySay = pos('S', m.err_opt) > 0 | \ m.err_sayOut
return
endProcedure errSetSayOut
/*--- 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
/* push error handler -----------------------------------------------*/
errHandlerPush: procedure expose m.
parse arg aH
ex = m.err_handler.0 + 1
m.err_handler.0 = ex
m.err_handler.ex = m.err_handler
m.err_handler = aH
return
endProcedure errHandlerPush
/* push error handler return Constant value -------------------------*/
errHandlerPushRet: procedure expose m.
parse arg rv
call errHandlerPush "return '"rv"'"
return
/* pop error handler -----------------------------------------------*/
errHandlerPop: procedure expose m.
if m.err_handler.0 < 1 then
call err 'errHandlerPop but err_handler.0='m.err_handler.0
ex = m.err_handler.0
m.err_handler = m.err_handler.ex
m.err_handler.0 = ex - 1
return
endProcedure errHandlerPop
/* pop error handler -----------------------------------------------*/
errHandlerCall:
interpret m.err_handler
m.err_handlerReturned = 0
return ''
endProcedure errHandlerCall
/*--- error routine: abend with message -----------------------------*/
err:
parse arg ggTxt, ggOpt
if abbrev(ggOpt, '^') then
return substr(ggOpt, 2)
call errIni
ggNx = m.err_nest + 1
m.err_nest = ggNx
m.err_nest.ggNx = ggTxt
if ggNx \== 1 & ggNx \== 2 then do ggNx=ggNx by -1 to 1
say ' error nesting.'ggNx '==>' m.err_nest.ggNx
end
drop err handler cleanup opt call return stackHistory
if ggOpt == '' & m.err_handler <> '' then do
m.err_handlerReturned = 1
ggRet = errHandlerCall()
ggDoR = m.err_handlerReturned
m.err_handlerReturned = 1
if ggDoR then do
m.err_nest = m.err_nest - 1
return ggRet
end
end
call errSay 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_cat == 'f' then
x = show + stackHistory + by + bad + arithmetic + conversion
call errSay ' }errorhandler exiting with exit(12)'
m.err_nest = m.err_nest - 1
exit errSetRc(12)
endSubroutine err
/*--- 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 = delStr(m.err_cleanup, cx, length(code)+2)
return
endProcedure errRmCleanup
errCleanup: procedure expose m.
call errIni
m.err_saySay = 1
m.err_sayOut = 0
if m.err_cleanup <> '\?' then do
do while m.err_cleanup <> '\?'
cx = pos('\?', m.err_cleanup, 3)
c1 = substr(m.err_cleanup, 3, cx-3)
m.err_cleanup = substr(m.err_cleanup, cx)
say 'errCleanup doing' c1
interpret c1
end
say 'errCleanup end doing err_cleanup'
end
if m.tso_ddAll <> '' then
call tsoFree m.tso_ddAll, 1
return
endProcedure errCleanup
/*--- say an errorMessage msg with pref and linesplits --------------*/
errSay: procedure expose m.
parse arg msg
return errSaySt(splitNl(err_l, 0, errMsg(msg)))
errSaySt: procedure expose m.
parse arg st
if m.err_saysay | \ m.err_sayOut then
call saySt st
if m.err_sayOut & \ ( m.err_saySay & m.j.out == m.j.say) then
call outSt st
return st
endProcedure errSaySt
/*--- prefix an errormessage with pref,
split it into lines at \n to stem m.err -------------------*/
errMsg: procedure expose m.
parse arg msg
m.err_cat = 'f'
do while substr(msg, 2, 1) == '}'
parse var msg m.err_cat '}' msg
end
if m.err_cat == ' ' | m.err_cat == 'o' then
return msg
pTxt = ',fatal error,error,input error,scanErr,warning,onlyMsg,'
px = pos(','m.err_cat, pTxt)
if px < 1 then do
px = 1
m.err_cat = 'f'
end
pre = substr(pTxt, px+1, pos(',', pTxt, px+2)-px-1)
if m.err_cat == 's' then
return pre msg
parse source . . s3 . /* current rexx */
return pre 'in' s3':' msg
endProcedure errMsg
/*--- fill stem st with lines of msg separated by \n ----------------*/
splitNl: procedure expose m.
parse arg st, sx, msg
bx = 1
sx = firstNS(sx, 1)
do lx=sx+1 to sx+999
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
/*--- out msg lines separated by \n ---------------------------------*/
outNL: procedure expose m.
parse arg msg
return outSt(splitNl(err_outNl, 0, msg))
/*--- say msg lines separated by \n ---------------------------------*/
sayNl: procedure expose m.
parse arg msg
return saySt(splitNl(err_outNl, 0, msg))
/*--- say (part of) the lines of a stem -----------------------------*/
saySt: procedure expose m.
parse arg st, fx, tx
do lx=firstNS(fx, 1) to firstNS(tx, m.st.0)
say strip(m.st.lx, 't')
end
return st
endProcedure saySt
/*--- 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_Num = '0123456789'
/* 012345678901234567890123456789 */
m.ut_lc = 'abcdefghijklmnopqrstuvwxyz'
m.ut_uc = translate(m.ut_lc)
m.ut_uc25 = left(m.ut_uc, 25)
m.ut_Alfa = m.ut_lc || m.ut_uc
m.ut_alfNum = m.ut_alfa || m.ut_Num
m.ut_alfDot = m.ut_alfNum || '.'
m.ut_alfId = m.ut_alfNum'_' /* avoid rexx allowed @ # $ ¬ . | ? */
m.ut_alfIdN1 = m.ut_Num /* 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_space = '05'x' ' /* with space: space and Tab char */
m.ut_alfPrint = m.ut_alfNum'+-*/=()¢!{}<> .:,;?|''"%&#@$£\_'
m.ut_numUc = m.ut_num || m.ut_uc
m.ut_base64 = m.ut_uc || m.ut_lc || m.ut_Num'+-'
m.ut_alfLC = m.ut_lc /* backward compatibility */
m.ut_alfUC = m.ut_uc /* backward compatibility */
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
/*--- strip and returnn first argument not space --------------------*/
firstNS: procedure expose m.
do ax=1 to arg()
if arg(ax) <> '' then
return strip(arg(ax))
end
return ''
endProcedure firstNS
/*--- return current time and cpu usage -----------------------------*/
utTime: procedure expose m.
return time() 'ela='time('E') 'cpu='sysvar('syscpu'),
'su='sysvar('syssrv')
/*--- sleep several seconds -----------------------------------------*/
sleep: procedure expose m.
parse arg secs, sayIt
if sayit <> 0 then
say time() 'sleeping' secs 'secs'
CALL SYSCALLS 'ON'
ADDRESS SYSCALL "sleep" secs
CALL SYSCALLS 'OFF'
if sayit <> 0 then
say time() 'slept' secs 'secs'
return
endProcedure sleep
/*--- left without truncation ---------------------------------------*/
lefPad: procedure expose m
parse arg s, len
if length(strip(s, 't')) >= len then
return strip(s, 't')
return left(s, len)
endProcedure lefPad
/*--- right without truncation --------------------------------------*/
rigPad: procedure expose m
parse arg s, len
if length(strip(s, 'l')) >= len then
return strip(s, 'l')
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_lc, m.ut_uc)
/*--- 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
/*--- character to decimal '0140'x --> 256+64=320 -------------------*/
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
endProcedure utc2d
utInter: procedure expose m.
interpret arg(1)
return
endProcedure utInter
/* copy ut end *******************************************************/
/* copy tstAll begin ************************************************/
tstAll: procedure expose m.
say 'tstAll' m.myWsh '8.7.16...............'
call tstBase
call tstComp
call tstDiv
if m.err_os = 'TSO' then do
call tstZos
call tstTut0
end
call tstTimeTot
return 0
endProcedure tstAll
/*--- with also the slow tests --------------------------------------*/
tstAlLong: procedure expose m.
call tstIni
m.tst_long = 1
return tstAll()
endProcedure tstAll
/****** tstZos *******************************************************/
tstZOs:
call tstTime
call tstTime2Tst
call tstII
call sqlIni
call tstSqlRx
call tstSql
if m.tst_csmRZ \== '' then do
call tstSqlCsm
call tstSqlWsh
call tstSqlWs2
end
call scanReadIni
call tstSqlCall
call tstSqlC
call tstSqlCsv
call tstSqlRxUpd
call tstSqlUpd
call tstSqlUpdPre
call tstSqlE
call tstSqlB
call tstSqlO
call tstSqlO1
call tstSqlO2
call tstSqlStmt
call tstSqlStmts
call tstSqlUpdComLoop
call tstSqlS1
call tstSqlFTab
call tstSqlFTab2
call tstSqlFTab3
call tstSqlFTab4
call tstSqlFTab5
call tstsql4obj
call tstdb2Ut
call tstMain
call tstHookSqlRdr
call tstCsmExWsh
call tstTotal
return
endProcedure tstZOs
/*--- manualTest for csi --------------------------------------------*/
tstCsi: procedure expose m.
if 0 then do
call lmd 'A540769.*K'
call tstCsiCla 'A540769.WK.REXX'
call tstCsiCla 'A540769.AAA.DATASETS'
call tstCsiCla 'A540769.RRR.DATASETS'
end
if 1 then do
call tstCsiOpNx 'A540769.WK.*E*'
call tstCsiOpNx 'A540769.AAA.DATASETS'
call tstCsiOpNx 'A540769.RRR.DATASETS'
end
if 1 then do
call tstCsiNxCl 'A540769.WK.**'
call tstCsiNxCl 'DSN.**'
call tstCsiNxCl 'DP4G.**'
end
return
tstCsiOpNx: procedure expose m.
parse arg ds
m = 'NUE123'
s = 'res89'
flds = 'devtyp volser mgmtclas comudsiz NOBYTTRK UDATASIZ HARBA'
say 'csiOpen' ds
call csiOpen m, ds, flds
do while csiNext(m, s)
say m.s 'dev' c2x(m.s.devTyp) ,
'vol' m.s.volSer 'cla' m.s.mgmtclas,
'comuDsiz' m.s.comuDsiz 'noBytTrk' m.s.noBytTrk,
'udatasiz' c2x(m.s.udatasiz) ,
'harba' c2x(m.s.harba)
end
return
tstCsiNxCl: procedure expose m.
parse arg ds
m = 'ABC123'
s = 'efg89'
flds = 'devtyp volser mgmtclas'
say 'csiOpen' ds
call csiOpen m, ds, flds
say timing() 'begin'
do i=1 while csiNext(m, s)
nn = csiArcTape(m.s.volser, m.s.mgmtClas, m.s.devtyp, m.s)
/* oo = csiCla(strip(m.s))
if oo <> nn then
say nn '<>' oo m.s
*/ if i // 1000 = 0 then
say timing() i nn m.s
end
say timing() (i-1) nn m.s
return
endProcedure tstCsiNxCl
tstMbrList: procedure expose m.
/*
$=/tstMbrList/
### start tst tstMbrList ##########################################
#noPds: -99 mbrs in A540769.TMP.TST.MBRLIST
#1: 1 mbrs in A540769.TMP.TST.MBRLIST
1 EINS
#0: 0 mbrs in A540769.TMP.TST.MBRLIST
#4: 4 mbrs in A540769.TMP.TST.MBRLIST
1 DREI
2 FUENF
3 VIER
4 ZWEI
#*IE*: 3 mbrs in A540769.TMP.TST.MBRLIST(*IE*)
1 IE
2 NNNIE
3 VIER
#*_IE*: 2 mbrs in A540769.TMP.TST.MBRLIST(*?IE*)
1 NNNIE
2 VIER
$/tstMbrList/
*/
call tst t, 'tstMbrList'
/* call tstMbrList1 "RZ2/A540769.WK.REXX(*DA?*)" */
pds = tstFileName('MbrList', 'r')
da.1 = '2ine eins'
call tstMbrList1 pds, '#noPds'
call writeDsn pds'(eins) ::f', da., 1
call tstMbrList1 pds, '#1'
call adrTso "delete '"pds"(eins)'"
call tstMbrList1 pds, '#0'
call writeDsn pds'(zwei) ::f', da., 1
call writeDsn pds'(drei) ::f', da., 1
call writeDsn pds'(vier) ::f', da., 1
call writeDsn pds'(fuenf) ::f', da., 1
call tstMbrList1 pds, '#4'
call writeDsn pds'(ie) ::f', da., 1
call writeDsn pds'(nnnie) ::f', da., 1
call tstMbrList1 pds"(*IE*)", '#*IE*'
call tstMbrList1 pds"(*?IE*)", '#*_IE*'
call adrTso "delete '"pds"'"
call tstEnd t
return
endProcedure tstMbrList
tstMbrList1: procedure expose m.
parse arg pds, txt
call tstOut t, txt':' mbrList(tstMbrList, pds) 'mbrs in' pds
do mx=1 to m.tstMbrList.0
call tstOut t, mx m.tstMbrList.mx
end
return
endProdecure tstMbrList1
/****** tstDiv *******************************************************/
tstDiv:
call tstSort
call tstMat
call tstMatch
call tstTotal
return
endProcedure tstDiv
tstSort: procedure expose m.
call tstSortComp
call tstSortComp '<<='
call tstSortComp 'm.aLe <<= m.aRi'
call tstSortComp 'if 1 then cmp = m.aLe <<= m.aRi;else call err sd'
return
endProcedure tstSort
tstSortComp: procedure expose m.
parse arg cmp
/*
$=/tstSort/
### start tst tstSort #############################################
sort 29 c ACHT DREI DREIZEHN EINS ELF FUENF M.I.25 M.I.26 M.I.27 M+
..I.29 NEUN SECHS SIEBEN VIER VIERZEHN ZEHN ZWEI ZWOELF 0 1 1 1 2 2+
. 3 3 4 4
sort 22 c ACHT DREIZEHN ELF M.I.25 M.I.26 M.I.27 M.I.29 NEUN VIERZ+
EHN ZEHN ZWOELF 0 1 1 1 2 2 3 3 4 4
sort 15 c M.I.25 M.I.26 M.I.27 M.I.29 0 1 1 1 2 2 3 3 4 4
sort 8 c M.I.25 M.I.26 M.I.27 M.I.29 0 1 1
sort 1 M.I.29
sortWords(also als a 05 4 1e2, cmp) a als also 05 1e2 4
sortWords(also als a 05 4, cmp) a als also 05 4
sortWords(also als a 05, cmp) a als also 05
sortWords(also als a, cmp) a als also
sortWords(also als, cmp) als also
sortWords(also, cmp) also
sortWords(, cmp) .
sortWords(also als a 05 4 1e2, <) a als also 4 05 1e2
sortWords(also als a 05 4 1e2, >) 1e2 05 4 also als a
$/tstSort/ */
/*
$=/tstSortAscii/
### start tst tstSortAscii ########################################
sort 29 0 1 1 1 2 2 3 3 4 4 ACHT DREI DREIZEHN EINS ELF FUENF M.I.+
25 M.I.26 M.I.27 M.I.29 NEUN SECHS SIEBEN VIER VIERZEHN ZEHN ZWEI Z+
WOELF c
sort 22 0 1 1 1 2 2 3 3 4 4 ACHT DREIZEHN ELF M.I.25 M.I.26 M.I.27+
. M.I.29 NEUN VIERZEHN ZEHN ZWOELF c
sort 15 0 1 1 1 2 2 3 3 4 4 M.I.25 M.I.26 M.I.27 M.I.29 c
sort 8 0 1 1 M.I.25 M.I.26 M.I.27 M.I.29 c
sort 1 M.I.29
$/tstSortAscii/ */
say '### start with comparator' cmp '###'
if m.err_os == 'LINUX' then
call tst t, "tstSortAscii"
else
call tst t, "tstSort"
call mAdd mCut(i, 0), eins, zwei, drei, vier, fuenf, sechs,
,sieben, acht, neun, zehn, elf, zwoelf, dreizehn, vierzehn
call mAdd i, 1, 2, 3, 4, 4, 3, 2, 1, 0, 1,
, 'M.I.25', 'M.I.26', 'M.I.27', 'c', 'M.I.29'
do yy = m.i.0 by -1 to 1
do x = 0 to yy
m.i.0 = x
call sort i, o, cmp
m = ''
la = ''
if x <> m.o.0 then
call err 'size mismatch' x '<>' m.o.0
do y=1 to m.o.0
m = m m.o.y
if \ (la << m.o.y) then
call err 'sort mismatch' yy x y '\' la '<<' m.o.y
end
end
if yy // 7 = 1 then
call tstOut t, 'sort' yy m
do x = 2 to yy
x1 = x-1
m.i.x1 = m.i.x
end
end
wi = 'also als a 05 4 1e2'
do l=words(wi) by -1 to 0
call tstOut t, 'sortWords('subWord(wi, 1, l)', cmp)' ,
sortWords(subWord(wi, 1, l), cmp)
end
call tstOut t, 'sortWords('wi', <)' sortWords(wi, '<')
call tstOut t, 'sortWords('wi', >)' sortWords(wi, '>')
call tstEnd t
return
endProcedure tstSort
tstMatch: procedure expose m.
/*
$=/tstMatch/
### start tst tstMatch ############################################
match(eins, e?n*) 1 1 2,i,s trans(E?N*) EiNs
match(eins, eins) 1 1 0 trans(EINS) EINS
match(e1nss, e?n*) 1 1 2,1,ss trans(?*) 1ss
match(eiinss, e?n*) 0 0 -9 trans(E?N*) .
match(einss, e?n *) 0 0 -9 trans(E?N *) .
match(ein s, e?n *) 1 1 2,i,s trans(E?N *) EiN s
match(ein abss , ?i*b*) 1 1 3,e,n a,ss trans(?I*B*) eIn aBss .
match(ein abss wie gehtsssxdirx und auch , ) 0 0 -9 trans() .
match(ies000, *000) 1 1 1,ies trans(*000) ies000
match(xx0x0000, *000) 1 1 1,xx0x0 trans(*000) xx0x0000
match(000x00000xx, 000*) 1 1 1,x00000xx trans(000*) 000x00000xx
match(000xx, *0*) 1 1 2,00,xx trans(ab*cd*ef) ab00cdxxef
match(abcdef, *abcdef*) 1 1 2,, trans(*ABCDEF*) ABCDEF
match(abcdef, **abcdef***) 1 1 5,,,,, trans(**ABCDEF***) ABCDEF
match(abcdef, *cd*) 1 1 2,ab,ef trans(*CD*) abCDef
match(abcdef, *abc*def*) 1 1 3,,, trans(*ABC*DEF*) ABCDEF
match(abcdef, *bc*e*) 1 1 3,a,d,f trans(*BC*E*) aBCdEf
match(abcdef, **bc**ef**) 1 1 6,a,,d,,, trans(**BC**EF**) aBCdEF
$/tstMatch/
*/
call tst t, "tstMatch"
call tstOut t, tstMatch1('eins', 'e?n*' )
call tstOut t, tstMatch1('eins', 'eins' )
call tstOut t, tstMatch1('e1nss', 'e?n*', '?*' )
call tstOut t, tstMatch1('eiinss', 'e?n*' )
call tstOut t, tstMatch1('einss', 'e?n *' )
call tstOut t, tstMatch1('ein s', 'e?n *' )
call tstOut t, tstMatch1('ein abss ', '?i*b*' )
call tstOut t, tstMatch1('ein abss wie gehtsssxdirx und auch ' )
call tstOut t, tstMatch1('ies000', '*000' )
call tstOut t, tstMatch1('xx0x0000', '*000' )
call tstOut t, tstMatch1('000x00000xx', '000*' )
call tstOut t, tstMatch1('000xx', '*0*', 'ab*cd*ef' )
call tstOut t, tstMatch1('abcdef', '*abcdef*' )
call tstOut t, tstMatch1('abcdef', '**abcdef***' )
call tstOut t, tstMatch1('abcdef', '*cd*' )
call tstOut t, tstMatch1('abcdef', '*abc*def*' )
call tstOut t, tstMatch1('abcdef', '*bc*e*' )
call tstOut t, tstMatch1('abcdef', '**bc**ef**' )
call tstEnd t
return
tstMatch1:
parse arg w, m, m2
r = 'match('w',' m')' match(w, m) matchVars(w, m, vv) m.vv.0
do x=1 to m.vv.0
r = r','m.vv.x
end
if m2 = '' then
m2 = translate(m)
r = r 'trans('m2')' matchRep(w, m, m2)
return r
endProcedure tstMatch1
tstIntRdr: procedure expose m.
i.1 = "//A540769J JOB (CP00,KE50),'DB2 REO',"
i.2 = "// MSGCLASS=T,TIME=1440,"
i.3 = "// NOTIFY=&SYSUID,REGION=0M,SCHENV=DB2"
i.4 = "//*MAIN CLASS=LOG"
i.5 = "//S1 EXEC PGM=IEFBR14"
call writeDsn 'RR2/intRdr', i., 5, 1
return
endProcedure tstIntRdr
tstII: procedure expose m.
/*
$=/tstII/
### start tst tstII ###############################################
iiDs(org) ORG.U0009.B0106.MLEM43
iiDs(db2) DSN.DB2
iiRz2C(RZ2) 2
*** err: no key=R?Y in II_RZ2C
iiRz2C(R?Y) 0
iiRz2C(RZY) Y
iiDbSys2C(de0G) E
*** err: no key=D??? in II_DB2C
iiDbSys2C(d???) 0
iiDbSys2C(DBOF) F
iiSys2RZ(S27) RZ2
iiMbr2DbSys(DBP5) DVBP
ii_rz RZX RZY RZZ RQ2 RR2 RZ2 RZ4
ii_rz2db.rzx DE0G DEVG DX0G DPXG
rr2/dvbp RR2 R p=R d=RZ2, db DVBP P 1
iiixPut 1: RZ2 2 p=B d=RZ2, db DBOF F 0
iiixPut 1: RZ2 2 p=B d=RZ2, db DVBP P 1
iiixPut 1: RZ2 2 p=B d=RZ2, db DP2G Q 0
*** err: no key=M6R in II_MBR2DB
errHan======= mbr2DbSys(m6r?) 0
errHandlerPush Mbr2DbSys(m7r?) ?no?dbSys?
*** err: no key=M8R in II_MBR2DB
errHandlerPop Mbr2DbSys(m8r?) 0
$/tstII/
*/
call tst t, 'tstII'
call tstOut t, 'iiDs(org) ' iiDs('oRg')
call tstOut t, 'iiDs(db2) ' iiDs(db2)
call tstOut t, 'iiRz2C(RZ2) ' iiRz2C(RZ2)
call tstOut t, 'iiRz2C(R?Y) ' iiRz2C(R?Y)
call tstOut t, 'iiRz2C(RZY) ' iiRz2C(RZY)
call tstOut t, 'iiDbSys2C(de0G) ' iiDbSys2C('de0G')
call tstOut t, 'iiDbSys2C(d???) ' iiDbSys2C('d???')
call tstOut t, 'iiDbSys2C(DBOF) ' iiDbSys2C('DBOF')
call tstOut t, 'iiSys2RZ(S27) ' iiSys2RZ(S27)
call tstOut t, 'iiMbr2DbSys(DBP5)' iiMbr2DbSys(DBP5)
call tstOut t, 'ii_rz ' m.ii_rz
call tstOut t, 'ii_rz2db.rzx ' m.ii_rz2db.rzx
call pipeIni
call iiPut 'rr2/ DvBp '
call tstOut t, 'rr2/dvbp ' ,
vGet('rz') vget('rzC') 'p='vget('rzP') 'd='vget('rzD'),
|| ', db' vGet('dbSys') vGet('dbSysC') vGet('dbSysElar')
w1 = wordPos('RZ2/DBOF', m.ii_rzDb)
do wx=w1 to w1+2
call tstOut t, 'iiixPut' iiIxPut(wx)':' ,
vGet('rz') vget('rzC') 'p='vget('rzP') 'd='vget('rzD'),
|| ', db' vGet('dbSys') vGet('dbSysC') vGet('dbSysElar')
end
call tstOut t, "errHan======= mbr2DbSys(m6r?)" iiMbr2DbSys('m6r?')
call errHandlerPushRet "?no?dbSys?"
call tstOut t, "errHandlerPush Mbr2DbSys(m7r?)" iiMbr2DbSys('m7r?')
call errHandlerPop
call tstOut t, "errHandlerPop Mbr2DbSys(m8r?)" iiMbr2DbSys('m8r?')
call tstEnd t
return
endProcedure tstII
tstTime2tst: procedure expose m.
/*
$=/tstTime2tst/
### start tst tstTime2tst #########################################
2015-05-13-23.45.57.987654 ==> 735730.99025448673611 ==> 2015-05-13+
-23.45.57.987654 1
1956-04-01-23.59.59.999999 ==> 714139.99999999998843 ==> 1956-04-01+
-23.59.59.999999 1
2016-02-29-12.34.56.789087 ==> 736022.52426839221065 ==> 2016-02-29+
-12.34.56.789087 1
1567-08-23-19.59.59.999999 ==> 572203.83333333332176 ==> 1567-08-23+
-19.59.59.999999 1
$/tstTime2tst/
*/
call tst t, 'tstTime2tst'
l = '2015-05-13-23.45.57.987654 1956-04-01-23.59.59.999999' ,
'2016-02-29-12.34.56.789087 1567-08-23-19.59.59.999999'
do lx=1 to 4
v = word(l, lx)
w = timeDays2tst(timestamp2days(v))
call tstOut t, v '==>' timestamp2days(v) '==>' w (v = w)
end
call tstEnd t
return
endProcedure tstTime2tst
tstTime: procedure
/* Winterzeit dez 2011
$=/tstTime/
### start tst tstTime #############################################
05-28-00.00 2days 735745
05-28-04.00 2days 735745.16666666666667
05-28-21.00 2days 735745.9
05-29-00.00 2days 735746
16-05-28-00 2days 736111
16...12 - 15...06 366.25000000000000
2016-05-28-12.23.45 .
2016-05-28-12-23.45 bad timestamp 2016-05-28-12-23
2016.05-28-12.23.45 bad timestamp 2016.05-28-12.23
2016-05-28-12.23.45.987654 .
2016-0b-28-12.23.45 bad timestamp 2016-0b-28-12.23
2016-05-28-12.23.45.9876543 bad timestamp 2016-05-28-12.23
2016-05-28-12.23.45.98-654 bad timestamp 2016-05-28-12.23
2016-00-28-12.23.45 bad month in timestamp 2016-00
2016-05-28-13.23.45 .
2016-15-28-12.23.45 bad month in timestamp 2016-15
2016-05-31-12.23.45 .
2016-04-31-13.23.45 bad day in timestamp 2016-04-3
2015-04-30-12.23.45 .
2016-02-30-12.23.45 bad day in timestamp 2016-02-3
2016-02-29-13.23.45 .
2015-02-29-12.23.45 bad day in timestamp 2015-02-2
2016-07-30-25.00.00 bad hour in timestamp 2016-07-
2016-04-07-24.00.00.0 .
2015-02-19-24.00.01 bad hour in timestamp 2015-02-
Achtung: output haengt von Winter/SommerZ & LeapSecs ab
stckUnit = 0.000000000244140625
timeLeap = 00000018CBA80000 = 106496000000 = 26.000 secs
timeZone = 00001AD274800000 = 29491200000000 = 7200.000 secs
timeUQZero = 207090001374976
timeUQDigis = 35 digits ABCDEFGHIJKLMNOPQRSTUVWXYZ012345678
2jul(2011-03-31-14.35.01.234567) 11090
Lrsn2TAI10(00C5E963363741000000) 2010-05-01-10.35.20.789008
Lrsn2Lzt(00C5E963363741000000) 2010-05-01-12.34.54.789008
TAI102Lrsn(2011-03-31-14.35.01.234567) 00C78D87B86E38700000
lzt2Lrsn(2011-03-31-14.35.01.234567) 00C78D6CFEC560700000
Lrsn2TAI10(TAI102Lrsn(2011-03-31-14.35.01.234567) +
2011-03-31-14.35.01.234567
TAI102Lrsn(Lrsn2TAI10(00C5E963363741000000) 00C5E963363741000000
Lrsn2LZt(LZt2Lrsn(2011-03-31-14.35.01.234567) 2011-03-31-14.35.01.2+
34567
LZt2Stc(Lrsn2LZt(00C5E963363741000000) 00C5E963363741000000
Lrsn2uniq(00C5E963363741000000) CTNR6S7T back 00C5E963363740000000
Lrsn2LZt(LZt2Lrsn(2051-10-31-14.35.01.234567) 2051-10-31-14.35.01+
..234567
Lrsn2TAI10(01010000000000000000) 2043-04-09-14.36.53.414912
$/tstTime/
Winterzeit
timeZone = 00000D693A400000 = 14745600000000 = 3600.000 secs
Lrsn2Lzt(00C5E963363741000000) 2010-05-01-11.34.54.789008
lzt2Lrsn(2011-03-31-14.35.01.234567) 00C78D7A67FFA0700000
Sommerzeit
timeZone = 00001AD274800000 = 29491200000000 = 7200.000 secs
Lrsn2Lzt(00C5E963363741000000) 2010-05-01-12.34.54.789008
lzt2Lrsn(2011-03-31-14.35.01.234567) 00C78D6CFEC560700000
*/
call jIni
call timeIni
call tst t, 'tstTime'
call out '05-28-00.00 2days ' timestamp2days('2015-05-28-00.00.00')
call out '05-28-04.00 2days ' timestamp2days('2015-05-28-04.00.00')
call out '05-28-21.00 2days ' timestamp2days('2015-05-28-21.36.00')
call out '05-29-00.00 2days ' timestamp2days('2015-05-29-00.00.00')
call out '16-05-28-00 2days ' timestamp2days('2016-05-28-00.00.00')
call out '16...12 - 15...06 ' timestampDiff( '2016-05-28-12.23.45',
, '2015-05-28-06.23.45')
l = '2016-05-28-12.23.45 2016-05-28-12-23.45 2016.05-28-12.23.45',
'2016-05-28-12.23.45.987654 2016-0b-28-12.23.45' ,
'2016-05-28-12.23.45.9876543 2016-05-28-12.23.45.98-654' ,
'2016-00-28-12.23.45 2016-05-28-13.23.45 2016-15-28-12.23.45',
'2016-05-31-12.23.45 2016-04-31-13.23.45 2015-04-30-12.23.45',
'2016-02-30-12.23.45 2016-02-29-13.23.45 2015-02-29-12.23.45',
'2016-07-30-25.00.00 2016-04-07-24.00.00.0 2015-02-19-24.00.01'
do lx=1 to words(l)
call out left(word(l, lx), 30),
strip(left(timestampCheck(word(l, lx)), 30), 't')
end
t1 = '2011-03-31-14.35.01.234567'
t2 = '2051-10-31-14.35.01.234567'
s1 = timeLrsnExp('C5E963363741')
s2 = timeLrsnExp('0101')
call out 'Achtung: output haengt von Winter/SommerZ & LeapSecs ab'
numeric digits 15
call out 'stckUnit =' m.time_StckUnit
call out 'timeLeap =' d2x(m.time_Leap,16) '=' m.time_Leap ,
'=' format(m.time_Leap * m.time_StckUnit,9,3) 'secs'
call out 'timeZone =' d2x(m.time_Zone,16) '=' m.time_Zone,
'=' format(m.time_Zone * m.time_StckUnit,6,3) 'secs'
/* call out "cvtext2_adr =" d2x(cvtExt2A, 8) */
call out 'timeUQZero =' m.time_UQZero
call out 'timeUQDigis =' ,
length(m.time_UQDigits) 'digits' m.time_UQDigits
call out '2jul('t1') ' time2jul(t1)
call out 'Lrsn2TAI10('s1')' timelrsn2TAI10(s1)
call out 'Lrsn2Lzt('s1')' timeLrsn2Lzt(s1)
call out 'TAI102Lrsn('t1')' timeTAI102Lrsn(t1)
call out 'lzt2Lrsn('t1')' timeLzt2Lrsn(t1)
call out 'Lrsn2TAI10(TAI102Lrsn('t1')' ,
timeLrsn2TAI10(timeTAI102Lrsn(t1))
call out 'TAI102Lrsn(Lrsn2TAI10('s1')' ,
timeTAI102Lrsn(timelrsn2TAI10(s1))
call out 'Lrsn2LZt(LZt2Lrsn('t1')' timeLrsn2LZt(timeLZt2Lrsn(t1))
call out 'LZt2Stc(Lrsn2LZt('s1')' timeLZt2Lrsn(timeLrsn2LZt(s1))
call out 'Lrsn2uniq('s1')' timeLrsn2Uniq(s1) ,
'back' timeUniq2Lrsn(timeLrsn2Uniq(s1))
call out 'Lrsn2LZt(LZt2Lrsn('t2')' timeLrsn2LZt(timeLZt2Lrsn(t2))
call out 'Lrsn2TAI10('s2')' timelrsn2TAI10(s2)
call tstEnd t
return
endProcedure tstTime
tstMat: procedure expose m.
/*
$=/tstMat/
### start tst tstMat ##############################################
. 0 sqrt 0 isPrime 0 nxPrime 3 permut 1 > 1 2 3 4 5
. 1 sqrt 1 isPrime 0 nxPrime 3 permut 2 > 2 1 3 4 5
. 2 sqrt 1 isPrime 1 nxPrime 3 permut 3 > 1 3 2 4 5
. 3 sqrt 1 isPrime 1 nxPrime 3 permut 3 > 2 3 1 4 5
. 4 sqrt 2 isPrime 0 nxPrime 5 permut 3 > 3 2 1 4 5
. 5 sqrt 2 isPrime 1 nxPrime 5 permut 3 > 3 1 2 4 5
. 6 sqrt 2 isPrime 0 nxPrime 7 permut 4 > 1 2 4 3 5
. 7 sqrt 2 isPrime 1 nxPrime 7 permut 4 > 2 1 4 3 5
. 8 sqrt 2 isPrime 0 nxPrime 11 permut 4 > 1 3 4 2 5
. 9 sqrt 3 isPrime 0 nxPrime 11 permut 4 > 2 3 4 1 5
. 10 sqrt 3 isPrime 0 nxPrime 11 permut 4 > 3 2 4 1 5
. 11 sqrt 3 isPrime 1 nxPrime 11 permut 4 > 3 1 4 2 5
. 12 sqrt 3 isPrime 0 nxPrime 13 permut 4 > 1 4 3 2 5
. 13 sqrt 3 isPrime 1 nxPrime 13 permut 4 > 2 4 3 1 5
. 14 sqrt 3 isPrime 0 nxPrime 17 permut 4 > 1 4 2 3 5
. 15 sqrt 3 isPrime 0 nxPrime 17 permut 4 > 2 4 1 3 5
. 16 sqrt 4 isPrime 0 nxPrime 17 permut 4 > 3 4 1 2 5
. 17 sqrt 4 isPrime 1 nxPrime 17 permut 4 > 3 4 2 1 5
. 18 sqrt 4 isPrime 0 nxPrime 19 permut 4 > 4 2 3 1 5
$/tstMat/
$/tstMat/
*/
call tst t, 'tstMat'
q = 'tst_Mat'
do qx=1 to 20
m.q.qx = qx
end
do i=0 to 18
call permut q, i
call tstOut t, right(i,4) 'sqrt' right(sqrt(i), 2) ,
'isPrime' isPrime(i) 'nxPrime' right(nxPrime(i), 4) ,
'permut' m.q.0 '>' m.q.1 m.q.2 m.q.3 m.q.4 m.q.5
end
call tstEnd t
return
endProcedure tstMat
tstCsmExWsh: procedure expose m.
/*
new lines: 24
$=/tstCsmExWsh/
### start tst tstCsmExWsh #########################################
--- sending v
line eins aus <toRZ>
csm_o1=¢fEins=o1Feins =o1Val fZwei=o1 fZwei!
csm_o2=¢fEins=o2Feins =o2Value fZwei=o2,fwei, und !
line vier end
--- sending e
line eins aus <toRZ>
tstR: @tstWriteoV2 isA :TstCsmExWsh*3
tstR: .fEins = o1Feins
tstR: = o1Val
tstR: .fZwei = o1 fZwei
tstR: @tstWriteoV4 isA :TstCsmExWsh*3
tstR: .fEins = o2Feins
tstR: = o2Value
tstR: .fZwei = o2,fwei, und .
line vier end
--- sending f50
line eins aus <toRZ> .
csm_o1=¢fEins=o1Feins =o1Val fZwei=o1 fZwei! .
csm_o2=¢fEins=o2Feins =o2Value fZwei=o2,fwei, ...!
line vier end .
$/tstCsmExWsh/
*/
call csmIni
call pipeIni
call tst t, "tstCsmExWsh"
call mAdd t.trans, m.tst_csmRz '<toRZ>'
bi = jBuf("$$- 'line eins aus' sysvar(sysnode)" ,
, "cc = classNew('n? TstCsmExWsh u f fEins v, v, f fZwei v')" ,
, "$$. csv2o('csm_o1',cc, 'o1Feins,o1Val,o1 fZwei')" ,
, "$$. csv2o('csm_o2',cc, 'o2Feins,o2Value,""o2,fwei, und ""')" ,
, "$$ line vier end")
call out '--- sending v'
call csmExWsh m.tst_csmRz, bi, 'v'
ww = oNew(m.class_csmExWsh, m.tst_csmRz, bi, 'e')
call out '--- sending e'
call jWriteAll t, ww
call out '--- sending f50'
call csmExWsh m.tst_csmRz, bi, 'f50'
call tstEnd t
return
endProcedure tstCsmExWsh
/****** tstSql *******************************************************/
tstSqlRx: procedure expose m.
/*
$=/tstSqlRx/
### start tst tstSqlRx ############################################
*** err: SQLCODE = -204: A540769.SYSDUMMY IS AN UNDEFINED NAME
. e 1: sql = select * from sysdummy
. e 2: stmt = prepare s7 into :M.SQL.7.D from :src
. e 3: with into :M.SQL.7.D = M.SQL.7.D
fetchA 1 ab=m.abcdef.123.AB=abc ef=efg
fetchA 0 ab=m.abcdef.123.AB=abc ef=efg
fetchB 1 ab=a cd=2 ef=--- ind=-1 gh=d ind=0
fetchB 0 ab=a cd=2 ef=--- ind=-1 gh=d ind=0
fetchC 1 a=a b=2 c=--- d=d
fetchC 0 a=a b=2 c=--- d=d
fetchBT 1 SYSTABLES
fetchBT 0 SYSTABLES
fetchBi 1 SYSINDEXES
fetchBi 0 SYSINDEXES
$/tstSqlRx/ */
call jIni
call tst t, "tstSqlRx"
call sqlConnect , 'e'
cx = 7
call sqlQuery cx, 'select * from sysdummy'
call sqlQuery cx, "select 'abc' , 'efg'",
'from sysibm.sysDummy1',':m.dst.ab, :m.dst.ef'
a = 'abcdef'
b = 123
drop m.a.b.ab m.a.b.ef
do i=1 to 2
call out 'fetchA' sqlFetch(cx, a || '.' || b) ,
'ab=m.'a'.'||b'.'ab'='m.a.b.ab 'ef='m.a.b.ef
end
call sqlClose cx
drop m.a.b.ab m.a.ab.ef a b c
sql = "select 'a' a, 2 b, case when 1=0 then 1 else null end c",
", case when 1=1 then 'd' else null end d",
"from sysibm.sysDummy1"
call sqlQuery cx, sql, 'AB CD EF GH'
st = 'abc.Def.123'
drop m.st.ab m.st.cd m.st.ef m.st.ef.sqlInd m.st.gh m.st.gh.sqlInd
do i=1 to 2
call out 'fetchB' sqlFetch(cx, st) ,
'ab='m.st.ab 'cd='m.st.cd 'ef='m.st.ef 'ind='m.st.ef.sqlInd,
'gh='m.st.gh 'ind='m.st.gh.sqlInd
end
call sqlClose cx
drop m.st.ab m.st.bc m.st.df m.st.df.sqlInd
call sqlQuery cx, sql
st = 'abc.Def.123'
drop m.st.a m.st.b m.st.c m.st.d
do i=1 to 2
call out 'fetchC' sqlFetch(cx, st) ,
'a='m.st.a 'b='m.st.b 'c='m.st.c 'd='m.st.d
end
drop m.st.a m.st.b m.st.c m.st.d
call sqlClose cx
drop m.st.1.a m.st.1.b m.st.1.c m.st.1.d m.st.0
call sqlQueryPrepare cx, "select name" ,
"from sysibm.sysTables" ,
"where creator = 'SYSIBM' and name = ?",':m.nm'
call sqlQueryExecute cx, 'SYSTABLES'
call out 'fetchBT' sqlFetch(cx) m.nm
call out 'fetchBT' sqlFetch(cx) m.nm
call sqlClose cx
call sqlQueryExecute cx, 'SYSINDEXES'
call out 'fetchBi' sqlFetch(cx) m.nm
call out 'fetchBi' sqlFetch(cx) m.nm
call tstEnd t
call sqlDisconnect
return
endProcedure tstSqlRx
tstSql: procedure expose m.
/*
$=/tstSql/
### start tst tstSql ##############################################
*** err: SQLCODE = -204: A540769.SYSDUMMY IS AN UNDEFINED NAME
. e 1: sql = select * from sysdummy
. e 2: stmt = prepare s7 into :M.SQL.7.D from :src
. e 3: with into :M.SQL.7.D = M.SQL.7.D
fetchA 1 ab=m.abcdef.123.AB=abc ef=efg
fetchA 0 ab=m.abcdef.123.AB=abc ef=efg
fetchB 1 ab=a cd=2 ef=--- ind=-1 gh=d ind=0
fetchB 0 ab=a cd=2 ef=--- ind=-1 gh=d ind=0
fetchC 1 a=a b=2 c=--- d=d
fetchC 0 a=a b=2 c=--- d=d
sql2St 1 st.0=1
sql2St:1 a=a b=2 c=--- d=d
sql2One a
sql2One a=a b=2 c=--- d=d
fetchBT 1 SYSTABLES
fetchBT 0 SYSTABLES
fetchBi 1 SYSINDEXES
fetchBi 0 SYSINDEXES
$/tstSql/ */
call jIni
call tst t, "tstSql"
call sqlConnect , 'e'
cx = 7
call sqlQuery cx, 'select * from sysdummy'
call sqlQuery cx, "select 'abc' , 'efg'",
'from sysibm.sysDummy1', ':m.dst.ab, :m.dst.ef'
a = 'abcdef'
b = 123
drop m.a.b.ab m.a.b.ef
do i=1 to 2
call out 'fetchA' sqlFetch(cx, a || '.' || b) ,
'ab=m.'a'.'||b'.'ab'='m.a.b.ab 'ef='m.a.b.ef
end
call sqlClose cx
drop m.a.b.ab m.a.ab.ef a b c
sql = "select 'a' a, 2 b, case when 1=0 then 1 else null end c",
", case when 1=1 then 'd' else null end d",
"from sysibm.sysDummy1"
call sqlQuery cx, sql, 'AB CD EF GH'
st = 'abc.Def.123'
drop m.st.ab m.st.cd m.st.ef m.st.ef.sqlInd m.st.gh m.st.gh.sqlInd
do i=1 to 2
call out 'fetchB' sqlFetch(cx, st) ,
'ab='m.st.ab 'cd='m.st.cd 'ef='m.st.ef 'ind='m.st.ef.sqlInd,
'gh='m.st.gh 'ind='m.st.gh.sqlInd
end
call sqlClose cx
drop m.st.ab m.st.bc m.st.df m.st.df.sqlInd
call sqlQuery cx, sql
st = 'abc.Def.123'
drop m.st.a m.st.b m.st.c m.st.d
do i=1 to 2
call out 'fetchC' sqlFetch(cx, st) ,
'a='m.st.a 'b='m.st.b 'c='m.st.c 'd='m.st.d
end
drop m.st.a m.st.b m.st.c m.st.d
call sqlClose cx
drop m.st.1.a m.st.1.b m.st.1.c m.st.1.d m.st.0
call out 'sql2St' sql2St(sql, st) 'st.0='m.st.0
do i=1 to m.st.0
call out 'sql2St:'i ,
'a='m.st.i.a 'b='m.st.i.b 'c='m.st.i.c 'd='m.st.i.d
end
drop m.st.1.a m.st.1.b m.st.1.c m.st.1.d m.st.0
drop m.st.a m.st.b m.st.c m.st.d m.st.0
call out 'sql2One' sql2One(sql, st)
call out 'sql2One' ,
'a='m.st.a 'b='m.st.b 'c='m.st.c 'd='m.st.d
drop m.st.a m.st.b m.st.c m.st.d m.st.0
call sqlQueryPrepare cx, "select name" ,
"from sysibm.sysTables" ,
"where creator = 'SYSIBM' and name = ?",':m.nm'
call sqlQueryExecute cx, 'SYSTABLES'
call out 'fetchBT' sqlFetch(cx) m.nm
call out 'fetchBT' sqlFetch(cx) m.nm
call sqlClose cx
call sqlQueryExecute cx, 'SYSINDEXES'
call out 'fetchBi' sqlFetch(cx) m.nm
call out 'fetchBi' sqlFetch(cx) m.nm
call tstEnd t
call sqlDisconnect
return
endProcedure tstSql
tstSqlCall: procedure expose m.
/*
$=/tstSqlCall/
### start tst tstSqlCall ##########################################
set sqlid 0
drop proc -204
crea proc 0
call -2 0
resultSets 1 vars=3 2=-1 3=call-2 -2
* resultSet 1 CUR NAME COLTYPE A2
cur=cur2 name=NAME type=VARCHAR len= a1= a2=call-2 a3=
cur=cur2 name=CREATOR type=VARCHAR len= a1= a2=call-2 a3=
cur=cur2 name=TYPE type=CHAR len= a1= a2=call-2 a3=
call -1 0
resultSets 1 vars=3 2=0 3=call-1 -1
* resultSet 1 CUR NAME COLTYPE LENGTH A1
cur=cur1 name=NAME type=VARCHAR len=128 a1=call-1 a2= a3=
call 0 0
resultSets 0 vars=3 2=1 3=call0 0
call 1 0
resultSets 1 vars=3 2=2 3=call1 1
* resultSet 1 CUR NAME COLTYPE LENGTH A1
cur=cur1 name=NAME type=VARCHAR len=128 a1=call1 a2= a3=
call 2 0
resultSets 2 vars=3 2=3 3=call2 2
* resultSet 1 CUR NAME COLTYPE LENGTH A1
cur=cur1 name=NAME type=VARCHAR len=128 a1=call2 a2= a3=
* resultSet 2 CUR NAME COLTYPE A2
cur=cur2 name=NAME type=VARCHAR len= a1= a2=call2 a3=
cur=cur2 name=CREATOR type=VARCHAR len= a1= a2=call2 a3=
cur=cur2 name=TYPE type=CHAR len= a1= a2=call2 a3=
call 3 0
resultSets 3 vars=3 2=4 3=call3 3
* resultSet 1 CUR NAME COLTYPE LENGTH A1
cur=cur1 name=NAME type=VARCHAR len=128 a1=call3 a2= a3=
* resultSet 2 CUR NAME COLTYPE A2
cur=cur2 name=NAME type=VARCHAR len= a1= a2=call3 a3=
cur=cur2 name=CREATOR type=VARCHAR len= a1= a2=call3 a3=
cur=cur2 name=TYPE type=CHAR len= a1= a2=call3 a3=
* resultSet 3 CUR NAME A3
rollback 0
$/tstSqlCall/ */
call tst t, "tstSqlCall"
prc = 'qz91WshTst1.proc1'
c1 = "from sysibm.sysColumns" ,
"where tbCreator = 'SYSIBM' and tbName = 'SYSTABLES'" ,
"order by colNo" ,
"fetch first"
call sqlConnect , 'e'
call tstOut t, 'set sqlid' ,
sqlUpdate(3, "set current sqlid = 'S100447'")
call tstOut t, 'drop proc' sqlUpdate(3, 'drop procedure' prc)
call sqlCommit
call tstOut t, 'crea proc' sqlUpdate(3, 'create procedure' prc ,
"(in a1 varchar(20), inOut cnt int, out res varchar(20))" ,
"version v1 not deterministic reads sql data" ,
"dynamic result sets 3" ,
"begin" ,
"declare prC1 cursor with return for" ,
"select 'cur1' cur, name, colType, length, left(a1, 7) a1" ,
c1 "1 rows only;" ,
"declare prC2 cursor with return for" ,
"select 'cur2' cur, name, colType, left(a1, 7) a2" ,
c1 "3 rows only;" ,
"declare prC3 cursor with return for" ,
"select 'cur2' cur, name, left(a1, 7) a3" ,
"from sysibm.sysTables where 1 = 0;" ,
"if cnt >= 1 or cnt = -1 then open prC1; end if;" ,
"if cnt >= 2 or cnt = -2 then open prC2; end if;" ,
"if cnt >= 3 or cnt = -3 then open prC3; end if;" ,
"set res = strip(left(a1, 10)) || ' ' || cnt;" ,
"set cnt = cnt + 1;" ,
"end" )
d = 'TST_sqlCall'
do qx= -2 to 3
call tstOut t, 'call' qx sqlCall(3,
, "call" prc "(call"qx"," qx", ' ')")
call tstOut t, 'resultSets' m.sql.3.resultSet.0,
'vars='m.sql.3.var.0 ,
'2='m.sql.3.var.2 '3='m.sql.3.var.3
if m.sql.3.resultSet \== '' then
do qy=1 until \ sqlNextResultSet(3)
call tstOut t, '* resultSet' qy m.sql.3.fetchFlds
m.d.length = ''
m.d.colType = ''
m.d.a1 = ''
m.d.a2 = ''
m.d.a3 = ''
do while sqlFetch(3, d)
call tstOut t, 'cur='m.d.cur 'name='m.d.name ,
'type='m.d.colType 'len='m.d.length ,
'a1='m.d.a1 'a2='m.d.a2 'a3='m.d.a3
end
call sqlClose 3
end
end
call tstOut t, 'rollback ' sqlUpdate(3, 'rollback')
call sqlDisconnect
call tstEnd t
return
endProcedure tstSqlCall
tstSqlCsm: procedure expose m.
/*
$=/tstSqlCsm/
### start tst tstSqlCsm ###########################################
*** err: SQLCODE = -204: S100447.SYSDUMMY IS AN UNDEFINED NAME
. e 1: sql = select * from sysdummy
. e 2: sqlCsmExe RZZ/DE0G
1 jRead .ab=abc, .ef=efg
2 jRead .AB=a, .CD=2 .EF=---, .GH=d
$/tstSqlCsm/ */
call pipeIni
call tst t, "tstSqlCsm"
call sqlConnect m.tst_csmRzDb, 'c'
call jOpen sqlRdr('select * from sysdummy'), '<'
f1 = 'ab'
f2 = 'er'
r = jOpen(sqlRdr("select 'abc' , 'efg'",
'from sysibm.sysDummy1', f1 f2), '<')
a = 'abcdef'
b = 123
drop m.a.b.ab m.a.b.ef
do while jRead(r)
dst = m.r
call out '1 jRead .ab='m.dst.f1', .ef='m.dst.f2
end
drop m.a.b.ab m.a.ab.ef a b c
sql = "select 'a' a, 2 b, case when 1=0 then 1 else null end c",
", case when 1=1 then 'd' else null end d",
"from sysibm.sysDummy1"
r = jOpen(sqlRdr(sql, 'AB CD EF GH'), '<')
do while jRead(r)
dst = m.r
call out '2 jRead .AB='m.dst.AB', .CD='m.dst.CD ,
'.EF='m.dst.EF', .GH='m.dst.GH
end
st = 'abc.Def.123'
call tstEnd t
call sqlDisconnect
return
endProcedure tstsqlCsm
tstSqlCSV: procedure expose m.
/*
$=/tstSqlCSV/
### start tst tstSqlCSV ###########################################
NAME,CREATOR,MITCOM,MITQUO,MITNU,COL6
SYSTABLES,SYSIBM ,"a,b","a""b",1,8
SYSTABLESPACE,SYSIBM ,"a,b","a""b",---,8
SYSTABLESPACESTATS,SYSIBM,"a,b","a""b",---,6
$/tstSqlCSV/ */
call sqlConnect , 'r'
call tst t, "tstSqlCSV"
r = csv4ObjRdr(sqlRdr("select name, creator, 'a,b' mitCom",
", 'a""b' mitQuo" ,
", case when name='SYSTABLES' then 1 else null end mitNu" ,
",length(creator)" ,
"from sysibm.sysTables" ,
"where creator = 'SYSIBM' and name like 'SYSTABLES%'",
"fetch first 3 rows only"))
call pipeWriteAll r
call sqlDisConnect
call tstEnd t
return
endProcedure tstSqlCsv
tstSqlB: procedure expose m.
/*
$=/tstSqlB/
### start tst tstSqlB #############################################
#jIn 1# select strip(name) "tb", strip(creator) cr
#jIn 2# , case when name = 'SYSTABLES' then 1 else null end
#jIn 3# from sysibm.sysTables
#jIn 4# where creator = 'SYSIBM' and name like 'SYSTABLES%'
#jIn 5# .
#jIn 6# order by name
#jIn 7# fetch first 3 rows only
#jIn eof 8#
dest1.fet: SYSTABLES SYSIBM 1
dest2.fet: SYSTABLESPACE SYSIBM ---
dest3.fet: SYSTABLESPACESTATS SYSIBM ---
$/tstSqlB/ */
call pipeIni
call tst t, "tstSqlB"
cx = 9
call sqlConnect , 'e'
call jIni
call mAdd mCut(t'.IN', 0),
, 'select strip(name) "tb", strip(creator) cr' ,
, ", case when name = 'SYSTABLES' then 1 else null end" ,
, "from sysibm.sysTables" ,
, "where creator = 'SYSIBM' and name like 'SYSTABLES%'", ,
, "order by name",
, "fetch first 3 rows only"
call sqlQuery cx, in2Str(,' ')
do qx=1 while sqlFetch(cx, 'dest'qx'.fet')
dst = 'dest'qx'.fet'
call out dst':' m.dst.tb m.dst.cr m.dst.col3
drop m.dst.tb m.dst.cr m.dst.col3
end
call sqlClose cx
call sqlDisconnect
call tstEnd t
return
endProcedure tstSqlB
tstSqlFTab: procedure expose m.
/*
$=/tstSqlFTab/
### start tst tstSqlFTab ##########################################
UPDATESTATSTIME----------------NACTIVE------NPAGES-EXTENT-LOADRLAST+
TIME--------------REORGLASTTIME--------------REORGINSERT-REORGDELET+
E-REORGUPDATE-REORGUNCLUS-REORGDISORG-REORGMASSDE-REORGNEARIN-REORG+
FARIND-STATSLASTTIME--------------STATSINSERT-STATSDELETE-STATSUPDA+
TE-STATSMASSDE-COPYLASTTIME---------------COPYUPDATED-COPYCHANGES-C+
OPYUPDATE-COPYUPDATETIME-------------I---DBID---PSID-PARTIT-INSTAN-+
--SPACE-TOTALRO-DATASIZ-UNCOMPR-DBNAME-------NAME---------REORGCL-R+
EORGSC-REORGHA-HASHLASTUS-DRI-L-STATS01-UPDATES-LASTDATACHANGE-----+
----------
--- modified
allg vorher others vorher
db-------ts---------part---inst-UPDATESTATSTIME----------------NACT+
IVE------NPAGES-EXTENT-LOADRLASTTIME--------------REORGLASTTIME----+
----------REORGINSERT-REORGDELETE-REORGUPDATE-REORGUNCLUS-REORGDISO+
RG-REORGMASSDE-REORGNEARIN-REORGFARIND-STATSLASTTIME--------------S+
TATSINSERT-STATSDELETE-STATSUPDATE-STATSMASSDE-COPYLASTTIME--------+
-------COPYUPDATED-COPYCHANGES-COPYUPDATE-COPYUPDATETIME-----------+
--I---DBID---PSID---SPACE-TOTALRO-DATASIZ-UNCOMPR-REORGCL-REORGSC-R+
EORGHA-HASHLASTUS-DRI-L-STATS01-UPDATES-LASTDATACHANGE-------------+
--
db-------ts---------part---inst-UPDATESTATSTIME----------------NACT+
IVE------NPAGES-EXTENT-LOADRLASTTIME--------------REORGLASTTIME----+
----------REORGINSERT-REORGDELETE-REORGUPDATE-REORGUNCLUS-REORGDISO+
RG-REORGMASSDE-REORGNEARIN-REORGFARIND-STATSLASTTIME--------------S+
TATSINSERT-STATSDELETE-STATSUPDATE-STATSMASSDE-COPYLASTTIME--------+
-------COPYUPDATED-COPYCHANGES-COPYUPDATE-COPYUPDATETIME-----------+
--I---DBID---PSID---SPACE-TOTALRO-DATASIZ-UNCOMPR-REORGCL-REORGSC-R+
EORGHA-HASHLASTUS-DRI-L-STATS01-UPDATES-LASTDATACHANGE-------------+
--
allg nachher others nachher
DBNAME INSTANCE +
. NPAGES REORGLASTTIME +
. REORGUPDATES +
. REORGMASSDELETE STATSLASTTIME +
. STATSUPDATES +
. COPYUPDATEDPAGES COPYUPDATETIME +
. PSID DATASIZE REO+
RGSCANACCESS DRIVETYPE UPDATESIZE
. NAME UPDATESTATSTIME +
. EXTENTS +
. REORGINSERTS REORGUNCLUSTINS +
. REORGNEARINDREF +
. STATSINSERTS STATSMASSDELETE +
. COPYCHANGES +
. IBMREQD SPACE UNCOMPRESSEDDATASI+
ZE REORGHASHACCESS LPFACILITY LASTDATACHANGE
. PARTITION NACTIVE+
. LOADRLASTTIME +
. REORGDELETES REORGD+
ISORGLOB REORGFARINDREF +
. STATSDELETES COPYLASTTIME +
. COPYUPDATELRSN +
. DBID TOTALROWS REORGCLUSTE+
RSENS HASHLASTUSED STATS01
$/tstSqlFTab/
*/
call pipeIni
call tst t, 'tstSqlFTab'
call sqlConnect , 'r'
call sqlQuery 17, 'select * from sysibm.sysTablespaceStats' ,
"where dbName = 'xxxDB06' and name = 'SYSTSTAB'"
call sqlFTabOpts fTabReset(abc, 1, ,'-'), 12
call sqlFTabDef abc, 492, '%7e'
call sqlfTab abc, 17
call out '--- modified'
call sqlQuery 17, 'select * from sysibm.sysTablespaceStats' ,
"where dbName = 'xxxDB06' and name = 'SYSTSTAB'"
call sqlFTabOpts fTabReset(abc, 2 1, 1 3 'c', '-'), 12
call sqlFTabDef abc, 492, '%7e'
call ftabAdd abc, DBNAME, '%-8C', 'db', , 'allg vorher' ,
, 'allg nachher'
call ftabAdd abc, NAME , '%-8C', 'ts'
call ftabAdd abc, PARTITION , , 'part'
call ftabAdd abc, INSTANCE , , 'inst'
ox = m.abc.0 + 1
call sqlFTabOthers abc, 17
call fTabSetTit abc, ox, 2, 'others vorher'
call fTabSetTit abc, ox, 3, 'others nachher'
call sqlFTab abc, 17
call tstEnd t
call sqlDisConnect
return
endProcedure tstSqlFTab
tstSqlFTab2: procedure expose m.
/*
$=/tstSqlFTab2/
### start tst tstSqlFTab2 #########################################
Und Eins Oder
. zw aber
Und Eins---------------zw aber---
. und eins 22223
. und eins 22224
Und Eins---------------zw aber---
Und Eins Oder
. zw aber
a-------------b---
aaa 222
a-------------b---
--- row 1 ---------------------------------------------------------+
-------------
. Und Eins Oder und eins
. zw aber 2.2223000e04 22223
--- row 2 ---------------------------------------------------------+
-------------
. Und Eins Oder und eins
. zw aber 2.2224000e04 22224
--- end of 2 rows -------------------------------------------------+
-------------
$/tstSqlFTab2/
*/
call pipeIni
call tst t, 'tstSqlFTab2'
call sqlConnect , 'r'
sq1 = 'select '' und eins'' "Und Eins Oder"',
', 22222 + row_number() over() "zw aber" ',
'from sysibm.sysTables fetch first 2 rows only'
call sqlQuery 17, sq1
call sqlFTab sqlfTabReset(tstSqlFtab2), 17
sq2 = 'select ''aaa'' "a", 222 "b"' ,
'from sysibm.sysTables fetch first 1 rows only'
call sqlQuery 17, sq2
call sqlFTab sqlfTabReset(tstSqlFtab2), 17
call sqlQuery 15, sq1
call sqlFTab sqlfTabOpts(fTabReset(tstSqlFtab2, , , 'c')), 15
call tstEnd t
call sqlDisConnect
return
endProcedure tstSqlFTab2
tstSqlFTab3: procedure expose m.
/*
$=/tstSqlFTab3/
### start tst tstSqlFTab3 #########################################
Und Eins Oder
. zw aber
Und Eins--z---
. und eins 1
. und eins 2
Und Eins--z---
Und Eins Oder
. zw aber
a-----b---
aaa 222
a-----b---
$/tstSqlFTab3/
*/
call pipeIni
call tst t, 'tstSqlFTab3'
call sqlConnect , 'r'
sq1 = 'select '' und eins'' "Und Eins Oder"',
', row_number() over() "zw aber" ',
'from sysibm.sysTables fetch first 2 rows only'
call sqlQuery 7, sq1
ft = sqlFTabOpts(fTabReset('tstSqFTab3', , ,'-a'))
call sqlFTab ft, 7
sq2 = 'select ''aaa'' "a", 222 "b"' ,
'from sysibm.sysTables fetch first 1 rows only'
call sqlQuery 17, sq2
f = sqlfTabReset('tstSqFTab3t')
st = 'tstSqFTab3st'
call sqlFetch2St 17, st
s2 = 'tstSqFTab3s2'
do sx=1 to m.st.0
m.s2.sx = st'.'sx
end
m.s2.0 = m.st.0
call sqlFTabComplete f, 17, 1, 0
call fTabDetect f, s2
call fTabBegin f
do sx=1 to m.st.0
call out f(m.f.fmt, st'.'sx)
end
call fTabEnd f
call tstEnd t
call sqlDisConnect
return
endProcedure tstSqlFTab3
tstSqlFTab4: procedure expose m.
/*
$=/tstSqlFTab4/
### start tst tstSqlFTab4 #########################################
a
1
1 rows fetched: select 1 "a" from sysibm.sysDummy1
sqlCode -204: drop table gibt.EsNicht
a
2
1 rows fetched: select 2 "a" from sysibm.sysDummy1
*** err: SQLCODE = -104: ILLEGAL SYMBOL "Y". SOME SYMBOLS THAT MIGH+
T
. e 1: BE LEGAL ARE: , FROM INTO
. e 2: src select x frm y
. e 3: > <<<pos 14 of 14<<<
. e 4: sql = select x frm y
. e 5: stmt = prepare s49 into :M.SQL.49.D from :src
. e 6: with into :M.SQL.49.D = M.SQL.49.D
sqlCode -104: select x frm y
a
3
1 rows fetched: select 3 "a" from sysibm.sysDummy1
dy => 1
a
1
1 rows fetched: select 1 "a" from sysibm.sysDummy1
sqlCode -204: drop table gibt.EsNicht
a
2
1 rows fetched: select 2 "a" from sysibm.sysDummy1
fatal error in wsM: SQLCODE = -104: ILLEGAL SYMBOL "Y". SOME SYMBO+
LS THAT MIGHT
. BE LEGAL ARE: , FROM INTO
src select x frm y
. > <<<pos 14 of 14<<<
sql = select x frm y
stmt = prepare s49 into :M.SQL.49.D from :src
with into :M.SQL.49.D = M.SQL.49.D
sqlCode 0: rollback
ret => 0
$/tstSqlFTab4/
*/
call pipeIni
call tst t, 'tstSqlFTab4'
eOutOld = m.err_sayOut
m.err_sayOut = 1
call sqlConnect
b = jBuf('select 1 "a" from sysibm.sysDummy1;' ,
, 'drop table gibt.EsNicht;' ,
, 'select 2 "a" from sysibm.sysDummy1;',
, ' select x frm y;',
, 'select 3 "a" from sysibm.sysDummy1;')
call tstout t, 'dy =>' sqlsOut(scanSqlStmtRdr(b, 0))
call tstout t, 'ret =>' sqlsOut(scanSqlStmtRdr(b, 0), 'rb ret')
call tstEnd t
call sqlDisConnect
m.err_sayOut = eOutOld
return
endProcedure tstSqlFTab4
tstSqlFTab5: procedure expose m.
/*
$=/tstSqlFTab5/
### start tst tstSqlFTab5 #########################################
-----D6-------D73------D62---------D92---
. 23456 -123.456 45.00 -123.45
-----D6-------D73------D62---------D92---
$/tstSqlFTab5/
*/
call pipeIni
call tst t, 'tstSqlFTab5'
call sqlConnect , 'e'
sq1 = 'select dec(23456, 6) d6, dec(-123.4567, 7, 3) d73',
', dec(45, 6, 2) d62, dec(-123.45678, 9, 2) d92',
'from sysibm.sysDummy1'
call sqlQuery 17, sq1
call sqlFTab sqlfTabReset(tstSqlFtab5), 17
call tstEnd t
call sqlDisConnect
return
endProcedure tstSqlFTab5
tstSql4Obj: procedure expose m.
/*
$=/tstSql4Obj/
### start tst tstSql4Obj ##########################################
tstR: @tstWriteoV2 isA :tstClass-1 = -11
tstR: .a2i = -11
tstR: .b3b = b3
tstR: .D4 = D4-11+D4++++.
tstR: .fl5 = -111.1
tstR: .ex6 = -.111e-11
insert into cr.insTb -- tstClass-1
. ( , a2i, b3b, D4, fl5, ex6
. ) values .
. ( -11, -11, 'b3', 'D4-11+D4++++', -111.1, -.111e-11
. ) ; .
insert into cr.insTbHex -- tstClass-1
. ( , a2i, b3b, D4, fl5, ex6
. ) values .
. ( -11, -11, 'b3', x'C40760F1F14EC4F44E4E4E4E', -111.1, -.111e-1+
1
. ) ; .
tstR: @tstWriteoV4 isA :tstClass-2
tstR: .c = c83
tstR: .a2i = 83
tstR: .b3b = b3b8
tstR: .D4 = D483+D4++++++++++++++++++++++++++++++++++++++++++++++++
.++++++++++++++++++++++++++++++.
tstR: .fl5 = .183
tstR: .ex6 = .11183e-8
insert into cr.insTb -- tstClass-2
. ( c, a2i, b3b, D4, fl5, ex6
. ) values .
. ( 'c83', 83, 'b3b8'
. , 'D483+D4++++++++++++++++++++++++++++++++++++++++++++++++++++++
'
. || '++++++++++++++++++++++++'
. , .183, .11183e-8
. ) ; .
insert into cr.insTbHex -- tstClass-2
. ( c, a2i, b3b, D4, fl5, ex6
. ) values .
. ( 'c83', 83, 'b3b8'
. , x'C407F8F34EC4F44E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E'
. || '++++++++++++++++++++++++++++++++'
. || x'314E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E'
. , .183, .11183e-8
. ) ; .
$/tstSql4Obj/
*/
call pipeIni
call tst t, 'tstSql4Obj'
call pipe '+N'
call tstDataClassOut '. c3 a2i i b3b c5 D4 c23 fl5 f8n2 ex6 e9n3',
, -11, -11
call tstDataClassOut 'c c3 a2i i b3b c5 D4 c93 fl5 f8n2 ex6 e9n3',
, 83, 83
call pipe 'P|'
do cx=1 while in()
i = m.in
call mAdd t'.'trans, className(objClass(i)) 'tstClass-'cx
call out i
call sql4Obj i, 'cr.insTb'
m.i.d4 = overlay('07'x, m.i.d4, 2)
if length(m.i.d4) >= 62 then
m.i.d4 = overlay('31'x, m.i.d4, 62)
call sql4Obj i, 'cr.insTbHex'
end
call pipe '-'
call tstEnd t
return
endProcedure tstSql4Obj
tstSqlC: procedure expose m.
/*
$=/tstSqlCRx/
### start tst tstSqlCRx ###########################################
*** err: SQLCODE = -104: ILLEGAL SYMBOL "?". SOME SYMBOLS THAT MIGH+
T
. e 1: BE LEGAL ARE: . <IDENTIFIER> JOIN INNER LEFT RIGHT FU+
LL CROSS ,
. e 2: HAVING GROUP
. e 3: src select * from sysibm?sysDummy1
. e 4: > >>>pos 21 of 30>>>
. e 5: sql = select * from sysibm?sysDummy1
. e 6: stmt = prepare s10 into :M.SQL.10.D from :src
. e 7: with into :M.SQL.10.D = M.SQL.10.D
*** err: SQLCODE = -204: NONONO.SYSDUMMY1 IS AN UNDEFINED NAME
. e 1: sql = select * from nonono.sysDummy1
. e 2: stmt = prepare s10 into :M.SQL.10.D from :src
. e 3: with into :M.SQL.10.D = M.SQL.10.D
sys local ==> server CHSKA000DP4G .
fetched a1=abc, i2=12, c3=---
. I1 C2
. 1 eins
2222 zwei
$/tstSqlCRx/
$=/tstSqlCCsm/
### start tst tstSqlCCsm ##########################################
*** err: SQLCODE = -104: ILLEGAL SYMBOL "?". SOME SYMBOLS THAT MIGH+
T
. e 1: BE LEGAL ARE: . <IDENTIFIER> JOIN INNER LEFT RIGHT FU+
LL CROSS ,
. e 2: HAVING GROUP
. e 3: src select * from sysibm?sysDummy1
. e 4: > >>>pos 21 of 30>>>
. e 5: sql = select * from sysibm?sysDummy1
. e 6: sqlCsmExe RZZ/DE0G
*** err: SQLCODE = -204: NONONO.SYSDUMMY1 IS AN UNDEFINED NAME
. e 1: sql = select * from nonono.sysDummy1
. e 2: sqlCsmExe RZZ/DE0G
sys RZZ/DE0G csm ==> server CHROI00ZDE0G .
fetched a1=abc, i2=12, c3=---
. I1 C2
. 1 eins
2222 zwei
$/tstSqlCCsm/
### start tst tstSqlCWsh ##########################################
*** err: sqlWshRdr got fatal error in wsM: SQLCODE = -104: ILLEGAL +
SYMBOL "?". SOME SYMBOLS THAT MIGHT
. e 1: BE LEGAL ARE: . <IDENTIFIER> JOIN INNER LEFT RIGHT FU+
LL CROSS ,
. e 2: HAVING GROUP
. e 3: src select * from sysibm?sysDummy1
. e 4: > >>>pos 21 of 30>>>
. e 5: sql = select * from sysibm?sysDummy1
. e 6: stmt = prepare s10 into :M.SQL.10.D from :src
. e 7: with into :M.SQL.10.D = M.SQL.10.D
*** err: sqlWshRdr got fatal error in wsM: SQLCODE = -204: NONONO.S+
YSDUMMY1 IS AN UNDEFINED NAME
. e 1: sql = select * from nonono.sysDummy1
. e 2: stmt = prepare s10 into :M.SQL.10.D from :src
. e 3: with into :M.SQL.10.D = M.SQL.10.D
sys RZZ/DE0G wsh ==> server CHROI00ZDE0G .
fetched a1=abc, i2=12, c3=---
. I1 C2
. 1 eins
$=/tstSqlCWsh/
### start tst tstSqlCWsh ##########################################
*** err: sqlWshRdr got fatal error in wsM: SQLCODE = -104: ILLEGAL+
. SYMBOL "?". SOME SYMBOLS THAT MIGHT
. e 1: BE LEGAL ARE: . <IDENTIFIER> JOIN INNER LEFT RIGHT FU+
LL CROSS ,
. e 2: HAVING GROUP
. e 3: src select * from sysibm?sysDummy1
. e 4: > >>>pos 21 of 30>>>
. e 5: sql = select * from sysibm?sysDummy1
. e 6: stmt = prepare s10 into :M.SQL.10.D from :src
. e 7: with into :M.SQL.10.D = M.SQL.10.D
. e 8: sqlCode 0: rollback
. e 9: from RZZ Z24 DE0G
*** err: sqlWshRdr got fatal error in wsM: SQLCODE = -204: NONONO.+
SYSDUMMY1 IS AN UNDEFINED NAME
. e 1: sql = select * from nonono.sysDummy1
. e 2: stmt = prepare s10 into :M.SQL.10.D from :src
. e 3: with into :M.SQL.10.D = M.SQL.10.D
. e 4: sqlCode 0: rollback
. e 5: from RZZ Z24 DE0G
sys RZZ/DE0G wsh ==> server CHROI00ZDE0G .
fetched a1=abc, i2=12, c3=---
. I1 C2
. 1 eins
2222 zwei
$/tstSqlCWsh/
*/
call pipeIni
sql1 = "select 1 i1, 'eins' c2 from sysibm.sysDummy1" ,
"union all select 2222 i1, 'zwei' c2 from sysibm.sysDummy1"
do tx=1 to 1 + (m.tst_CsmRZ \== '') * 2
if tx = 1 then do
call tst t, "tstSqlCRx"
call sqlConnect , 'r'
sys = 'local'
end
else if tx=2 then do
call tst t, "tstSqlCCsm"
sys = m.tst_csmRzDb 'csm'
call sqlConnect m.tst_csmRzDb, 'c'
end
else do
call tst t, "tstSqlCWsh"
call sqlConnect m.tst_csmRzDb, 'w'
sys = m.tst_csmRzDb 'wsh'
end
cx = 9
call jOpen sqlRdr('select * from sysibm?sysDummy1'), '<'
call jOpen sqlRdr('select * from nonono.sysDummy1'), '<'
rr = jOpen(sqlRdr("select 'abc' a1, 12 i2, current server srv",
", case when 1=0 then 1 else null end c3",
"from sysibm.sysDummy1"), '<')
do while jRead(rr)
dst = m.rr
call out 'sys' sys '==> server' m.dst.srv
call out 'fetched a1='m.dst.a1', i2='m.dst.i2', c3='m.dst.c3
end
call jClose rr
call fTabAuto , sqlRdr(sql1)
call sqlDisconnect
call tstEnd t
end
return
endProcedure tstSqlC
tstSqlUpd: procedure expose m.
/*
$=/tstSqlUpd/
### start tst tstSqlUpd ###########################################
insert updC 1
insert select updC 2
dest4.fet: 1 eins 2012-04-01-06.07.08.000000 1 updC 0
dest5.fet: 2 zwei 2012-02-29-15.44.33.220000 --- updC 0
dest6.fet: 11 zehn+eins 2012-04-11-06.07.08.000000 1 updC 0
dest7.fet: 12 zehn+zwei 2012-03-10-15.44.33.220000 --- updC 0
SQLCODE = 000, SUCCESSFUL EXECUTION
warnings 4=W no where
sql = select * from final table (update session.dgtt set c2 = 'u' +
|| c2)
stmt = prepare s9 into :M.SQL.9.D from :src
with into :M.SQL.9.D = M.SQL.9.D
dest9.fet: 1 ueins 2012-04-01-06.07.08.000000 updC 4
dest10.fet: 2 uzwei 2012-02-29-15.44.33.220000 updC 4
dest11.fet: 11 uzehn+eins 2012-04-11-06.07.08.000000 updC 4
dest12.fet: 12 uzehn+zwei 2012-03-10-15.44.33.220000 updC 4
$/tstSqlUpd/ */
call tst t, "tstSqlUpd"
cx = 9
qx = 3
call sqlConnect , 'e'
call sqlUpdate,"declare global temporary table session.dgtt",
"(i1 int, c2 varchar(20), t3 timestamp)"
call sqlUpdate,"insert into session.dgtt" ,
"values(1, 'eins', '2012-04-01 06.07.08')"
call sqlUpdate,"insert into session.dgtt" ,
"values(2, 'zwei', '2012-02-29 15:44:33.22')"
call out 'insert updC' m.sql..updateCount
call sqlUpdate,"insert into session.dgtt" ,
"select i1+10, 'zehn+'||strip(c2), t3+10 days",
"from session.dgtt"
call out 'insert select updC' m.sql..updateCount
call sqlQuery cx, 'select d.*' ,
', case when mod(i1,2) = 1 then 1 else null end grad' ,
'from session.dgtt d'
do qx=qx+1 while sqlFetch(cx, 'dest'qx'.fet')
dst = 'dest'qx'.fet'
call out dst':' m.dst.i1 m.dst.c2 m.dst.t3 m.dst.grad ,
'updC' m.sql.cx.updateCount
drop m.dst.i1 m.dst.c2 m.dst.t3 m.dst.grad
end
call sqlClose cx
call sqlQuery cx, "select * from final table (update session.dgtt",
" set c2 = 'u' || c2)"
do qx=qx+1 while sqlFetch(cx, 'dest'qx'.fet')
dst = 'dest'qx'.fet'
call out dst':' m.dst.i1 m.dst.c2 m.dst.t3 ,
'updC' m.sql.cx.updateCount
drop m.dst.i1 m.dst.c2 m.dst.t3 m.dst.grad
end
call sqlDisconnect
call tstEnd t
return
endProcedure tstSqlUpd
tstSqlUpdPre: procedure expose m.
/*
$=/tstSqlUpdPre/
### start tst tstSqlUpdPre ########################################
insert updC 1
insert select updC 2
dest4.fet: 1 eins 2012-04-01-06.07.08.000000 1 updC 0
dest5.fet: 2 zwei 2012-02-29-15.44.33.220000 --- updC 0
dest6.fet: 11 zehn+eins 2012-04-11-06.07.08.000000 1 updC 0
dest7.fet: 12 zehn+zwei 2012-03-10-15.44.33.220000 --- updC 0
SQLCODE = 000, SUCCESSFUL EXECUTION
warnings 4=W no where
sql = select * from final table ( update session.dgtt set c2 = ? ||+
. c2)
stmt = prepare s5 into :M.SQL.5.D from :src
with into :M.SQL.5.D = M.SQL.5.D
dest9.fet: 1 ueins 2012-04-01-06.07.08.000000 updC 4
dest10.fet: 2 uzwei 2012-02-29-15.44.33.220000 updC 4
dest11.fet: 11 uzehn+eins 2012-04-11-06.07.08.000000 updC 4
dest12.fet: 12 uzehn+zwei 2012-03-10-15.44.33.220000 updC 4
$/tstSqlUpdPre/ */
call tst t, "tstSqlUpdPre"
cx = 5
qx = 3
call sqlConnect , 'e'
call sqlUpdate,"declare global temporary table session.dgtt",
"(i1 int, c2 varchar(20), t3 timestamp)"
call sqlUpdatePrepare 5, "insert into session.dgtt" ,
"values (?, ?, ?)"
call sqlUpdateExecute 5, 1, 'eins', '2012-04-01 06.07.08'
call sqlUpdateExecute 5, 2, 'zwei', '2012-02-29 15:44:33.22'
call out 'insert updC' m.sql.5.updateCount
call sqlUpdatePrepare 5,"insert into session.dgtt" ,
"select i1+?, 'zehn+'||strip(c2), t3+? days",
"from session.dgtt"
call sqlUpdateExecute 5, 10, 10
call out 'insert select updC' m.sql.5.updateCount
call sqlQueryPrepare cx, 'select d.*' ,
', case when mod(i1,2) = ? then 0+? else null end grad',
'from session.dgtt d'
call sqlQueryExecute cx, 1, 1
do qx=qx+1 while sqlFetch(cx, 'dest'qx'.fet')
dst = 'dest'qx'.fet'
call out dst':' m.dst.i1 m.dst.c2 m.dst.t3 m.dst.grad ,
'updC' m.sql.cx.updateCount
drop m.dst.i1 m.dst.c2 m.dst.t3 m.dst.grad
end
call sqlClose cx
call sqlQueryPrepare cx, "select * from final table (" ,
"update session.dgtt set c2 = ? || c2)"
call sqlQueryExecute cx, "u"
do qx=qx+1 while sqlFetch(cx, 'dest'qx'.fet')
dst = 'dest'qx'.fet'
call out dst':' m.dst.i1 m.dst.c2 m.dst.t3 ,
'updC' m.sql.cx.updateCount
drop m.dst.i1 m.dst.c2 m.dst.t3 m.dst.grad
end
call sqlDisconnect
call tstEnd t
return
endProcedure tstSqlUpdPre
tstsqlRxUpd: procedure expose m.
/*
$=/tstsqlRxUpd/
### start tst tstsqlRxUpd #########################################
insert updC 1
insert select updC 2
dest4.fet: 1 eins 2012-04-01-06.07.08.000000 1 updC 0
dest5.fet: 2 zwei 2012-02-29-15.44.33.220000 --- updC 0
dest6.fet: 11 zehn+eins 2012-04-11-06.07.08.000000 1 updC 0
dest7.fet: 12 zehn+zwei 2012-03-10-15.44.33.220000 --- updC 0
SQLCODE = 000, SUCCESSFUL EXECUTION
warnings 4=W no where
sql = select * from final table (update session.dgtt set c2 = 'u' +
|| c2)
stmt = prepare s9 into :M.SQL.9.D from :src
with into :M.SQL.9.D = M.SQL.9.D
dest9.fet: 1 ueins 2012-04-01-06.07.08.000000 updC 4
dest10.fet: 2 uzwei 2012-02-29-15.44.33.220000 updC 4
dest11.fet: 11 uzehn+eins 2012-04-11-06.07.08.000000 updC 4
dest12.fet: 12 uzehn+zwei 2012-03-10-15.44.33.220000 updC 4
$/tstsqlRxUpd/ */
call pipeIni
call tst t, "tstsqlRxUpd"
cx = 9
qx = 3
call sqlConnect , 'e'
call sqlUpdate,"declare global temporary table session.dgtt",
"(i1 int, c2 varchar(20), t3 timestamp)"
call sqlUpdate,"insert into session.dgtt" ,
"values(1, 'eins', '2012-04-01 06.07.08')"
call sqlUpdate,"insert into session.dgtt" ,
"values(2, 'zwei', '2012-02-29 15:44:33.22')"
call out 'insert updC' m.sql..updateCount
call sqlUpdate,"insert into session.dgtt" ,
"select i1+10, 'zehn+'||strip(c2), t3+10 days",
"from session.dgtt"
call out 'insert select updC' m.sql..updateCount
call sqlQuery cx, 'select d.*' ,
', case when mod(i1,2) = 1 then 1 else null end grad' ,
'from session.dgtt d'
do qx=qx+1 while sqlFetch(cx, 'dest'qx'.fet')
dst = 'dest'qx'.fet'
call out dst':' m.dst.i1 m.dst.c2 m.dst.t3 m.dst.grad ,
'updC' m.sql.cx.updateCount
drop m.dst.i1 m.dst.c2 m.dst.t3 m.dst.grad
end
call sqlClose cx
call sqlQuery cx, "select * from final table",
"(update session.dgtt set c2 = 'u' || c2)"
do qx=qx+1 while sqlFetch(cx, 'dest'qx'.fet')
dst = 'dest'qx'.fet'
call out dst':' m.dst.i1 m.dst.c2 m.dst.t3 ,
'updC' m.sql.cx.updateCount
drop m.dst.i1 m.dst.c2 m.dst.t3 m.dst.grad
end
call sqlClose cx
call sqlDisconnect
call tstEnd t
return
endProcedure tstsqlRxUpd
tstSqlE: procedure expose m.
/*
$=/tstSqlE/
### start tst tstSqlE #############################################
*** err: SQLCODE = -713: THE REPLACEMENT VALUE FOR CURRENT SCHEMA I+
S
. e 1: INVALID
. e 2: sql = set current schema = 'sysibm'
. e 3: stmt = execute immediate :src
-713 set schema ''
0 set schema
0 select
fetch=1 SYSIBM
$/tstSqlE/
*/
call sqlConnect , 'e'
call tst t, "tstSqlE"
call tstOut t, sqlExecute(3, "set current schema = 'sysibm'") ,
"set schema ''"
call tstOut t, sqlExecute(3, " set current schema = sysibm ") ,
"set schema"
call tstOut t, sqlExecute(3, " select current schema c" ,
"from sysibm.sysDummy1") 'select'
call tstOut t, 'fetch='sqlFetch(3, aa) m.aa.c
call sqlClose 3
call sqlDisConnect
call tstEnd t
return
endProcedure tstSqlE
tstSqlO: procedure expose m.
/*
$=/tstSqlO/
### start tst tstSqlO #############################################
sqlCode 0: set current schema = A540769
*** err: SQLCODE = -204: A540769.SYSDUMMY IS AN UNDEFINED NAME
. e 1: sql = select * from sysdummy
. e 2: stmt = prepare s49 into :M.SQL.49.D from :src
. e 3: with into :M.SQL.49.D = M.SQL.49.D
sqlCode -204: select * from sysdummy
REQD=Y col=123 case=--- .sqlInd:-1 col5=anonym geburri=1956-04-01+
-06.00.00.000000
$/tstSqlO/
*/
call sqlConnect , 's'
call tst t, "tstSqlO"
call sqlStmts 'set current schema = A540769';
call sqlStmts 'select * from sysdummy';
r = sqlRdr( ,
"select d.*, 123, timestamp('01.04.1956','06:00:00')" ,
'"geburri walter",',
'case when 1=0 then 1 else null end caseNull,',
"'anonym'" ,
'from sysibm.sysdummy1 d')
call jOpen r, '<'
do while jRead(r)
o = m.r
call out 'REQD='m.o.IBMREQD 'col='m.o.col2,
'case='m.o.CASENULL '.sqlInd:'m.o.caseNull.sqlInd,
'col5='m.o.col5,
'geburri='m.o.GEBURRI
end
call jClose r
call sqlDisConnect
call tstEnd t
return
endProcedure tstSqlO
tstSqlUpdComLoop: procedure expose m.
/*
$=/tstSqlUpdComLoop/
### start tst tstSqlUpdComLoop ####################################
sqlCode 0: declare global temporary table session.dgtt (i1 int) on +
commit ....
sqlCode 0, 123 rows inserted: insert into session.dgtt select row_n+
umber()....
CNT
123
1 rows fetched: select count(*) cnt from session.dgtt
123 rows deleted, 10 commits: delete from session.dgtt d where i1 i+
n (sele....
C
0
1 rows fetched: select count(*) cnt from session.dgtt
$/tstSqlUpdComLoop/ */
call pipeIni
call tst t, "tstSqlUpdComLoop"
call sqlConnect , 's'
call sqlsOut "declare global temporary table session.dgtt",
"(i1 int) on commit preserve rows"
call sqlsOut "insert into session.dgtt",
"select row_number() over() from sysibm.sysTables",
"fetch first 123 rows only"
call sqlsOut "select count(*) cnt from session.dgtt"
call out sqlUpdComLoop("delete from session.dgtt d where i1 in",
"(select i1 from session.dgtt fetch first 13 rows only)")
call sqlsOut "select count(*) cnt from session.dgtt"
call sqlDisConnect
call tstEnd t
return
endProcedure tstSqlUpdComLoop
tstSqlO1: procedure expose m.
/*
$=/tstSqlO1/
### start tst tstSqlO1 ############################################
tstR: @tstWriteoV2 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLEPART
tstR: @tstWriteoV3 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLEPART_HIST
tstR: @tstWriteoV4 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLES
tstR: @tstWriteoV5 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLESPACE
--- writeAll
tstR: @tstWriteoV6 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLEPART
tstR: @tstWriteoV7 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLEPART_HIST
tstR: @tstWriteoV8 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLES
tstR: @tstWriteoV9 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLESPACE
$/tstSqlO1/
*/
call pipeIni
call tst t, "tstSqlO1"
call sqlConnect , 'r'
qr = sqlRdr("select strip(creator) cr, strip(name) tb",
"from sysibm.sysTables",
"where creator='SYSIBM' and name like 'SYSTABL%'",
"order by 2 fetch first 4 rows only")
call jOpen qr, m.j.cRead
call mAdd t.trans, className(m.qr.type) '<tstSqlO1Type>'
do while jRead(qr)
call out m.qr
end
call jClose qr
call out '--- writeAll'
call pipeWriteAll qr
call sqlDisConnect
call tstEnd t
return 0
endProcedure tstSqlO1
tstSqlO2: procedure expose m.
/*
$=/tstSqlO2/
### start tst tstSqlO2 ############################################
CR TB RR
SYSIBM SYSTABLEPART 1
SYSIBM SYSTABLEPART_HIST 4
SYSIBM SYSTABLES 9
SYSIBM SYSTABLESPACE 16
$/tstSqlO2/
*/
call pipeIni
call tst t, "tstSqlO2"
call sqlConnect , 'r'
call pipe '+N'
call out "select strip(creator) cr, strip(name) tb,"
call out "(row_number()over())*(row_number()over()) rr"
call out "from sysibm.sysTables"
call out "where creator='SYSIBM' and name like 'SYSTABL%'"
call out "order by 2 fetch first 4 rows only"
call pipe 'N|'
call sqlSel
call pipe 'P|'
call fTabAuto fTabReset(abc, 1)
call pipe '-'
call sqlDisConnect
call tstEnd t
return 0
endProcedure tstSqlO2
tstSqlS1: procedure expose m.
/*
$=/tstSqlS1/
### start tst tstSqlS1 ############################################
select c, a from sysibm.sysDummy1
tstR: @tstWriteoV2 isA :<cla sql c a>
tstR: .C = 1
tstR: .A = a
select ... where 1=0
tstR: @ obj null
$/tstSqlS1/
*/
call tst t, "tstSqlS1"
call sqlConnect , 'r'
s1 = jSingle( ,
sqlRdr("select count(*) c, 'a' a from sysibm.sysdummy1"))
call mAdd t.trans, className(objClass(s1)) '<cla sql c a>'
call out 'select c, a from sysibm.sysDummy1'
call tstWrite t, s1
call out 'select ... where 1=0'
call tstWrite t, jSingle( ,
sqlRdr("select*from sysibm.sysdummy1 where 1=0"), '')
call sqlDisConnect
call tstEnd t
return
endProcedure tstSqlS1
tstSqlWsh: procedure expose m.
/*
$=/tstSqlWsh/
### start tst tstSqlWsh ###########################################
tstR: @tstWriteoV14 isA :Sql*15
tstR: .COL1 = <csmServer>
1 rows fetched: select current server from sysibm.sysDummy1
tstR: @tstWriteoV16 isA :Sql*17
tstR: .ZWEI = second sel
tstR: .DREI = 3333
tstR: .VIER = 4444
1 rows fetched: select 'second sel' zwei, 3333 drei, 4444 vier from+
. sysibm....
fatal error in wsM: SQLCODE = -104: ILLEGAL SYMBOL "XYZ". SOME SYM+
BOLS THAT
. MIGHT BE LEGAL ARE: <ERR_STMT> <WNG_STMT> GET SQL SAVEPOINT HO+
LD
. FREE ASSOCIATE
src xyz
. > <<<pos 1 of 3<<<
sql = xyz
sqlCode 0: rollback
from <csmRZ> <csmSys*> <csmDB>
$/tstSqlWsh/
*/
call pipeIni
call sqlconClass_w
call tst t, "tstSqlWsh"
call tstTransCsm t
b = jBuf('select current server from' , 'sysibm.sysDummy1',
, ';;;', "select 'second sel' zwei, 3333 drei, 4444 vier" ,
, "from sysibm.sysDummy1",,";;xyz")
r = scanSqlStmtRdr(b)
call sqlWshOut r, m.tst_csmRzDb, 0, 'o'
call tstEnd t
return
endProcedure tstSqlWsh
tstSqlWs2: procedure expose m.
/*
$=/tstSqlWs2/
### start tst tstSqlWs2 ###########################################
tstR: @tstWriteoV14 isA :Sql*15
tstR: .COL1 = <csmServer> .
tstR: .COLNO = 1
tstR: .NAME = NAME
tstR: @tstWriteoV16 isA :Sql*15
tstR: .COL1 = <csmServer> .
tstR: .COLNO = 2
tstR: .NAME = CREATOR
tstR: @tstWriteoV17 isA :Sql*15
tstR: .COL1 = <csmServer> .
tstR: .COLNO = 3
tstR: .NAME = TYPE
tstR: @tstWriteoV18 isA :Sql*15
tstR: .COL1 = <csmServer> .
tstR: .COLNO = 4
tstR: .NAME = DBNAME
$/tstSqlWs2/
*/
call pipeIni
call sqlconClass_w
call tst t, "tstSqlWs2"
call tstTransCsm t
sql = "select current server, colNo, name" ,
"from sysibm.sysColumns" ,
"where tbCreator = 'SYSIBM' and tbName = 'SYSTABLES'",
"order by colNo fetch first 4 rows only"
w = oNew(m.class_SqlWshRdr, m.tst_csmRzDb, sql)
call pipeWriteNow w
call tstEnd t
return
endProcedure tstSqlWs2
tstSqlStmt: procedure expose m.
/*
$=/tstSqlStmt/
### start tst tstSqlStmt ##########################################
*** err: SQLCODE = -713: THE REPLACEMENT VALUE FOR CURRENT SCHEMA I+
S
. e 1: INVALID
. e 2: sql = set current schema = 'sysibm'
. e 3: stmt = execute immediate :src
sqlCode -713: set current schema = 'sysibm'
sqlCode 0: set current schema = sysibm
tstR: @tstWriteoV2 isA :<sql?sc>
tstR: .C = SYSIBM
1 rows fetched: select current schema c from sysDummy1
tstR: @tstWriteoV3 isA :<sql?sc>
tstR: .C = SYSIBM
1 rows fetched: (select current schema c from sysDummy1)
$/tstSqlStmt/
*/
call sqlConnect , 's'
call tst t, "tstSqlStmt"
cn = className(classNew('n* Sql u f%v C'))
call mAdd t.trans, cn '<sql?sc>'
call sqlStmts "set current schema = 'sysibm'"
call sqlsOut " set current schema = sysibm "
call sqlsOut " select current schema c from sysDummy1", , 'o'
call sqlsOut " (select current schema c from sysDummy1)", , 'o'
call sqlDisConnect
call tstEnd t
return
endProcedure tstSqlStmt
tstSqlStmts: procedure expose m.
/*
$=/tstSqlStmts/
### start tst tstSqlStmts #########################################
*** err: SQLCODE = -104: ILLEGAL SYMBOL "BLABLA". SOME SYMBOLS THAT
. e 1: MIGHT BE LEGAL ARE: <ERR_STMT> <WNG_STMT> GET SQL SAV+
EPOINT HOLD
. e 2: FREE ASSOCIATE
. e 3: src blabla
. e 4: > <<<pos 1 of 6<<<
. e 5: sql = blabla
sqlCode -104: blabla
sqlCode 0: set current schema= sysIbm
c
1
1 rows fetched: select count(*) "c" from sysDummy1 with ur
c
1
1 rows fetched: select count(*) "c" from sysDummy1 with ur
#jIn 1# set current -- sdf
#jIn 2# schema = s100447;
#jIn eof 3#
sqlCode 0: set current schema = s100447
$/tstSqlStmts/ */
call sqlConnect , 's'
call tst t, "tstSqlStmts"
call sqlStmts "blabla ;;set current schema= sysIbm "
b = jBuf('select count(*) "c" from sysDummy1 --com' ,
,'with /* comm */ ur;')
call sqlStmts b
call sqlStmts b
call mAdd mCut(t'.IN', 0), 'set current -- sdf','schema = s100447;'
call sqlStmts
call sqlDisConnect
call tstEnd t
return
endProcedure tstSqlStmts
tstDb2Ut: procedure expose m.
/*
$=/tstDb2Ut/
### start tst tstDb2Ut ############################################
. TEMPLATE IDSN DSN(DSN.INPUT.UNL)
#jIn 1# template old ,
. template old ,
#jIn 2# LOAD DATA INDDN oldDD .
LOAD DATA LOG NO
. INDDN IDSN RESUME NO REPLACE COPYDDN(TCOPYD)
. DISCARDDN TDISC
. STATISTICS INDEX(ALL) UPDATE ALL
. DISCARDS 1
. ERRDDN TERRD
. MAPDDN TMAPD .
. WORKDDN (TSYUTD,TSOUTD) .
. SORTDEVT DISK .
#jIn 3# ( cols )
( cols )
$/tstDb2Ut/
*/
call pipeIni
call tst t, 'tstDb2Ut'
call mAdd mCut(t'.IN', 0), ' template old ,' ,
, 'LOAD DATA INDDN oldDD ' ,
, '( cols )'
call db2UtilPunch 'rep iDsn=DSN.INPUT.UNL'
call tstEnd t
return
endProcedure tstDb2Ut
/*--- manualTest for csi --------------------------------------------*/
tstSqlDisDb: procedure expose m.
call sqlDsn di, 'DP4G', '-dis db(*) sp(*)' ,
'restrict advisory limit(*)', 12
m.oo.0 = 0
call sqlDisDb oo, di
say 'di.0' m.di.0 '==> oo.0' m.oo.0
trace ?r
ix = sqlDisDbIndex(oo, QZ01A1P,A006A)
say 'DB2PDB6.RR2HHAGE ==>' ix m.oo.ix.sta
ix = sqlDisDbIndex(oo, QZ01A1P,A006J, 3)
say 'DB2PDB6.RR2HHAGE.3 ==>' ix m.oo.ix.sta
ix = sqlDisDbIndex(oo, DB2PDB6,RR2HHAGE,22)
say 'DB2PDB6.RR2HHAGE.22 ==>' ix m.oo.ix.sta
return
endProcedure tstSqlDisDb
/****** tst wsh main and hooks ***************************************/
tstMain: procedure expose main
/*
$=/tstMain/
### start tst tstMain #############################################
DREI
. ABC
D ABC
3 abc
1 rows fetched: select 1+2 drei, 'abc' abc from sysibm.sysDummy1
$/tstMain/
*/
call pipeIni
i = jBuf("select 1+2 drei, 'abc' abc" ,
"from sysibm.sysDummy1")
call tst t, 'tstMain'
w = tstMain1
m.w.exitCC = 0
call wshRun w, 'sqlsOut */ a', i
call tstEnd t
return
endProcedure tstMain
tstHookSqlRdr: procedure expose m.
/*
$=/tstHookSqlRdr/
### start tst tstHookSqlRdr #######################################
tstR: @tstWriteoV1 isA :Sql*2
tstR: .F5 = 5
tstR: .F2 = zwei
fatal error in wsM: SQLCODE = -104: ILLEGAL SYMBOL "?". SOME SYMBO+
LS THAT MIGHT
. BE LEGAL ARE: AT MICROSECONDS MICROSECOND SECONDS SECOND MINUT+
ES
. MINUTE HOURS
src select 2?3 f5, 'zwei' f2 from sysibm.sysDummy1
. > <<<pos 9 of 46<<<
sql = select 2?3 f5, 'zwei' f2 from sysibm.sysDummy1
stmt = prepare s10 into :M.SQL.10.D from :src
with into :M.SQL.10.D = M.SQL.10.D
sqlCode 0: rollback
from RZ4 S42 DP4G
fatal error in wsM: SQLCODE = -924: DB2 CONNECTION INTERNAL ERROR, +
00000002,
. 0000000C, 00F30006
sql = connect NODB
from RZ4 S42 NODB
$/tstHookSqlRdr/
*/
call pipeIni
call tst t, 'tstHookSqlRdr'
w = tst_wsh
m.w.outLen = 99
m.w.in = jBuf("select 2+3 f5, 'zwei' f2 from sysibm.sysDummy1")
call wshHook_sqlRdr w
m.w.in = jBuf("select 2?3 f5, 'zwei' f2 from sysibm.sysDummy1")
call wshHook_sqlRdr w
call wshHook_sqlRdr w, 'noDB'
call tstEnd t
return
endProcedure tstHookSqlRdr
/****** tstComp *******************************************************
test the wsh compiler
**********************************************************************/
tstComp: procedure expose m.
call compIni
call tstCompDataConst
call tstCompDataVars
call tstCompShell
call tstCompPrimary
call tstCompExpr
call tstCompFile
call tstCompStmt
call tstCompDir
call tstCompObj
call tstCompORun
call tstCompORu2
call tstCompORuRe
call tstCompDataIO
call tstCompPipe
call tstCompPip2
call tstCompRedir
call tstCompComp
call tstCompColon
call tstCompWithNew
call tstCompSyntax
if m.err_os == 'TSO' then
call tstCompSql
call tstTotal
return
endProcedure tstComp
tstComp1: procedure expose m.
parse arg ty nm cnt
c1 = 0
if cnt = 0 | cnt = '+' then do
c1 = cnt
cnt = ''
end
call jIni
src = jBuf()
call jOpen src, m.j.cWri
do sx=2 to arg()
call jWrite src, arg(sx)
end
call tstComp2 nm, ty, jClose(src), , c1, cnt
return
endProcedure tstComp1
tstComp2: procedure expose m.
parse arg nm, spec, src, compSt
call compIni
call tst t, nm, compSt
if src == '' then do
src = jBuf()
call tst4dp src'.BUF', mapInline(nm'Src')
end
m.t.moreOutOk = abbrev(strip(arg(5)), '+')
oldErr = m.err.count
call out 'compile' spec',' (m.src.buf.0) 'lines:' m.src.buf.1
r = wshHookComp(tstWWWW, spec, src)
noSyn = m.err.count = oldErr
coErr = m.t.err
if noSyn then
say "compiled" r ":" objMet(r, 'oRun')
else
say "*** syntaxed"
cnt = 0
do ax = 5 to max(arg(), 5) while m.t.err = coErr & noSyn
a1 = strip(arg(ax))
if a1 == '' & arg() >= 5 then
iterate
if abbrev(a1, '+') then do
m.t.moreOutOk = 1
a1 = strip(substr(a1, 2))
end
if datatype(a1, 'n') then
cnt = a1
else if a1 \== '' then
call err 'tstComp2 bad arg('ax')' arg(ax)
if cnt = 0 then do
call mCut 'T.IN', 0
call out "run without input"
end
else do
call mAdd mCut('T.IN', 0),
,"eins zwei drei", "zehn elf zwoelf?",
, "zwanzig 21 22 23 24 ... 29|"
do lx=4 to cnt
call mAdd 'T.IN', left(lx "line" lx, lx+9, '-')';'
end
call out "run with" cnt "inputs"
end
m.t.inIx = 0
call oRun r
end
call tstEnd t
return
endProcedure tstComp2
tstCompDataConst: procedure expose m.
/*
$=/tstCompDataConst/
### start tst tstCompDataConst ####################################
compile =, 8 lines: Lline one, $** asdf
run without input
. Lline one, .
line two..
line threecontinued on 4
line five fortsetzung
line six fortsetzung
$/tstCompDataConst/ */
call tstComp1 '= tstCompDataConst',
, ' Lline one, $** asdf',
, 'line two.',
, 'line three$*+ bla bla' ,
, 'continued on 4',
, 'line five $*( und so',
, 'weiter $abc $? $''$*)'' $"$*)" und weiter $*) fortsetzung',
, 'line six $*( und $*( $** $*( so',
, 'weiter $abc $? $*)'' $"$*)" und weiter $*) fortsetzung'
/*
$=/tstCompDataConstBefAftComm1/
### start tst tstCompDataConstBefAftComm1 #########################
compile =, 3 lines: $*(anfangs com.$*) $*(plus$*) $** x
run without input
the only line;
$/tstCompDataConstBefAftComm1/ */
call tstComp1 '= tstCompDataConstBefAftComm1',
, ' $*(anfangs com.$*) $*(plus$*) $** x',
, 'the only line;',
, ' $*(end kommentar$*) '
/*
$=/tstCompDataConstBefAftComm2/
### start tst tstCompDataConstBefAftComm2 #########################
compile =, 11 lines: $*(anfangs com.$*) $*(plus$*) $*+ x
run without input
the first non empty line;
tstR: @ obj null
befor an empty line with comments;
$/tstCompDataConstBefAftComm2/ */
call tstComp1 '= tstCompDataConstBefAftComm2',
, ' $*(anfangs com.$*) $*(plus$*) $*+ x',
, ' $*(forts Zeile com.$*) $*(plus$*) $** x',
, ' $*(comment 2. Zeile$*) $*(plus$*) $*+ x',
, ' $*(forts Zeile com.$*) $*(plus$*) $** x',
, 'the first non empty line;',
, ' ',
, 'befor an empty line with comments;',
, ' $*(comment 4. Zeile$*) $*(plus$*) $*+ x',
, ' $*(forts 4.Zeile com.$*) $*(plus$*) $** x',
, ' $*(end kommentar$*) $*+',
, ' $*(forts end com.$*) $*(plus$*) $** x'
return
endProcedure tstCompDataComm
tstCompDataVars: procedure expose m.
/*
$=/tstCompDataVars/
### start tst tstCompDataVars #####################################
compile =, 5 lines: Lline one, $** asdf
run without input
. Lline one, .
lline zwei output
lline 3 .
variable v1 = valueV1 ${v1}= valueV1;
. $-{""$v1} = valueV1;
$/tstCompDataVars/ */
call tstComp1 '= tstCompDataVars',
, ' Lline one, $** asdf',
, ' $$ lline zwei output',
, 'lline 3 $=v1= valueV1 ' ,
, 'variable v1 = $v1 $"${v1}=" ${ v1 }; ',
, ' $"$-{""""$v1} =" $-{$""$"v1"}; '
return
endProcedure tstCompDataVars
tstCompShell: procedure expose m.
/*
$=/tstCompShell3/
### start tst tstCompShell3 #######################################
compile @, 8 lines: call tstOut "T", "abc" $-¢2*3$! "efg"$-¢2*3$!"+
hij"
run without input
abc 6 efg6hij
insert into A540769x.tqt002 with n(n) as ( select 4 from sysibm.s
insert into A540769x.tqt002 with n(n) as ( select 4 from sysibm.s +
. union all .
abc 6 efg6hij
$/tstCompShell3/ */
call tstComp1 '@ tstCompShell3',
, 'call tstOut "T", "abc" $-¢2*3$! "efg"$-¢2*3$!"hij"',
, 'ix=3' ,
, 'call tstOut "T","insert into A540769x.tqt002" ,',
, '"with n(n) as ( select" $-¢ix+1$! "from sysibm.s"',
, 'call tstOut "T","insert into A540769x.tqt002" , ',
, '"with n(n) as ( select" $-¢ix+1$! "from sysibm.s" , ' ,
, '" union all "' ,
, '$$ abc $-¢2*3$! efg$-¢2*3$!hij',
/*
$=/tstCompShell/
### start tst tstCompShell ########################################
compile @, 12 lines: $$ Lline one, $** asdf
run without input
Lline one,
lline zwei output
v1 = valueV1 ${v1}= valueV1|
REXX OUT L5 CONTINUED L6 CONTINUED L7
L8 ONE
L9 TWO
valueV1
valueV1 valueV2
out valueV1 valueV2
SCHLUSS
$/tstCompShell/ */
call tstComp1 '@ tstCompShell',
, ' $$ Lline one, $** asdf',
, ' $$ lline zwei output',
, ' $=v1= valueV1 ' ,
, '$$ v1 = $v1 $"${v1}=" ${ v1 }| ' ,
, 'call out rexx out l5, ' ,
, ' continued l6 , ' ,
, ' continued l7 ' ,
, 'call out l8 one ' ,
, 'call out l9 two$=v2=valueV2 ',
, '$$- $v1 $$- $v1 $v2 ',
, 'call out "out " $v1 $v2 ',
, '$$- schluss '
/*
$=/tstCompShell2/
### start tst tstCompShell2 #######################################
compile @, 13 lines: $@do j=0 to 1 $@¢ $$ do j=$j
run without input
do j=0
after if 0 $@¢ $!
after if 0 $=@¢ $!
do j=1
if 1 then $@¢ a
a2
if 1 then $@=¢ b
b2
after if 1 $@¢ $!
after if 1 $=@¢ $!
end
$/tstCompShell2/ */
call tstComp1 '@ tstCompShell2',
, '$@do j=0 to 1 $@¢ $$ do j=$j' ,
, 'if $j then $@¢ ',
, '$$ if $j then $"$@¢" a $$a2' ,
, '$!',
, 'if $j then $@=¢ ',
, '$$ if $j then $"$@=¢" b $$b2' ,
, '$!',
, 'if $j then $@¢ $!' ,
, '$$ after if $j $"$@¢ $!"' ,
, 'if $j then $@=¢ $!' ,
, '$$ after if $j $"$=@¢ $!"' ,
, '$!',
, '$$ end'
return
endProcedure tstCompShell
tstCompPrimary: procedure expose m.
call compIni
/*
$=/tstCompPrimary/
### start tst tstCompPrimary ######################################
compile =, 16 lines: Strings $"$""$""""$""" $'$''$''''$'''
run without input
Strings $"$""$" $'$''$'
rexx $-¢ 3 * 5 $! = 15
rexx $-¢ 5 * 7 $! = 35
rexx $-// 7 * 11 $// = 77
rexx $-/abcEf/ 11 * 13 $/abcEf/ = 143
data line three line four bis hier
shell line five line six bis hier
var get v1 value Eins, v1 value Eins
var isDef v1 1, v2 0
#jIn eof 1#
var read >1 0 rr undefined
#jIn eof 2#
var read >2 0 rr undefined
no call abc$-¢4*5$! $-¢efg$-¢6*7$! abc20 EFG42
brackets $-¢$-¢1+9$!*$-¢7+3$!*$-/b/5+5$/b/$! 1000
run with 3 inputs
Strings $"$""$" $'$''$'
rexx $-¢ 3 * 5 $! = 15
rexx $-¢ 5 * 7 $! = 35
rexx $-// 7 * 11 $// = 77
rexx $-/abcEf/ 11 * 13 $/abcEf/ = 143
data line three line four bis hier
shell line five line six bis hier
var get v1 value Eins, v1 value Eins
var isDef v1 1, v2 0
#jIn 1# eins zwei drei
var read >1 1 rr eins zwei drei
#jIn 2# zehn elf zwoelf?
var read >2 1 rr zehn elf zwoelf?
no call abc$-¢4*5$! $-¢efg$-¢6*7$! abc20 EFG42
brackets $-¢$-¢1+9$!*$-¢7+3$!*$-/b/5+5$/b/$! 1000
$/tstCompPrimary/ */
call vRemove 'v2'
call tstComp1 '= tstCompPrimary 3',
, 'Strings $"$""$""""$"""' "$'$''$''''$'''",
, 'rexx $"$-¢ 3 * 5 $! =" $-¢ 3 * 5 $!' ,
, 'rexx $"$-¢ 5 * 7 $! =" $-¢ 5 * 7 $!' ,
, 'rexx $"$-// 7 * 11 $// =" $-// 7 * 11 $//' ,
, 'rexx $"$-/abcEf/ 11 * 13 $/abcEf/ ="',
'$-/abcEf/ 11 * 13 $/abcEf/' ,
, 'data $-=¢ line three',
, 'line four $! bis hier' ,
, 'shell $-@¢ $$ line five',
, '$$ line six $! bis hier' ,
, '$= v1 = value Eins $=rr=undefined $= eins = 1 ',
, 'var get v1 $v1, v1 ${ v1 } ',
, 'var isDef v1 ${? v${ eins } }, v2 ${?v2 } ',
, 'var read >1 ${> rr} rr $rr' ,
, 'var read >2 ${> rr} rr $rr',
, 'no call $"abc$-¢4*5$! $-¢efg$-¢6*7$!"',
'abc$-¢4*5$! $-¢efg$-¢6*7$!$!',
, 'brackets $"$-¢$-¢1+9$!*$-¢7+3$!*$-/b/5+5$/b/$!"',
'$-¢$-¢1+9$!*$-¢7+3$!*$-/b/5+5$/b/$!'
return
endProcedure tstCompPrimary
tstCompExpr: procedure expose m.
call compIni
/*
$=/tstCompExprStr/
### start tst tstCompExprStr ######################################
compile -, 3 lines: $=vv=vvStr
run without input
vv=vvStr
o2String($.-vv)=vvStr
$/tstCompExprStr/ */
call tstComp1 '- tstCompExprStr',
, '$=vv=vvStr' ,
, '"vv="$vv' ,
, '$"o2String($.-vv)="o2String($.-vv)'
/*
$=/tstCompExprObj/
### start tst tstCompExprObj ######################################
compile ., 5 lines: $=vv=vvStr
run without input
vv=
vvStr
s2o($.vv)=
vvStr
$/tstCompExprObj/ */
call tstComp1 '. tstCompExprObj',
, '$=vv=vvStr' ,
, '"!vv="', '$.-vv',
, '$."s2o($.vv)="', 's2o($-vv)'
/*
$=/tstCompExprDat/
### start tst tstCompExprDat ######################################
compile =, 4 lines: $=vv=vvDat
run without input
vv=vvDat
$.-vv= !vvDat
$.-¢"abc"$!=!abc
$/tstCompExprDat/ */
call tstComp1 '= tstCompExprDat',
, '$=vv=vvDat' ,
, 'vv=$vv',
, '$"$.-vv=" $.-vv',
, '$"$.-¢""abc""$!="$.-¢"abc"$!'
/*
$=/tstCompExprRun/
### start tst tstCompExprRun ######################################
compile @, 3 lines: $=vv=vvRun
run without input
vv=vvRun
o2string($.-vv)=vvRun
$/tstCompExprRun/ */
call tstComp1 '@ tstCompExprRun',
, '$=vv=vvRun' ,
, 'call out "vv="$vv',
, 'call out $"o2string($.-vv)="o2string($.-vv)'
/*
$=/tstCompExprCon/
### start tst tstCompExprCon ######################################
compile #, 2 lines: $$ in # drinnen
run without input
$$ in # drinnen
call out "vv="$vv
$/tstCompExprCon/
$=/tstCompExprCo2/
### start tst tstCompExprCo2 ######################################
compile #, 3 lines: $$ in # drinnen
run without input
$$ in # drinnen
call out "vv="$vv
nacgh $#@
$/tstCompExprCo2/
*/
call tstComp1 '# tstCompExprCon',
, '$$ in # drinnen' ,
, 'call out "vv="$vv'
call tstComp1 '# tstCompExprCo2',
, '$$ in # drinnen' ,
, 'call out "vv="$vv',
, '$#@ $$ nacgh $"$#@"'
return
endProcedure tstCompExpr
tstCompStmt: procedure expose m.
/*
$=/tstCompStmt1/
### start tst tstCompStmt1 ########################################
compile @, 8 lines: $= v1 = value eins $= v2 =- 3*5*7 .
run without input
data v1 value eins v2 105
eins
zwei
drei
vier
fuenf
elf
. zwoelf dreiZ .
. vierZ .
fuenfZ
lang v1 value eins v2 945
oRun ouput 1
$/tstCompStmt1/ */
call pipeIni
call compIni
call vPut 'oRun', oRunner('call out "oRun ouput" (1*1)')
call vRemove 'v2'
call tstComp1 '@ tstCompStmt1',
, '$= v1 = value eins $= v2 =- 3*5*7 ',
, '$$ data v1 $v1 v2 ${ v2 }',
, '$$eins $@¢$$ zwei $$ drei ',
, ' $@¢ $! $@// $// $@/q r s / $/q r s /',
' $@/eins/ $@¢ $$vier $! $/eins/ $! $$fuenf',
, '$$elf $@=¢$@=¢ zwoelf dreiZ $! ',
, ' $@=¢ $! $@=¢ $@=¢ vierZ $! $! $! $$fuenfZ',
, '$$- "lang v1" $v1 "v2" ${v2}*9',
, '$@oRun'
/*
$=/tstCompStmt2/
### start tst tstCompStmt2 ########################################
compile @, 1 lines: $@for qq $$ loop qq $qq
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
loop qq eins zwei drei
#jIn 2# zehn elf zwoelf?
loop qq zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
loop qq zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
$/tstCompStmt2/ */
call tstComp1 '@ tstCompStmt2 3',
, '$@for qq $$ loop qq $qq'
/*
$=/tstCompStmt3/
### start tst tstCompStmt3 ########################################
compile @, 9 lines: $$ 1 begin run 1
2 ct zwei
ct 4 mit assign .
run without input
1 begin run 1
3 run 3 ctV = ct 4 assign ctV|
run 5 procCall $@prCa
out in proc at 8
run 6 vor call $@prCa
out in proc at 8
9 run end
run with 3 inputs
1 begin run 1
3 run 3 ctV = ct 4 assign ctV|
run 5 procCall $@prCa
out in proc at 8
run 6 vor call $@prCa
out in proc at 8
9 run end
$/tstCompStmt3/ */
call tstComp1 '@ tstCompStmt3 3',
, '$$ 1 begin run 1',
, '$@ct $$ 2 ct zwei',
, '$$ 3 run 3 ctV = $ctV|',
, '$@ct $@=¢ct 4 mit assign $=ctV = ct 4 assign ctV $!',
, '$$ run 5 procCall $"$@prCa" $@prCa',
, '$$ run 6 vor call $"$@prCa"',
, '$@prCa',
, '$@proc prCa $$out in proc at 8',
, '$$ 9 run end'
/*
$=/tstCompStmt4/
### start tst tstCompStmt4 ########################################
compile @, 4 lines: $=eins=vorher
run without input
eins vorher
eins aus named block eins .
$/tstCompStmt4/ */
call tstComp1 '@ tstCompStmt4 0',
, '$=eins=vorher' ,
, '$$ eins $eins' ,
, '$=/eins/aus named block eins $/eins/' ,
, '$$ eins $eins'
/*
$=/tstCompStmtDo/
### start tst tstCompStmtDo #######################################
compile @, 2 lines: ti=0$@do y=3 to 4 $@do 2 $@¢
run without input
y=3 ti1 z=7
y=3 ti1 z=8
y=3 ti2 z=7
y=3 ti2 z=8
y=4 ti3 z=7
y=4 ti3 z=8
y=4 ti4 z=7
y=4 ti4 z=8
$/tstCompStmtDo/ */
call tstComp1 '@ tstCompStmtDo', 'ti=0$@do y=3 to 4 $@do 2 $@¢',
, 'ti = ti + 1',
'$@do $*(sdf$*) z $*(sdf$*) =7 to 8 $$ y=$y ti$-¢ti$! z=$z $!'
/*
$=/tstCompStmtDo2/
### start tst tstCompStmtDo2 ######################################
compile @, 7 lines: $$ $-=/sqlSel/
run without input
select 1 abc select 2 abc after table .
$/tstCompStmtDo2/ */
call tstComp1 '@ tstCompStmtDo2',
, '$$ $-=/sqlSel/',
, '$=ty = abc ',
, '$@do tx=1 to 2 $@=/table/',
, 'select $tx $ty',
, '$/table/',
, '$=ty = abc',
, 'after table',
'$/sqlSel/'
/*
$=/tstCompStmtWith/
### start tst tstCompStmtWith #####################################
compile @, 3 lines: $@with $.vA $$ fEins=$FEINS fZwei=$FZWEI va&fEi+
ns=${vA&FEINS}
run without input
fEins=1Eins fZwei=1Zwei va&fEins=1Eins
fEins=1Eins fZwei=1Zwei va&fEins=1Eins
fEins=2Eins fZwei=2Zwei va&fEins=1Eins
fEins=1Eins fZwei=1Zwei va&fEins=1Eins
$/tstCompStmtWith/
*/
cl = classNew('n? tstStmtWith u f FEINS v, f FZWEI v')
v1 = onew(cl)
m.v1.feins = '1Eins'
m.v1.fzwei = '1Zwei'
v2 = oNew(cl)
m.v2.feins ='2Eins'
m.v2.fzwei ='2Zwei'
call vPut 'vA', v1
call vPut 'vB', v2
stmt = '$$ fEins=$FEINS fZwei=$FZWEI va&fEins=${vA&FEINS}'
call tstComp1 '@ tstCompStmtWith',
, '$@with $.vA' stmt ,
, '$@with $vA $@¢' stmt ,
, '$@with $vB ' stmt stmt '$!'
/*
$=/tstCompStmtArg/
### start tst tstCompStmtArg ######################################
compile :, 11 lines: v2 = var2
run without input
a1=eins a2=zwei, a3=elf b1= b2=
after op= v2=var2 var2=zwei,
a1=EINS a2=ZWEI a3= b1=ELF b2=
after op=- v2=var2 var2=ZWEI
a1=EINS a2=ZWEI a3= b1=ELF b2=
after op=. v2=var2 var2=ZWEI
$/tstCompStmtArg/
*/
call tstComp1 ': tstCompStmtArg',
, 'v2 = var2',
, '@% outArg eins zwei, elf',
, '$$ after op= v2=$v2 var2=$var2',
, '@% outArg - eins zwei, elf',
, '$$ after op=- v2=$v2 var2=$var2',
, '@% outArg . eins zwei, elf',
, '$$ after op=. v2=$v2 var2=$var2',
, 'proc $@:/outArg/' ,
, 'arg a1 {$v2} a3, b1 b2',
, '$$ a1=$a1 a2=${$v2} a3=$a3 b1=$b1 b2=$b2' ,
, '$/outArg/'
cl = classNew('n? tstStmtWith u f FEINS v, f FZWEI v')
return
endProcedure tstCompStmt
tstCompProc: procedure expose m.
/*
$=/tstCompProc1/
### start tst tstCompProc1 ########################################
compile =, 11 lines: $$ vor1
run without input
vor1
called p1 eins
vor2
tstR: @ obj null
vor3
. called p3 drei
vor4
. called p2 .
vor9 endof
$/tstCompProc1/ */
call pipeIni
call compIni
call tstComp1 '= tstCompProc1',
, "$$ vor1",
, "$@% p1 eins $$vor2 $@% p2 zwei $$vor3 $@% p3 drei",
, "$$ vor4 $proc p1 $$- 'called p1' arg(2)",
, "$proc p2", " ", "$** a", "$*(b$*) called p2 $-¢arg(2)$!",
, "$proc p3 ", "$** a", " $*(b$*) called p3 $-¢arg(2)$!",
, "$$ vor9 endof"
return
endProcedure tstCompProc
tstCompSyntax: procedure expose m.
call pipeIni
call tstCompSynPrimary
call tstCompSynAss
call tstCompSynRun
return
endProcedure tstCompSyntax
tstCompSynPrimary: procedure expose m.
/*
$=/tstCompSynPri1/
### start tst tstCompSynPri1 ######################################
compile @, 1 lines: a $ =
*** err: scanErr wsh kindExe'@' expected: compile stopped before en+
d of input
. e 1: last token scanPosition $ =
. e 2: pos 3 in line 1: a $ =
$/tstCompSynPri1/ */
call tstComp1 '@ tstCompSynPri1 +', 'a $ ='
/*
$=/tstCompSynPri2/
### start tst tstCompSynPri2 ######################################
compile @, 1 lines: a $. {
*** err: scanErr primary block or expression expected expected
. e 1: last token scanPosition . {
. e 2: pos 4 in line 1: a $. {
*** err: scanErr primary block or expression expected expected
. e 1: last token scanPosition . {
. e 2: pos 4 in line 1: a $. {
*** err: scanErr wsh kindExe'@' expected: compile stopped before en+
d of input
. e 1: last token scanPosition $. {
. e 2: pos 3 in line 1: a $. {
$/tstCompSynPri2/ */
call tstComp1 '@ tstCompSynPri2 +', 'a $. {'
/*
$=/tstCompSynPri3/
### start tst tstCompSynPri3 ######################################
compile @, 1 lines: b $- ¢ .
*** err: scanErr primary block or expression expected expected
. e 1: last token scanPosition - ¢
. e 2: pos 4 in line 1: b $- ¢
*** err: scanErr primary block or expression expected expected
. e 1: last token scanPosition - ¢
. e 2: pos 4 in line 1: b $- ¢
*** err: scanErr wsh kindExe'@' expected: compile stopped before en+
d of input
. e 1: last token scanPosition $- ¢
. e 2: pos 3 in line 1: b $- ¢
$/tstCompSynPri3/ */
call tstComp1 '@ tstCompSynPri3 +', 'b $- ¢ '
/*
$=/tstCompSynPri4/
### start tst tstCompSynPri4 ######################################
compile @, 1 lines: a ${ $*( sdf$*) } =
*** err: scanErr var name expected
. e 1: last token scanPosition } =
. e 2: pos 17 in line 1: a ${ $*( sdf$*) } =
$/tstCompSynPri4/ */
call tstComp1 '@ tstCompSynPri4 +', 'a ${ $*( sdf$*) } ='
/*
$=/tstCompSynFile/
### start tst tstCompSynFile ######################################
compile @, 1 lines: $@.<$*( co1 $*) $$abc
*** err: scanErr primary, block or expression expected
. e 1: last token scanPosition .<$*( co1 $*) $$abc
. e 2: pos 3 in line 1: $@.<$*( co1 $*) $$abc
*** err: scanErr wsh kindExe'@' expected: compile stopped before en+
d of input
. e 1: last token scanPosition $@.<$*( co1 $*) $$abc
. e 2: pos 1 in line 1: $@.<$*( co1 $*) $$abc
$/tstCompSynFile/ */
call tstComp1 '@ tstCompSynFile +', '$@.<$*( co1 $*) $$abc'
return
endProcedure tstCompSynPrimary
tstCompSynAss: procedure expose m.
/*
$=/tstCompSynAss1/
### start tst tstCompSynAss1 ######################################
compile @, 1 lines: $=
*** err: scanErr block or expression in assignment after $= expecte+
d
. e 1: last token scanPosition .
. e 2: pos 3 in line 1: $=
$/tstCompSynAss1/ */
call tstComp1 '@ tstCompSynAss1 +', '$='
/*
$=/tstCompSynAss2/
### start tst tstCompSynAss2 ######################################
compile @, 2 lines: $= .
*** err: scanErr block or expression in assignment after $= expecte+
d
. e 1: last token scanPosition .
. e 2: pos 3 in line 1: $=
$/tstCompSynAss2/ */
call tstComp1 '@ tstCompSynAss2 +', '$= ', 'eins'
/*
$=/tstCompSynAss3/
### start tst tstCompSynAss3 ######################################
compile @, 2 lines: $= $$
*** err: scanErr block or expression in assignment after $= expecte+
d
. e 1: last token scanPosition $$
. e 2: pos 6 in line 1: $= $$
$/tstCompSynAss3/ */
call tstComp1 '@ tstCompSynAss3 +', '$= $$', 'eins'
/*
$=/tstCompSynAss4/
### start tst tstCompSynAss4 ######################################
compile @, 1 lines: $= eins
*** err: scanErr wsh kindExe'@' expected: compile stopped before en+
d of input
. e 1: last token scanPosition $= eins
. e 2: pos 1 in line 1: $= eins
$/tstCompSynAss4/ */
call tstComp1 '@ tstCompSynAss4 +', '$= eins'
/*
$=/tstCompSynAss5/
### start tst tstCompSynAss5 ######################################
compile @, 1 lines: $= abc eins $$ = x
*** err: scanErr wsh kindExe'@' expected: compile stopped before en+
d of input
. e 1: last token scanPosition $= abc eins $$ = x
. e 2: pos 1 in line 1: $= abc eins $$ = x
$/tstCompSynAss5/
$=/tstCompSynAss5old/
### start tst tstCompSynAss5 ######################################
compile @, 1 lines: $= abc eins $$ = x
*** err: scanErr = expected in assignment after $= var
. e 1: last token scanPosition eins $$ = x
. e 2: pos 9 in line 1: $= abc eins $$ = x
$/tstCompSynAss5old/ */
call tstComp1 '@ tstCompSynAss5 +', '$= abc eins $$ = x'
/*
$=/tstCompSynAss6/
### start tst tstCompSynAss6 ######################################
compile @, 1 lines: $= abc =
*** err: scanErr block or expression in assignment after $= expecte+
d
. e 1: last token scanPosition .
. e 2: pos 10 in line 1: $= abc =
$/tstCompSynAss6/ */
call tstComp1 '@ tstCompSynAss6 +', '$= abc ='
/*
$=/tstCompSynAss7/
### start tst tstCompSynAss7 ######################################
compile @, 1 lines: $= abc =..
*** err: scanErr block or expression in assignment after $= expecte+
d
. e 1: last token scanPosition .
. e 2: pos 11 in line 1: $= abc =..
$/tstCompSynAss7/ */
call tstComp1 '@ tstCompSynAss7 +', '$= abc =.'
return
endProcedure tstCompSynAss
tstCompSynRun: procedure expose m.
/*
$=/tstCompSynRun1/
### start tst tstCompSynRun1 ######################################
compile @, 1 lines: $@
*** err: scanErr primary, block or expression expected
. e 1: last token scanPosition .
. e 2: pos 3 in line 1: $@
*** err: scanErr wsh kindExe'@' expected: compile stopped before en+
d of input
. e 1: last token scanPosition $@
. e 2: pos 1 in line 1: $@
$/tstCompSynRun1/ */
call tstComp1 '@ tstCompSynRun1 +', '$@'
/*
$=/tstCompSynRun2/
### start tst tstCompSynRun2 ######################################
compile @, 1 lines: $@=
*** err: scanErr primary, block or expression expected
. e 1: last token scanPosition =
. e 2: pos 3 in line 1: $@=
*** err: scanErr wsh kindExe'@' expected: compile stopped before en+
d of input
. e 1: last token scanPosition $@=
. e 2: pos 1 in line 1: $@=
$/tstCompSynRun2/ */
call tstComp1 '@ tstCompSynRun2 +', '$@='
/*
$=/tstCompSynRun3/
### start tst tstCompSynRun3 ######################################
compile @, 1 lines: $@: und
*** err: scanErr bad kind : in compExpr
. e 1: last token scanPosition und
. e 2: pos 5 in line 1: $@: und
fatal error in wsM: compAst2rx bad ops=!) kind=M.0.KIND ast=0
*** err: bad ast 0
*** err: compAst2rx bad ops=!) kind=M.0.KIND ast=0
$/tstCompSynRun3/ */
call tstComp1 '@ tstCompSynRun3 +', '$@: und'
/*
$=/tstCompSynFor4/
### start tst tstCompSynFor4 ######################################
compile @, 1 lines: $@for
*** err: scanErr var? statement after for expected
. e 1: last token scanPosition .
. e 2: atEnd after line 1: $@for
$/tstCompSynFor4/ */
call tstComp1 '@ tstCompSynFor4 +', '$@for'
/*
$=/tstCompSynFor5/
### start tst tstCompSynFor5 ######################################
compile @, 2 lines: $@for
*** err: scanErr var? statement after for expected
. e 1: last token scanPosition .
. e 2: pos 6 in line 1: $@for
$/tstCompSynFor5/
call tstComp1 '@ tstCompSynFor5 +', '$@for', a
$=/tstCompSynFor6/
### start tst tstCompSynFor6 ######################################
compile @, 2 lines: a
*** err: scanErr variable or named block after for
. e 1: last token scanPosition .
. e 2: pos 15 in line 2: b $@for $$q
$/tstCompSynFor6/
call tstComp1 '@ tstCompSynFor6 +', 'a', ' b $@for $$q'
*/
/*
$=/tstCompSynFor7/
### start tst tstCompSynFor7 ######################################
compile @, 3 lines: a
*** err: scanErr var? statement after for expected
. e 1: last token scanPosition .
. e 2: pos 11 in line 2: b $@for a
$/tstCompSynFor7/
call tstComp1 '@ tstCompSynFor7 +', 'a', ' b $@for a', ' $$q'
$=/tstCompSynCt8/
### start tst tstCompSynCt8 #######################################
compile @, 3 lines: a
*** err: scanErr ct statement expected
. e 1: last token scanPosition .
. e 2: atEnd after line 3: .
$/tstCompSynCt8/ */
call tstComp1 '@ tstCompSynCt8 +', 'a', ' b $@ct', ' '
/*
$=/tstCompSynProc9/
### start tst tstCompSynProc9 #####################################
compile @, 3 lines: a
*** err: scanErr proc statement expected
. e 1: last token scanPosition .
. e 2: atEnd after line 3: $**x
$/tstCompSynProc9/ */
call tstComp1 '@ tstCompSynProc9 +', 'a', ' b $@proc ' , '$**x'
/*
$=/tstCompSynProcA/
### start tst tstCompSynProcA #####################################
compile @, 2 lines: $@proc p1
*** err: scanErr proc statement expected
. e 1: last token scanPosition .
. e 2: pos 10 in line 1: $@proc p1
$/tstCompSynProcA/
call tstComp1 '@ tstCompSynProcA +', '$@proc p1', '$$'
$=/tstCompSynCallB/
### start tst tstCompSynCallB #####################################
compile @, 1 lines: $@% ¢roc p1$!
*** err: scanErr primary, block or expression expected
. e 1: last token scanPosition % ¢roc p1$!
. e 2: pos 3 in line 1: $@% ¢roc p1$!
*** err: scanErr wsh kindExe'@' expected: compile stopped before en+
d of input
. e 1: last token scanPosition $@% ¢roc p1$!
. e 2: pos 1 in line 1: $@% ¢roc p1$!
$/tstCompSynCallB/ */
call tstComp1 '@ tstCompSynCallB +', '$@% ¢roc p1$!'
/*
$=/tstCompSynCallC/
### start tst tstCompSynCallC #####################################
compile @, 1 lines: $@%¢call roc p1 !
*** err: scanErr ending $! expected after ¢
. e 1: last token scanPosition .
. e 2: atEnd after line 1: $@%¢call roc p1 !
$/tstCompSynCallC/ */
call tstComp1 '@ tstCompSynCallC +', '$@%¢call roc p1 !'
/*
$=/tstCompSynCallD/
### start tst tstCompSynCallD #####################################
compile @, 2 lines: $@^¢call( $** roc
*** err: scanErr ending $! expected after ¢
. e 1: last token scanPosition )
. e 2: pos 13 in line 2: $*( p1 $*) )
$/tstCompSynCallD/ */
call tstComp1 '@ tstCompSynCallD +',
,'$@^¢call( $** roc' , ' $*( p1 $*) )'
return
endProcedure tstCompSynRun
tstCompObj: procedure expose m.
call tstReset t
call classIni
cl = classNew('n? tstCompCla u v, f FEINS v, f FZWEI v')
do rx=1 to 10
o = oNew(cl)
m.tstComp.rx = o
m.o = 'o'rx
if rx // 2 = 0 then do
m.o.fEins = 'o'rx'.1'
m.o.fZwei = 'o'rx'.fZwei'rx
end
else do
m.o.fEins = 'o'rx'.fEins'
m.o.fZwei = 'o'rx'.2'
end
call mAdd 'T.TRANS', m.tstComp.rx '<o'rx'>'
end
/*
$=/tstCompObjRef/
### start tst tstCompObjRef #######################################
compile @, 13 lines: o1=m.tstComp.1
run without input
out .$"string" o1
string
out . o1
tstR: @<o1> isA :tstCompCla = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
out .{ o2 }
tstR: @<o2> isA :tstCompCla = o2
tstR: .FEINS = o2.1
tstR: .FZWEI = o2.fZwei2
out .¢ o3 $!
tstR: @<o3> isA :tstCompCla = o3
tstR: .FEINS = o3.fEins
tstR: .FZWEI = o3.2
out .¢ o4 $!
tstR: @<o4> isA :tstCompCla = o4
tstR: .FEINS = o4.1
tstR: .FZWEI = o4.fZwei4
out ./-/ o5 $/-/
tstR: @<o5> isA :tstCompCla = o5
tstR: .FEINS = o5.fEins
tstR: .FZWEI = o5.2
$/tstCompObjRef/ */
m.ttt=1
call tstComp1 '@ tstCompObjRef' ,
, 'o1=m.tstComp.1',
, 'o2 = m.tstComp.2' ,
, '$$ out $".$""string""" o1 $$."string"',
, '$$ out . o1 $$. o1',
, '$$ out .{ o2 } $$.¢ o2 $!',
, '$$ out .¢ o3 $"$!" $$.¢ ', ' m.tstComp.3 ', ' $!',
, '$$ out .¢ o4 $"$!" $$.¢ ', ' m.tstComp.4 ', ' $!',
, '$$ out ./-/ o5 $"$/-/" $$./-/ m.tstComp.5 ', ' $/-/'
/*
$=/tstCompObjRefPri/
### start tst tstCompObjRefPri ####################################
compile @, 9 lines: $$ out .$"$.{o1}" $$.¢ m.tstComp.1 $!
run without input
out .$.{o1}
tstR: @<o1> isA :tstCompCla = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
out .$.-{o2}
<o2>
out .$.={o3}
. m.tstComp.3 .
out .$.@{out o4}
tstWriteO kindOf ORun oRun begin <<<
tstR: @<o4> isA :tstCompCla = o4
tstR: .FEINS = o4.1
tstR: .FZWEI = o4.fZwei4
tstWriteO kindOf ORun oRun end >>>
out .$.@¢$$abc $$efg$!
tstWriteO kindOf ORun oRun begin <<<
abc
efg
tstWriteO kindOf ORun oRun end >>>
out .$.@¢o5$!
tstWriteO kindOf ORun oRun begin <<<
tstR: @<o5> isA :tstCompCla = o5
tstR: .FEINS = o5.fEins
tstR: .FZWEI = o5.2
abc
tstWriteO kindOf ORun oRun end >>>
$/tstCompObjRefPri/ */
call tstComp1 '@ tstCompObjRefPri' ,
, '$$ out .$"$.{o1}" $$.¢ m.tstComp.1 $!',
, '$$ out .$"$.-{o2}" $$.-¢ m.tstComp.2 $!',
, '$$ out .$"$.={o3}" $$.=¢ m.tstComp.3 $!',
, '$$ out .$"$.@{out o4}" $$.@@¢ call out m.tstComp.4 $!',
, '$$ out .$"$.@¢$$abc $$efg$!" $$. $.@@¢ $$abc ', ' ',' $$efg $!',
, '$$ out .$"$.@¢o5$!" $$. $.@@¢ $$. m.tstComp.5', '$$abc $!'
/*
$=/tstCompObjRefFile/
### start tst tstCompObjRefFile ###################################
compile @, 7 lines: $$ out .$".<.¢o1!" $$.<.¢ m.tstComp.1 $!
run without input
out ..<.¢o1!
tstWriteO kindOf JRW jWriteNow begin <<<
tstR: @<o1> isA :tstCompCla = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
tstWriteO kindOf JRW jWriteNow end >>>
out .<$.-{o2}
tstWriteO kindOf JRW jWriteNow begin <<<
tstR: @<o2> isA :tstCompCla = o2
tstR: .FEINS = o2.1
tstR: .FZWEI = o2.fZwei2
tstWriteO kindOf JRW jWriteNow end >>>
out .$.<{o3}
tstWriteO kindOf JRW jWriteNow begin <<<
. m.tstComp.3 .
tstWriteO kindOf JRW jWriteNow end >>>
out .$.<@{out o4}
tstWriteO kindOf JRW jWriteNow begin <<<
tstR: @<o4> isA :tstCompCla = o4
tstR: .FEINS = o4.1
tstR: .FZWEI = o4.fZwei4
tstWriteO kindOf JRW jWriteNow end >>>
out .$<@¢$$abc $$efg$!
tstWriteO kindOf JRW jWriteNow begin <<<
abc
efg
tstWriteO kindOf JRW jWriteNow end >>>
$/tstCompObjRefFile/ */
call tstComp1 '@ tstCompObjRefFile' ,
, '$$ out .$".<.¢o1!" $$.<.¢ m.tstComp.1 $!',
, '$$ out .$"<$.-{o2}" $$<.¢ m.tstComp.2 $!',
, '$$ out .$"$.<{o3}" $$<=¢ m.tstComp.3 $!',
, '$$ out .$"$.<@{out o4}" $$<@¢ call out m.tstComp.4 $!',
, '$$ out .$"$<@¢$$abc $$efg$!" $$<@¢ $$abc ', ' ', ' $$efg $!'
/*
$=/tstCompObjFor/
### start tst tstCompObjFor #######################################
compile @, 2 lines: $@do rx=1 to 3 $$. m.tstComp.rx
run without input
FEINS=o1.fEins FZWEI=o1.2
FEINS=o2.1 FZWEI=o2.fZwei2
FEINS=o3.fEins FZWEI=o3.2
$/tstCompObjFor/
*/
call tstComp1 '@ tstCompObjFor' ,
, '$@do rx=1 to 3 $$. m.tstComp.rx' ,
, '$| $@forWith witx $$ FEINS=$FEINS FZWEI=$FZWEI'
/*
$=/tstCompObjRun/
### start tst tstCompObjRun #######################################
compile @, 4 lines: $$ out .$"$@¢o1!" $$@¢ $$. m.tstComp.1 $!
run without input
out .$@¢o1!
tstWriteO kindOf ORun oRun begin <<<
tstR: @<o1> isA :tstCompCla = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
tstWriteO kindOf ORun oRun end >>>
out .$<@¢$$abc $$efg$!
tstWriteO kindOf JRW jWriteNow begin <<<
abc
efg
tstWriteO kindOf JRW jWriteNow end >>>
$/tstCompObjRun/ */
call tstComp1 '@ tstCompObjRun' ,
, '$$ out .$"$@¢o1!" $$@¢ $$. m.tstComp.1 $!',
, '$$ out .$"$<@¢$$abc $$efg$!" $$<@¢ $$abc ', ' ', ' $$efg $!'
m.t.trans.0 = 0
/*
$=/tstCompObj/
### start tst tstCompObj ##########################################
compile @, 6 lines: o1=m.tstComp.1
run without input
out . o1
tstR: @tstWriteoV1 isA :tstCompCla = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
out .{ o2 }
tstR: @tstWriteoV2 isA :tstCompCla = o2
tstR: .FEINS = o2.1
tstR: .FZWEI = o2.fZwei2
out .¢ o1, o2!
tstR: @tstWriteoV1 isA :tstCompCla = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
tstR: @tstWriteoV2 isA :tstCompCla = o2
tstR: .FEINS = o2.1
tstR: .FZWEI = o2.fZwei2
$/tstCompObj/ */
call tstComp1 '@ tstCompObj' ,
, 'o1=m.tstComp.1',
, 'o2 = m.tstComp.2' ,
, '$$ out . o1 $$. o1',
, '$$ out .{ o2 } $$.¢ o2 $!',
, '$$ out .¢ o1, o2!$; $@.¢ m.tstComp.1 ', ' m.tstComp.2 $!'
return
m.t.trans.0 = 0
endProcedure tstCompObj
tstCompORun: procedure expose m.
/*
$=/tstCompORun/
### start tst tstCompORun #########################################
compile @, 6 lines: $@oRun
run without input
oRun arg=1, v2=, v3=, v4=
oRun arg=1, v2=, v3=, v4=
oRun arg=2, v2=-{1 arg only} oder?, v3=, v4=
oRun arg=2, v2=!.{1 obj only} oder?, v3=, v4=
oRun arg=3, v2={2 args}, v3=und zwei?, v4=
oRun arg=4, v2={3 args}, v3=zwei, v4=und drei?
$/tstCompORun/ */
call compIni
call vPut 'oRun', oRunner('parse arg , v2, v3, v4;',
'call tstOut t, "oRun arg="arg()", v2="v2", v3="v3", v4="v4' )
call tstComp1 '@ tstCompORun',
, '$@oRun', '$@%¢oRun$!' ,
, ' $@%¢oRun $"-{1 arg only}" oder?$!' ,
, ' $@%¢oRun - $.".{1 obj only}" ''oder?''$! $=v2=zwei' ,
, ' $@%¢oRun - $"{2 args}", "und" $v2"?"$!' ,
, ' $@%¢oRun - $"{3 args}", $v2, "und drei?"$!'
return
endProcedure tstCompORun
tstCompORu2: procedure expose m.
/*
$=/tstCompORu2/
### start tst tstCompORu2 #########################################
compile @, 6 lines: $@oRun
run without input
oRun arg=1, v2=, v3=, v4=
oRun arg=1, v2=, v3=, v4=
oRun arg=2, v2=eins, zwei, drei, v3=, v4=
oRun arg=2, v2=eins, zwei, drei, v3=, v4=
oRun arg=4, v2=-eins, v3=zwei, v4=DREI
oRun arg=4, v2=-eins, v3=zwei, v4=DREI
$/tstCompORu2/ */
call compIni
call vPut 'oRun', oRunner('parse arg , v2, v3, v4;',
'call tstOut t, "oRun arg="arg()", v2="v2", v3="v3", v4="v4' )
call tstComp1 '@ tstCompORu2',
, '$@oRun', '$@%oRun',
, '$@% oRun eins, zwei, drei' ,
, '$@%¢ oRun eins, zwei, drei $!',
, '$@% oRun - "-eins", "zwei", drei' ,
, '$@%¢ oRun - "-eins", "zwei", drei $!'
return
endProcedure tstCompORu2
tstCompORuRe: procedure expose m.
/*
$=/tstCompORuRe/
### start tst tstCompORuRe ########################################
compile @, 9 lines: $$ primary $-^oRuRe eins, zwei
run without input
primary oRuRe(arg=1, v2=, v3=) eins, zwei
oRuRe(arg=2, v2=expr, zwei, v3=)
oRuRe(arg=3, v2=-expr, v3=zwei)
oRuRe(arg=2, v2=block, zwei, v3=)
oRuRe(arg=3, v2=-block, v3=zwei)
$/tstCompORuRe/ */
call compIni
call vPut 'oRuRe', oRunner('parse arg , v2, v3;',
'return "oRuRe(arg="arg()", v2="v2", v3="v3")"' )
call tstComp1 '@ tstCompORuRe',
, '$$ primary $-^oRuRe eins, zwei' ,
, '$$-^ oRuRe expr, zwei',
, '$$-^ oRuRe - "-expr", "zwei"',
, '$$-^¢oRuRe block, zwei$!' ,
, '$$-^¢',, 'oRuRe - "-block", "zwei"' , , '$!'
return
endProcedure tstCompORuRe
tstCompDataIO: procedure expose m.
/*
$=/tstCompDataHereData/
### start tst tstCompDataHereData #################################
compile =, 13 lines: herdata $@#/stop/ .
run without input
. herdata .
heredata 1 $x
heredata 2 $y
nach heredata
. herdata ¢ .
heredata 1 xValue
heredata 2 yValueY
nach heredata ¢
. herdata { .
HEREDATA 1 xValue
heredata 2 yValueY
nach heredata {
$/tstCompDataHereData/ */
call tstComp1 '= tstCompDataHereData',
, ' herdata $@#/stop/ ',
, 'heredata 1 $x',
, 'heredata 2 $y',
, '$/stop/ $$ nach heredata',
, ' herdata ¢ $@=/stop/ ',
, '$=x=xValue$=y=yValueY',
, 'heredata 1 $x',
, 'heredata 2 $y',
, '$/stop/ $$ nach heredata ¢',
, ' herdata { $@/st/',
, '; call out heredata 1 $x',
, '$$heredata 2 $y',
, '$/st/ $$ nach heredata {'
/*
$=/tstCompDataIO/
### start tst tstCompDataIO #######################################
compile =, 5 lines: input 1 $@.<-=¢$dsn $*+.
run without input
. input 1 .
readInp line 1 .
readInp line 2 .
. nach dsn input und nochmals mit &
readInp line 1 .
readInp line 2 .
. und schluiss..
$/tstCompDataIO/ */
dsn = word(tstPdsMbr(tstFilename('lib37', 'r'), 'readInp'), 1)
dsnFB = strip(dsn tstFB('::F37', 0))
b = jBuf(tstFB('readInp line 1', 37),
,tstFB('readInp line 2', 37))
extFd = tstFB('&dsn('dsn') dd(xyz)', 0)
extFd = tstFB(dsn 'dd(xyz) ::f', 0)
if extFd = '' then
extFd = dsn
call jCat file(dsnFB), b
call vPut 'dsn', dsn
say 'dsn' dsn 'extFD' extFD'?'
call tstComp1 '= tstCompDataIO',
, ' input 1 $@.<-=¢$dsn $*+',
, tstFB('::f', 0) '$!',
, ' nach dsn input und nochmals mit & ' ,
, ' $@.<'extFD,
, ' und schluiss.'
return
endProcedure tstCompDataIO
tstObjVF: procedure expose m.
parse arg v, f
obj = oNew(classNew('n? TstClassVF u v, f FLD1 v'))
m.obj = if(f=='','val='v, v)
m.obj.fld1 = if(f=='','FLD1='v, f)
return obj
endProcedure tstObjVF
tstCompFile: procedure expose m.
/*
$=/tstCompFileBloSrc/
$=vv=value-of-vv
###file from empty # block
$@<#¢
$!
###file from 1 line # block
$@<#¢
the only $ix+1/0 line $vv
$!
###file from 2 line # block
$@<#¢
first line /0 $*+ no comment
second and last line $$ $wie
$!
===file from empty = block
$@<=¢ $*+ comment
$!
===file from 1 line = block
$@<=¢ the only line $!
===file from 2 line = block
$@<=¢ first line$** comment
second and last line $!
---file from empty - block
$@<-/s/
$/s/
---file from 1 line - block
$@<-/s/ the only "line" (1*1) $/s/
---file from 2 line = block
$@<-// first "line" (1+0)
second and "last line" (1+1) $//
...file from empty . block
$@<.¢
$!
...file from 1 line . block
$@<.¢ tstObjVF('v-Eins', '1-Eins') $!
...file from 2 line . block
$@<.¢ tstObjVF('v-Elf', '1-Elf')
tstObjVF('zwoelf') $!
...file from 3 line . block
$@<.¢ tstObjVF('einUndDreissig')
s2o('zweiUndDreissig' o2String($.-vv))
tstObjVF('dreiUndDreissig') $!
@@@file from empty @ block
$@<@¢
$!
$=noOutput=before
@@@file from nooutput @ block
$@<@¢ nop
$=noOutput = run in block $!
@@@nach noOutput=$noOutput
@@@file from 1 line @ block
$@<@¢ $$. tstObjVF('w-Eins', 'w1-Eins') $!
@@@file from 2 line @ block
$@<@¢ $$. tstObjVF('w-Elf', 'w1-Elf')
y='zwoelf' $$- y $!
@@@file from 3 line @ block
$@<@¢ $$. tstObjVF('w einUndDreissig') $$ +
zweiUndDreissig $$ 33 $vv$!
{{{ empty ¢ block
$@<¢ $!
{{{ empty ¢ block with comment
$@<¢ $*+ abc
$!
{{{ one line ¢ block
$@<¢ the only $"¢...$!" line $*+.
$vv $!
{{{ one line -¢ block
$@<-¢ the only $"-¢...$!" "line" $vv $!
{{{ empty #¢ block
$@<#¢
$!
{{{ one line #¢ block
$@<#¢ the only $"-¢...$!" "line" $vv $¢vv${x}$!
$!
$/tstCompFileBloSrc/ */
/*
$=/tstCompFileBlo/
### start tst tstCompFileBlo ######################################
compile =, 72 lines: $=vv=value-of-vv
run without input
###file from empty # block
###file from 1 line # block
the only $ix+1/0 line $vv
###file from 2 line # block
first line /0 $*+ no comment
second and last line $$ $wie
===file from empty = block
===file from 1 line = block
. the only line .
===file from 2 line = block
. first line
second and last line .
---file from empty - block
---file from 1 line - block
THE ONLY line 1
---file from 2 line = block
FIRST line 1
SECOND AND last line 2
...file from empty . block
...file from 1 line . block
tstR: @tstWriteoV1 isA :TstClassVF = v-Eins
tstR: .FLD1 = 1-Eins
...file from 2 line . block
tstR: @tstWriteoV2 isA :TstClassVF = v-Elf
tstR: .FLD1 = 1-Elf
tstR: @tstWriteoV3 isA :TstClassVF = val=zwoelf
tstR: .FLD1 = FLD1=zwoelf
...file from 3 line . block
tstR: @tstWriteoV4 isA :TstClassVF = val=einUndDreissig
tstR: .FLD1 = FLD1=einUndDreissig
zweiUndDreissig value-of-vv
tstR: @tstWriteoV5 isA :TstClassVF = val=dreiUndDreissig
tstR: .FLD1 = FLD1=dreiUndDreissig
@@@file from empty @ block
@@@file from nooutput @ block
@@@nach noOutput=run in block
@@@file from 1 line @ block
tstR: @tstWriteoV6 isA :TstClassVF = w-Eins
tstR: .FLD1 = w1-Eins
@@@file from 2 line @ block
tstR: @tstWriteoV7 isA :TstClassVF = w-Elf
tstR: .FLD1 = w1-Elf
zwoelf
@@@file from 3 line @ block
tstR: @tstWriteoV8 isA :TstClassVF = val=w einUndDreissig
tstR: .FLD1 = FLD1=w einUndDreissig
zweiUndDreissig
33 value-of-vv
{{{ empty ¢ block
{{{ empty ¢ block with comment
{{{ one line ¢ block
. the only ¢...$! line value-of-vv .
{{{ one line -¢ block
THE ONLY -¢...$! line value-of-vv
{{{ empty #¢ block
{{{ one line #¢ block
. the only $"-¢...$!" "line" $vv $¢vv${x}$!
$/tstCompFileBlo/ */
call tstComp2 'tstCompFileBlo', '='
m.t.trans.0 = 0
/*
$=/tstCompFileObjSrc/
$=vv=value-vv-1
$=fE=<¢ $!
$=f2=. $.<.¢s2o("f2 line 1" o2String($.-vv))
tstObjVF("f2 line2") $!
---empty file $"$@<$fE"
$@fE
---file with 2 lines $"$@<$f2"
$@.<.f2
$=vv=value-vv-2
---file with 2 lines $"$@<$f2"
$@.<.f2
$= dsn =- word(tstPdsMbr(tstFilename('libvb', 'r'), 'fileObj'),1) +
tstFB('::V', 0)
$@¢
fi=jOpen(file($dsn),'>')
call jWrite fi, 'line one on' $"$dsn"
call jWrite fi, 'line two on' $"$dsn"
call jClose fi
$!
---file on disk out
$@<-dsn
$/tstCompFileObjSrc/ */
/*
$=/tstCompFileObj/
### start tst tstCompFileObj ######################################
compile =, 20 lines: $=vv=value-vv-1
run without input
---empty file $@<$fE
---file with 2 lines $@<$f2
f2 line 1 value-vv-1
tstR: @tstWriteoV1 isA :TstClassVF = val=f2 line2
tstR: .FLD1 = FLD1=f2 line2
---file with 2 lines $@<$f2
f2 line 1 value-vv-1
tstR: @tstWriteoV1 isA :TstClassVF = val=f2 line2
tstR: .FLD1 = FLD1=f2 line2
---file on disk out
line one on $dsn
line two on $dsn
$/tstCompFileObj/ */
call tstComp2 'tstCompFileObj', '='
return
endProcedure tstCompFile
tstCompPipe: procedure expose m.
/*
$=/tstCompPipe1/
### start tst tstCompPipe1 ########################################
compile @, 1 lines: call pipePreSuf "(1 ", " 1)"
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
(1 eins zwei drei 1)
#jIn 2# zehn elf zwoelf?
(1 zehn elf zwoelf? 1)
#jIn 3# zwanzig 21 22 23 24 ... 29|
(1 zwanzig 21 22 23 24 ... 29| 1)
#jIn eof 4#
$/tstCompPipe1/ */
call tstComp1 '@ tstCompPipe1 3',
, ' call pipePreSuf "(1 ", " 1)"'
/*
$=/tstCompPipe2/
### start tst tstCompPipe2 ########################################
compile @, 2 lines: call pipePreSuf "(1 ", " 1)"
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
#jIn 2# zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
¢2 (1 eins zwei drei 1) 2!
¢2 (1 zehn elf zwoelf? 1) 2!
¢2 (1 zwanzig 21 22 23 24 ... 29| 1) 2!
$/tstCompPipe2/ */
call tstComp1 '@ tstCompPipe2 3',
, ' call pipePreSuf "(1 ", " 1)"' ,
, ' $| call pipePreSuf "¢2 ", " 2!"'
/*
$=/tstCompPipe3/
### start tst tstCompPipe3 ########################################
compile @, 3 lines: call pipePreSuf "(1 ", " 1)"
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
#jIn 2# zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
<3 ¢2 (1 eins zwei drei 1) 2! 3>
<3 ¢2 (1 zehn elf zwoelf? 1) 2! 3>
<3 ¢2 (1 zwanzig 21 22 23 24 ... 29| 1) 2! 3>
$/tstCompPipe3/ */
call tstComp1 '@ tstCompPipe3 3',
, ' call pipePreSuf "(1 ", " 1)"' ,
, ' $| call pipePreSuf "¢2 ", " 2!"',
, ' $| call pipePreSuf "<3 ", " 3>"'
/*
$=/tstCompPipe4/
### start tst tstCompPipe4 ########################################
compile @, 7 lines: call pipePreSuf "(1 ", " 1)"
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
#jIn 2# zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
<3 ¢222 ¢221 ¢21 ¢20 (1 eins zwei drei 1) 20! 21! 221! 222! 3>
<3 ¢222 ¢221 ¢21 ¢20 (1 zehn elf zwoelf? 1) 20! 21! 221! 222! 3>
<3 ¢222 ¢221 ¢21 ¢20 (1 zwanzig 21 22 23 24 ... 29| 1) 20! 21! 221!+
. 222! 3>
$/tstCompPipe4/ */
call tstComp1 '@ tstCompPipe4 3',
, ' call pipePreSuf "(1 ", " 1)"' ,
, ' $| $@¢ call pipePreSuf "¢20 ", " 20!"',
, ' $| call pipePreSuf "¢21 ", " 21!"',
, ' $| $@¢ call pipePreSuf "¢221 ", " 221!"',
, ' $| call pipePreSuf "¢222 ", " 222!"',
, '$! $! ',
, ' $| call pipePreSuf "<3 ", " 3>"'
return
endProcedure tstCompPipe
tstCompPip2: procedure expose m.
/*
$=/tstCompPip21/
### start tst tstCompPip21 ########################################
compile @, 3 lines: $<¢ zeile eins .
run without input
(1 zeile eins 1)
(1 zeile zwei 1)
run with 3 inputs
(1 zeile eins 1)
(1 zeile zwei 1)
$/tstCompPip21/ */
call tstComp1 '@ tstCompPip21 3',
, ' $<¢ zeile eins ' ,
, ' zeile zwei $!' ,
, ' call pipePreSuf "(1 ", " 1)"'
/*
$=/tstCompPip22/
### start tst tstCompPip22 ########################################
compile @, 3 lines: if ${>i1} then $@¢
run without input
#jIn eof 1#
nachher
run with 3 inputs
#jIn 1# eins zwei drei
<zeile 1: eins zwei drei>
<zwei>
nachher
$/tstCompPip22/ */
call tstComp1 '@ tstCompPip22 3',
, 'if ${>i1} then $@¢' ,
, ' $$ zeile 1: $i1 $$ zwei $| call pipePreSuf "<",">" $!',
, ' $$ nachher '
return
endProcedure tstCompPip2
tstCompRedir: procedure expose m.
/*
$=/tstCompRedir/
### start tst tstCompRedir ########################################
compile @, 6 lines: $=eins=<@¢ $@for vv $$ <$vv> $! .
run without input
#jIn eof 1#
output eins .
output piped zwei .
run with 3 inputs
#jIn 1# eins zwei drei
#jIn 2# zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
output eins <eins zwei drei> <zehn elf zwoelf?> +
<zwanzig 21 22 23 24 ... 29|>
output piped zwei ab<eins zwei drei>yz ab<zehn elf zwoelf?>yz a+
b<zwanzig 21 22 23 24 ... 29|>yz
$/tstCompRedir/ */
call pipeIni
call vRemove 'eins' /* alte Variable loswerden */
dsn = word(tstPdsMbr(tstFilename('libvb', 'r'), 'redir1'), 1)
call vPut 'dsn', dsn
say 'dsn' $dsn
call tstComp1 '@ tstCompRedir 3' ,
, ' $=eins=<@¢ $@for vv $$ <$vv> $! ',
, ' $$ output eins $-=¢$@.eins$! $; ',
, ' $@for ww $$b${ww}y ' ,
, ' $>-= $-¢ $dsn $! 'tstFB('::v', 0),
, '$| call pipePreSuf "a", "z" $<.eins' ,
, ' $; $$ output piped zwei $-=¢$@<$-dsn$!'
/*
$=/tstCompRedi2/
### start tst tstCompRedi2 ########################################
compile @, 12 lines: call mAdd t.trans, $var "dsnTestRedi"
run without input
>1<dsnTestRedi currTimeRedi
>2<$"dsnTestRedi" currTimeRedi
>3<$"dsnTestRedi" ::v currTimeRedi
>4<$-var" currTimeRedi
>5<$dsnTestRedi" currTimeRedi
$/tstCompRedi2/
*/
call vPut 'var', tstFileName('compRedi', 'r')
call vPut 'tst', translate(date()'+'time()'+testRedi2', '_', ' ')
call tstComp1 '@ tstCompRedi2 ' ,
, 'call mAdd t.trans, $var "dsnTestRedi"',
, 'call mAdd t.trans, $tst "currTimeRedi"',
, '$<> $>'vGet('var') '::v $$ $">1<'vGet('var')'" $tst',
, '$<> $<'vGet('var') ' $@ call pipeWriteAll' ,
, '$<> $>$"'vGet('var')' ::v" $$ $">2<$""'vGet('var')'""" $tst',
, '$<> $<$"'vGet('var') '" $@ call pipeWriteAll',
, '$<> $>$"'vGet('var')'" ::v $$ $">3<$""'vGet('var')'"" ::v" $tst',
, '$<> $<$"'vGet('var') '" $@ call pipeWriteAll',
, '$<> $>-var $$ $">4<$"-var" $tst',
, '$<> $<-var $@ call pipeWriteAll',
, '$<> $>$var ::v $$ $">5<$"$var" $tst',
, '$<> $<$var $@ call pipeWriteAll'
return
endProcedure tstCompRedir
tstCompComp: procedure expose m.
/*
$=/tstCompCompShell/
### start tst tstCompCompShell ####################################
compile @, 5 lines: $$compiling shell $; $= rrr =. $.^compile $<@#/+
aaa/
run without input
compiling shell
running einmal
RUN 1 COMPILED einmal
#jIn eof 1#
running zweimal
RUN 1 COMPILED zweimal
#jIn eof 2#
run with 3 inputs
compiling shell
running einmal
RUN 1 COMPILED einmal
#jIn 1# eins zwei drei
compRun eins zwei dreieinmal
#jIn 2# zehn elf zwoelf?
compRun zehn elf zwoelf?einmal
#jIn 3# zwanzig 21 22 23 24 ... 29|
compRun zwanzig 21 22 23 24 ... 29|einmal
#jIn eof 4#
running zweimal
RUN 1 COMPILED zweimal
#jIn eof 5#
$/tstCompCompShell/ */
call tstComp1 '@ tstCompCompShell 3',
, "$$compiling shell $; $= rrr =. $.^compile $<@#/aaa/",
, "call out run 1*1*1 compiled $cc;" ,
"$@for v $$ compRun $v$cc" ,
, "$/aaa/ $;",
, "$=cc=einmal $$ running $cc $@rrr",
, "$=cc=zweimal $$ running $cc $@rrr"
/*
$=/tstCompCompData/
### start tst tstCompCompData #####################################
compile @, 5 lines: $$compiling data $; $= rrr =. $.^¢compile = +
=$! $<@#/aaa/
run without input
compiling data
running einmal
call out run 1*1*1 compiled einmal
running zweimal
call out run 1*1*1 compiled zweimal
run with 3 inputs
compiling data
running einmal
call out run 1*1*1 compiled einmal
running zweimal
call out run 1*1*1 compiled zweimal
$/tstCompCompData/ */
call tstComp1 '@ tstCompCompData 3',
, "$$compiling data $; $= rrr =. $.^¢compile = =$! $<@#/aaa/",
, "call out run 1*1*1 compiled $cc",
, "$/aaa/ $;",
, "$=cc=einmal $$ running $cc $@rrr",
, "$=cc=zweimal $$ running $cc $@rrr"
return
endProcedure tstCompComp
tstCompDir: procedure expose m.
/*
$=/tstCompDirSrc/
'in src v1='$v1
$#@ call out 'src @ out v1='$v1
$#. $*(komm$*) s2o('src . v1=')
$.-v1
$#-
'src - v1='$v1
$#=
src = v1=$v1
$/tstCompDirSrc/
$=/tstCompDir/
### start tst tstCompDir ##########################################
compile @call out 'before v1='$v1 $=v1=eins $#. s2o('. v1='$-v1) $#+
@ call out '@ v1='$v1 $#= = v1=$v1 $#- '- v1='$v1 $#-, 8 lines: 'in+
. src v1='$v1
run without input
before v1=v1Before
.. v1=eins
@ v1=eins
= v1=eins .
- v1=eins
in src v1=eins
src @ out v1=eins
src . v1=
eins
src - v1=eins
src = v1=eins
$/tstCompDir/ */
call compIni
call vPut 'v1', 'v1Before'
call tstComp2 'tstCompDir', "@call out 'before v1='$v1 $=v1=eins" ,
"$#. s2o('. v1='$-v1) $#@ call out '@ v1='$v1" ,
"$#= = v1=$v1 $#- '- v1='$v1 $#-"
/*
$=/tstCompDirPiSrc/
zeile 1 v1=$v1
zweite Zeile vor $"$@$#-"
$#@ $@proc pi2 $@-¢
$'zeile drei nach $@$#- v1='v1
vierte und letzte Zeile $!
$/tstCompDirPiSrc/ */
/*
$=/tstCompDirPi/
### start tst tstCompDirPi ########################################
compile @call pipePreSuf '<','>' $=v1=eiPi $<.pi2 $#=, 5 lines: ze+
ile 1 v1=$v1
run without input
<zeile drei nach $@$#- v1=V1>
<VIERTE UND LETZTE ZEILE>
zeile 1 v1=eiPi
zweite Zeile vor $@$#-
$/tstCompDirPi/ */
call tstComp2 'tstCompDirPi',
, "@call pipePreSuf '<','>' $=v1=eiPi $<.pi2 $#="
return
endProcedure tstCompDir
tstCompColon: procedure expose m.
/*
$=/tstCompColon1/
### start tst tstCompColon1 #######################################
compile :, 12 lines: vA = valueVonA
run without input
vA = valueVonA
vA=valueVonA vB=valueVonB vC=valueVonC
vC=valueVonC vD=valueVonD vE=valueVonvE
vF=6
$/tstCompColon1/ */
call tstComp1 ': tstCompColon1',
, 'vA = valueVonA' ,
, ' $$ vA = $vA' ,
, ' * kommentar ' ,
, '=vB=- "valueVonB"' ,
, '=/vC/valueVonC$/vC/' ,
, ' $$ vA=$vA vB=$vB vC=$vC' ,
, '$=/vD/valueVonD' ,
, '$/vD/ vE=valueVonvE' ,
, ' * kommentar ' ,
, ' $$ vC=$vC vD=$vD vE=$vE',
, 'vF=- 2*3 $=vG=@@¢ $$ vF=$vF$!' ,
, '@vG'
/*
$=/tstCompColon2/
### start tst tstCompColon2 #######################################
compile :, 7 lines: ix=0
run without input
#jIn eof 1#
proc p1 arg(2) total 0 im argumentchen
run with 3 inputs
#jIn 1# eins zwei drei
#jIn 2# zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
<<for 1 -> eins zwei drei>>
<<for 2 -> zehn elf zwoelf?>>
<<for 3 -> zwanzig 21 22 23 24 ... 29|>>
proc p1 arg(2) total 3 im argumentchen
$/tstCompColon2/
*/
call tstComp1 ': tstCompColon2 3',
, 'ix=0' ,
, 'for v @:¢ix=- $ix+1',
, ' $$ for $ix -> $v' ,
, '! | @¢call pipePreSuf "<<",">>"',
, '$! @%¢p1 total $ix im argumentchen$!',
, 'proc @:/p1/$$- "proc p1 arg(2)" arg(2)' ,
, '/p1/'
/*
$=/tstCompColon3/
### start tst tstCompColon3 #######################################
compile :, 11 lines: tc3Eins=freeVar1
run without input
tc3Eins=freeVar1 o2&tc3Eins= o2&tc3Zwei=
tc3Eins=freeVar1 o2&tc3Eins=with3Eins o2&tc3Zwei=with3Zwei
tc3Eins=freeVar1 o2&tc3Eins=ass4Eins o2&tc3Zwei=with5Zwei
o3&tc3Eins=ass4Eins o3&tc3Zwei=with5 o3 Zwei
tc3Eins=freeVar1 o2&tc3Eins=ass4Eins o2&tc3Zwei=with5Zwei
$/tstCompColon3/
*/
call classNew 'n? TstCompColon3 u f tc3Eins v, f tc3Zwei v'
showO2 = 'tc3Eins=$tc3Eins' ,
'o2&tc3Eins=${o2&tc3Eins} o2&tc3Zwei=${o2&tc3Zwei}'
showO3 = 'o3&tc3Eins=${o3&tc3Eins} o3&tc3Zwei=${o3&tc3Zwei}'
call tstComp1 ': tstCompColon3',
, 'tc3Eins=freeVar1' ,
, 'o2 =. oNew("TstCompColon3")' ,
, '$$' showO2 ,
, 'with $o2 $@:¢tc3Eins = with3Eins',
, 'tc3Zwei = with3Zwei',
, '! $$' showO2 ,
, '{o2&tc3Eins} = ass4Eins',
, 'with $o2 $=tc3Zwei = with5Zwei',
, '$$' showO2 ,
, 'with o3 =. oCopy($o2) $=tc3Zwei = with5 o3 Zwei',
, '$$' showO3 '$$' showO2
return
endProcedure tstCompColon
tstCompWithNew: procedure expose m.
/*
$=/tstCompWithNew/
### start tst tstCompWithNew ######################################
compile :, 12 lines: withNew $@:¢
run without input
tstR: @tstWriteoV2 isA :<TstCT1Class>
tstR: .fEins = withNewValue fEins
tstR: .fZwei = withNewValue fZwei
tstR: .fDrei = withNewValuel drei
tstR: @tstWriteoV3 isA :<TstCT1Class>
tstR: .fEins = withNewValue fEinsB
tstR: .fZwei = withNewValue fZweiB
tstR: .fDrei = withNewValue fDreiB
tstR: @tstWriteoV5 isA :<TstCT2Class>
tstR: .fEins = withValue fEinsC
tstR: .fDrei = withValue fDreiC
$/tstCompWithNew/
*/
call wshIni
cl = classNew('n* CompTable u f fEins v, f fZwei v, f fDrei v')
c2 = classNew('n* CompTable u f fEins v, f fDrei v')
call tstComp1 ': tstCompWithNew',
, 'withNew $@:¢' ,
, 'fEins = withNewValue fEins' ,
, 'fZwei = withNewValue fZwei' ,
, '$@¢call mAdd t.trans, className("'cl'") "<TstCT1Class>"',
, '$@:¢ fDrei = withNewValuel drei $! $! ' ,
, '$! withNew $@:¢' ,
, 'fEins = withNewValue fEinsB' ,
, 'fZwei = withNewValue fZweiB',
, 'fDrei = withNewValue fDreiB',
, '$! withNew $@:¢ fEins = withValue fEinsC' ,
, '$@¢call mAdd t.trans, className("'c2'") "<TstCT2Class>"',
, '$@¢$=fDrei = withValue fDreiC$! $! $! '
/*
$=/tstCompWithNeRe/
### start tst tstCompWithNeRe #####################################
compile :, 11 lines: withNew $@:¢
run without input
tstR: @tstWriteoV2 isA :<TstClassR2>
tstR: .rA = value rA
tstR: .rB refTo @!value rB isA :w
tstR: @tstWriteoV4 isA :<TstClassR2>
tstR: .rA = val33 rA
tstR: .rB refTo @!VAL33 RB isA :w
tstR: @tstWriteoV5 isA :<TstClassR2>
tstR: .rA = val22 rA
tstR: .rB refTo @!VAL22 RB isA :w
tstR: @tstWriteoV6 isA :<TstCT1Class>
tstR: .fEins = withNewValue fEins
tstR: .fZwei = withNewValue fZwei
tstR: .fDrei = withNewValuel drei
vOth=value vOth fZwei=fZwei Wert vorher ?fDrei=0
$/tstCompWithNeRe/
*/
cR = classNew("n* CompTable u f rA v, f rB r")
call vRemove 'fDrei'
call vPut 'fZwei', 'fZwei Wert vorher'
call tstComp1 ': tstCompWithNeRe',
, 'withNew $@:¢' ,
, 'fEins = withNewValue fEins' ,
, '@:¢withNew $@:¢rA=value rA $=rB=. "!value rB" ' ,
, '$@ call mAdd t.trans, className("'cR'") "<TstClassR2>"$!$!',
, 'fZwei = withNewValue fZwei' ,
, '$@¢call mAdd t.trans, className("'cl'") "<TstCT1Class>"',
, '$@:¢withNew $@:¢ rA =val22 rA $=rB=. !val22 rB ' ,
, '{vOth} = value vOth',
, '$@:¢withNew @:¢rA =val33 rA $=rB=. !val33 rB $! $! $! $!' ,
, '$@:¢ fDrei = withNewValuel drei $! $! $!',
, '$<> $$ vOth=$vOth fZwei=$fZwei ?fDrei=${?fDrei}'
return
endProcedure tstCompWithNew
tstCompSql: procedure expose m.
/*
$=/tstCompSqlSrc/
$@=¢
select strip(creator) cr, strip(name) tb,
(row_number()over())*(row_number()over()) rr
from sysibm.sysTables
where creator='SYSIBM' and name like 'SYSTABL%'
order by 2 fetch first 4 rows only
$!
$| call sqlSel
$| call fTabAuto
$/tstCompSqlSrc/
$=/tstCompSql/
### start tst tstCompSql ##########################################
compile @, 9 lines: $@=¢
run without input
CR TB RR
SYSIBM SYSTABLEPART 1
SYSIBM SYSTABLEPART_HIST 4
SYSIBM SYSTABLES 9
SYSIBM SYSTABLESPACE 16
$/tstCompSql/
$=/tstCompSqlFTabSrc/
$$ select 'ahaaaax' ahaCol, 'buuuuh' buhhhh from sysibm.sysDummy1
$| call sql2tab , , sqlFTabOpts(fTabReset(tstCompS1, '1', '1', '-'))
$<>
$= s1 = select 'aOh' ahaOhne, 'buuVar' buhVar from sysibm.sysDummy1
call sqlQuery 7, $s1
t2 = sqlFTabOpts(fTabReset(tstCompS2, '2 1', '2 c', '-'))
ox = m.t2.0 + 1
call sqlFTabOthers t2, 7
call sqlFTab fTabSetTit(t2, ox, 2, '-----'), 7
$<>
$$ select 'aOh' aDrei, 'buuDre' buhDrei from sysibm.sysDummy1
$| call sql2Tab
$/tstCompSqlFTabSrc/
$=/tstCompSqlFTab/
### start tst tstCompSqlFTab ######################################
compile @, 12 lines: $$ select 'ahaaaax' ahaCol, 'buuuuh' buhhhh fr+
om sysibm.sysDummy1
run without input
AHACOL--BUHHHH---
ahaaaax buuuuh
AHACOL--BUHHHH---
-----
AHA-BUHVAR---
aOh buuVar
-----
AHAOHNE
. BUHVAR
ADREI
. BUHDREI
ADR-BUHDRE---
aOh buuDre
ADR-BUHDRE---
ADREI
. BUHDREI
$/tstCompSqlFTab/
*/
call sqlConnect , 's'
call tstComp2 'tstCompSql', '@'
call tstComp2 'tstCompSqlFTab', '@'
call sqlDisConnect
return
endProcedure tstCompSql
/* ?????rework tstTut ?????????????????*/
tstTut0: procedure expose m.
/*
$=/tstTut01Src/
$#=
$*+>.fSub() Kommentar
$*+>~tmp.jcl(t) Kommentar
$*+@=¢ Kommentar
$=subsys=DP4G
$=db=DA540769
$=ts=A977A
$*+@<~wk.jcl(jc) Kommentar
??* ?-¢sysvar(sysnode) date() time()?!ts=$ts 10*len=$-¢length($ts)*10$!
//P02 EXEC PGM=DSNUTILB,
// PARM='$subsys,A540769C.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=$subsys.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE $db.$ts* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
$@¢if right($ts, 2) == '7A' then $@=¢
FULL YES
$! else
$$ $'' FULL NO
$!
SHRLEVEL CHANGE
$*+! Kommentar
$#out original/src
$/tstTut01Src/
$=/tstTut01/
### start tst tstTut01 ############################################
compile , 28 lines: $#=
run without input
??* ?-¢sysvar(sysnode) date() time()?!ts=A977A 10*len=50
//P02 EXEC PGM=DSNUTILB,
// PARM='DP4G,A540769C.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DA540769.A977A* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
FULL YES
SHRLEVEL CHANGE
$/tstTut01/
$=/tstTut02Src/
$#@
$**>.fSub()
$**@¢
$=subsys=DP4G
$=db=DA540769
$=jx=0
$@do tx = 976 to 977 $@=¢
$=ts=A$tx
$=jx=- $jx+1
//A540769$jx JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//C$ts EXEC PGM=DSNUTILB,
// PARM='$subsys,A540769$jx.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=$subsys.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE $db.$ts* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$!
$**!
$#out original/src
$/tstTut02Src/
$=/tstTut02/
### start tst tstTut02 ############################################
compile , 28 lines: $#@
run without input
//A5407691 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA976 EXEC PGM=DSNUTILB,
// PARM='DP4G,A5407691.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DA540769.A976* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
//A5407692 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA977 EXEC PGM=DSNUTILB,
// PARM='DP4G,A5407692.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DA540769.A977* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$/tstTut02/
$=/tstTut03Src/
$#@
$=subsys=DP4G
$<>
$<#¢
db ts
DGDB9998 A976
DA540769 A977
$!
$@. csvColRdr()
$** $| call fTabAuto
$** $#end
$|
$=jx=0
$@forWith o $@=¢
$=jx=- $jx+1
//A540769$jx JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//C$ts EXEC PGM=DSNUTILB,
// PARM='$subsys,A540769$jx.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=$subsys.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE $db.$ts* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$!
$#out original/src
$/tstTut03Src/
$=/tstTut03/
### start tst tstTut03 ############################################
compile , 33 lines: $#@
run without input
//A5407691 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA976 EXEC PGM=DSNUTILB,
// PARM='DP4G,A5407691.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DGDB9998.A976* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
//A5407692 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA977 EXEC PGM=DSNUTILB,
// PARM='DP4G,A5407692.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DA540769.A977* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$/tstTut03/
$=/tstTut04Src/
$#@
$=subsys=DP4G
$=db=DA540769
call sqlConnect $subsys
$@=¢ select dbName db , tsName ts
from sysibm.sysTables
where creator = 'SYSIBM' and name like 'SYSINDEXPAR%'
order by name desc
$!
$| call sqlSel
$** $| call fTabAuto
$** $#end
$|
$=jx=0
$@forWith o $@=¢
$=jx=- $jx+1
//A540769$jx JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//C$TS EXEC PGM=DSNUTILB,
// PARM='$subsys,A540769$jx.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=$subsys.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE $DB.$TS* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$!
call sqlDisConnect
$#out original/src
$/tstTut04Src/
$=/tstTut04/
### start tst tstTut04 ############################################
compile , 35 lines: $#@
run without input
//A5407691 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CSYSHIST EXEC PGM=DSNUTILB,
// PARM='DP4G,A5407691.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DSNDB06 .SYSHIST * PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
//A5407692 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CSYSTSIPT EXEC PGM=DSNUTILB,
// PARM='DP4G,A5407692.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DSNDB06 .SYSTSIPT* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$/tstTut04/
$=/tstTut05Src/
$#:
subsys = DP4G
lst =<:¢withNew out :¢
db = DGDB9998
ts =<:¢table
ts
A976
A977
$!
db = DA540769
<|/ts/
ts
A976
A975
/ts/
!
$** $$. $lst
$** $@ct $@¢$=tool =. $.compile@ $<~.wk.rexx(wshtut06)$!
$** $@$tool
$@do sx=1 to ${lst.0} $@¢
$=db = ${lst.$sx.db}
$** $$. ${lst.$sx}
$@do tx=1 to ${lst.$sx.ts.0} $@=¢
$*+ $$. ${lst.$sx.ts.$tx}
$=ts= ${lst.$sx.ts.$tx.ts}
$@¢ say $-=¢subsys $subsys db $db ts $ts $! $!
$@copy()
$!
$!
$@ct $@¢
cl = classNew('n? DbTsList u s' ,
classNew('n? DbTs u f db v, f ts s' ,
classNew('n? Ts u f ts v')))
$=lst=. oNew(cl)
$!
$@proc copy $@=¢
$@ct $=jx=0
$=jx=- $jx+1
//A540769$jx JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//C$ts EXEC PGM=DSNUTILB,
// PARM='$subsys,A540769$jx.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=$subsys.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE $db.$ts* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$!
$#out original/src
$/tstTut05Src/
$=/tstTut05/
### start tst tstTut05 ############################################
compile , 56 lines: $#@
run without input
//A5407691 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA976 EXEC PGM=DSNUTILB,
// PARM='DP4G,A5407691.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DGDB9998.A976* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
//A5407692 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA977 EXEC PGM=DSNUTILB,
// PARM='DP4G,A5407692.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DGDB9998.A977* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
//A5407693 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA976 EXEC PGM=DSNUTILB,
// PARM='DP4G,A5407693.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DA540769.A976* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
//A5407694 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA975 EXEC PGM=DSNUTILB,
// PARM='DP4G,A5407694.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DA540769.A975* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$/tstTut05/
tstTut06 ==> platz für copy aus tut05
$=/tstTut07Src/
$**$>.fEdit()
call sqlConnect dp4g
$@:¢table
ts
VTCASHFLOW
VTCASHFLOWAMOUNT
VTINSTRFLATDATA
$!
$| $@=¢
select name, statstime, strip(dbName) || '.' || strip(tsName) dbts
from sysibm.sysTables
where creator = 'VDPS2' and name in
$=co=(
$@forWith t $@=¢
$co '$ts'
$=co=,
$!
)
$!
$| call sqlSel
$** $| call fTabAuto
$|
$=jx=0
$@forWith t $@=¢
$=jx=- $jx+1
//A540769$jx JOB (CP00,KE50),
// 'CATALOG',MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//STEP$jx EXEC PGM=DSNUTILB,TIME=1440,
// PARM=(DP4G,'A540769$jx.RUNSTA'),
// REGION=0M
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSOUT DD SYSOUT=*
//RNPRIN01 DD SYSOUT=*
//SYSIN DD *
LISTDEF LST#STA INCLUDE TABLESPACE $DBTS
OPTIONS EVENT (ITEMERROR, SKIP)
RUNSTATS TABLESPACE LIST LST#STA
SHRLEVEL CHANGE
INDEX(ALL KEYCARD)
REPORT YES UPDATE ALL
$!
call sqlDisconnect
$#out original/src
$/tstTut07Src/
$=/tstTut07/
$=/tstTut07/
### start tst tstTut07 ############################################
compile , 47 lines: $**$>.fEdit()
run without input
//A5407691 JOB (CP00,KE50),
// 'CATALOG',MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//STEP1 EXEC PGM=DSNUTILB,TIME=1440,
// PARM=(DP4G,'A5407691.RUNSTA'),
// REGION=0M
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSOUT DD SYSOUT=*
//RNPRIN01 DD SYSOUT=*
//SYSIN DD *
LISTDEF LST#STA INCLUDE TABLESPACE VV27A1T.VDPS329
OPTIONS EVENT (ITEMERROR, SKIP)
..
RUNSTATS TABLESPACE LIST LST#STA
SHRLEVEL CHANGE
INDEX(ALL KEYCARD)
REPORT YES UPDATE ALL
//A5407692 JOB (CP00,KE50),
// 'CATALOG',MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//STEP2 EXEC PGM=DSNUTILB,TIME=1440,
// PARM=(DP4G,'A5407692.RUNSTA'),
// REGION=0M
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSOUT DD SYSOUT=*
//RNPRIN01 DD SYSOUT=*
//SYSIN DD *
LISTDEF LST#STA INCLUDE TABLESPACE VV28A1T.VDPS390
OPTIONS EVENT (ITEMERROR, SKIP)
..
RUNSTATS TABLESPACE LIST LST#STA
SHRLEVEL CHANGE
INDEX(ALL KEYCARD)
REPORT YES UPDATE ALL
//A5407693 JOB (CP00,KE50),
// 'CATALOG',MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//STEP3 EXEC PGM=DSNUTILB,TIME=1440,
// PARM=(DP4G,'A5407693.RUNSTA'),
// REGION=0M
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSOUT DD SYSOUT=*
//RNPRIN01 DD SYSOUT=*
//SYSIN DD *
LISTDEF LST#STA INCLUDE TABLESPACE VV21A1T.VDPS004
OPTIONS EVENT (ITEMERROR, SKIP)
..
RUNSTATS TABLESPACE LIST LST#STA
SHRLEVEL CHANGE
INDEX(ALL KEYCARD)
REPORT YES UPDATE ALL
$/tstTut07/
$=/tstTut08Src/
$/tstTut08Src/
$=/tstTut08/
$/tstTut08/
*/
call sqlIni
call sqlDisconnect '*'
call tstComp2 'tstTut01'
call tstComp2 'tstTut02'
call tstComp2 'tstTut03'
if m.err_os == 'TSO' then do
call tstComp2 'tstTut04'
/* call tstComp2 'tstTut05' */
/* call tstComp2 'tstTut07' ???? anderes Beispiel ???? */
end
call tstTotal
return
endProcedure tstTut0
/****** tstBase *******************************************************
test the basic classes
**********************************************************************/
tstBase: procedure expose m.
call tstTstSay
call tstM
call tstUtc2d
call tstMap
call tstMapVia
call classIni
call tstClass
call tstClass2
call tstClass3
call tstClass4
call tstO
call tstOStr
call tstOEins
call tstO2Text
call tstF
call tstFWords
call tstFtst
call tstFCat
call jIni
call tstJSay
call tstJ
call tstJ2
call tstScanSqlStmt
call catIni
call tstCat
call pipeIni
CALL TstEnv
CALL TstEnvCat
call tstPipe
call tstPipeS
call tstEnvVars
call tstvWith
call tstTotal
call tstPipeLazy
call tstEnvClass
call tstDsn
call tstDsn2
if m.tst_csmRZ \== '' then
call tstDsnEx
call tstFile
call tstFileList
call tstMbrList
call tstFE
call tstFTab
call tstFmt
call tstFUnit
call tstfUnit2
call tstCsv
call tstCsv2
call tstCsvExt
call tstCsvInt
call tstCsvV2F
call tstTotal
call tstSb
call tstSb2
call tstScan
call ScanReadIni
call tstScanRead
call tstScanUtilInto
call tstScanWin
call tstScanSQL
call tstTotal
return
endProcedure tstBase
/*--- test the tst Module, check the output visually ---------------*/
tstTstSay: procedure expose m.
call tstIni
oldErr = m.tst.err
oldNames = m.tst.errNames
say '+++ tstTstSay start with' oldErr 'totErrs and',
m.tst.tests 'tests'
/*
$=/tstTstSayEins/
### start tst tstTstSayEins #######################################
test eins einzige testZeile
$/tstTstSayEins/
$=/tstTstSayZwei/
### start tst tstTstSayZwei #######################################
zwei 1. testZeile
zwei 2. und letzte testZeile
$/tstTstSayZwei/
$=/tstTstSayDrei/
### start tst tstTstSayDrei #######################################
drei 1. testZeile vor empty Zeile
..
drei 3. testZeile vor 10 space
. .
drei 5. testZeile ziemlich lang 66 +
. 77 5 10 15++++++++++++++++++++
.+++++++++++++++++++++++++++++++++++++++++++.
$/tstTstSayDrei/
*/
call tst x, 'tstTstSayEins'
call tstOut x, "test eins einzige testZeile"
call tstEnd x, 'err 0'
call tst x, 'tstTstSayZwei'
call tstOut x, "zwei 1. testZeile"
call tstOut x, "zwei 2. und letzte testZeile"
call tstEnd x, 'err 0'
call tst x, 'tstTstSayZwei'
call tstOut x, "zwei 1. testZeile " /* ein space zuviel */
call tstOut x, "zwei 2. und letzte testZeile"
call tstOut x, "zwei 3. zuviel"
call tstEnd x, 'err 3'
call tst y, 'tstTstSayDrei'
call tstOut y, 'drei 1. testZeile vor empty Zeile'
call tstOut y, ''
call tstOut y, 'drei 3. testZeile vor 10 space'
call tstOut y, left('', 10)
call tstOut y, 'drei 5. testZeile ziemlich lang',
left(66, 66) left('77 5 10 15', 77, '+')
call tstEnd y, 'err 0'
if m.y.err <> 0 then
call err '+++ tstTstSay errs' m.x.err 'expected' 0
if m.tst.err <> oldErr + 3 then
call err '+++ tstTstSay totErrs' m.tst.err 'expected' 3
say '+++ tstTstSay end Ok with' m.tst.err 'totErrs and' ,
m.tst.tests 'tests'
m.tst.err = oldErr
m.tst.errNames = oldNames
return
endProcedure tstTstSay
tstMark: procedure expose m.
parse arg m, msg
if symbol('m.m') == 'VAR' then
m.m = msg';' m.m
else
m.m = msg 'new'
return m
endProcedure tstMark
tstM: procedure expose m.
/*
$=/tstMa/
### start tst tstMa ###############################################
mNew() 1=newM1 2=newM2
mNew(tst...) 2=2 new 3=4; 3; 1 new 4=5 new
iter 4; 3; 1 new
iter 2 new
iter 5 new
$/tstMa/
*/
call tst t, 'tstMa'
m1 = mNew()
m2 = mNew()
m.m1 = 'newM1'
m.m2 = 'newM2'
call tstOut t, 'mNew() 1='m.m1 '2='m.m2
call mNewArea 'tst'm1
t1 = tstMark(mNew('tst'm1), '1')
t2 = tstMark(mNew('tst'm1), '2')
call mFree tstMark(t1, '3')
t3 = tstMark(mNew('tst'm1), '4')
t4 = tstMark(mNew('tst'm1), '5')
call tstOut t, 'mNew(tst...) 2='m.t2 '3='m.t3 '4='m.t4
i = mIterBegin('tst'm1)
do forever
i = mIter(i)
if i == '' then
leave
call tstOut t, 'iter' m.i
end
call tstEnd t
/*
$=/tstM/
### start tst tstM ################################################
symbol m.b LIT
symbol m.a LIT
mAdd a A.2
mAdd a A.3
m.a: 3: 1=eins 2=zwei 3=drei 4=M.A.4
m.c: 5: 1=c vorAddSt a 2=eins 3=zwei 4=drei 5=c nacAddSt a 6=M.C.6
$/tstM/ */
drop m.b m.a m.a.0 m.a.1 m.a.2
call tst t, 'tstM'
call tstOut t, 'symbol m.b' symbol('m.b')
m.b = 1
call tstOut t, 'symbol m.a' symbol('m.a')
call tstOut t, 'mAdd a' mAdd(mCut(a, 0), 'eins', 'zwei')
call tstOut t, 'mAdd a' mAdd(a, 'drei')
call tstOut t,'m.a:' m.a.0': 1='m.a.1 '2='m.a.2 '3='m.a.3 '4='m.a.4
call mAdd mCut(c, 0), 'c vorAddSt a'
call mAddSt c, a
call mAdd c, 'c nacAddSt a'
call tstOut t, 'm.c:' m.c.0': 1='m.c.1 '2='m.c.2 '3='m.c.3,
'4='m.c.4 '5='m.c.5 '6='m.c.6
call tstEnd t
return
endProcedure tstM
tstFCat: procedure expose m.
/*
$=/tstFCat/
### start tst tstFCat #############################################
fCat( ,0) =;
fCat(1 ,0) =;
fCat(112222 ,0) =;
fCat(3#a1%c2 ,0) =;
fCat(4#a1%c2@%c333 ,0) =;
fCat(5#a1%c2@%c3@%c4 ,0) =;
fCat( ,1) =eins;
fCat(1 ,1) =eins;
fCat(112222 ,1) =eins;
fCat(3#a1%c2 ,1) =1eins2;
fCat(4#a1%c2@%c333 ,1) =1eins2eins333;
fCat(5#a1%c2@%c3@%c4 ,1) =1eins2eins3eins4;
fCat( ,2) =einszwei;
fCat(1 ,2) =eins1zwei;
fCat(112222 ,2) =eins112222zwei;
fCat(3#a1%c2 ,2) =1eins231zwei2;
fCat(4#a1%c2@%c333 ,2) =1eins2eins33341zwei2zwei333;
fCat(5#a1%c2@%c3@%c4 ,2) =1eins2eins3eins451zwei2zwei3zwei4;
fCat( ,3) =einszweidrei;
fCat(1 ,3) =eins1zwei1drei;
fCat(112222 ,3) =eins112222zwei112222drei;
fCat(3#a1%c2 ,3) =1eins231zwei231drei2;
fCat(4#a1%c2@%c333 ,3) =1eins2eins33341zwei2zwei33341drei2dr+
ei333;
fCat(5#a1%c2@%c3@%c4 ,3) =1eins2eins3eins451zwei2zwei3zwei451d+
rei2drei3drei4;
$/tstFCat/ */
call pipeIni
call tst t, "tstFCat"
m.qq.1 = "eins"
m.qq.2 = "zwei"
m.qq.3 = "drei"
do qx = 0 to 3
m.qq.0 = qx
call tstFCat1 qx
call tstFCat1 qx, '1'
call tstFCat1 qx, '112222'
call tstFCat1 qx, '3#a1%c2'
call tstFCat1 qx, '4#a1%c2@%c333'
call tstFCat1 qx, '5#a1%c2@%c3@%c4'
end
call tstEnd t
return
endProcedure tstFCat
tstFCat1: procedure expose m.
parse arg m.qq.0, fmt
call out left("fCat("fmt, 26)","m.qq.0") ="fCat(fmt, qq)";"
return
endProcedure tstFCat1
tstMap: procedure expose m.
/*
$=/tstMap/
### start tst tstMap ##############################################
mapNew m keys m-keys 0
map m zwei --> 2
map m Zwei is not defined
map stem m-keys 4
map m eins --> 1
map m zwei --> 2
map m drei --> 3
map m vier --> 4
*** err: duplicate in mapAdd(m, eins, 1)
map m zwei is not defined
q 2 zw dr
map stem Q 2
map Q zw --> 2Q
map Q dr --> 3Q
map stem m 3
map m eins --> 1
map m zwei --> 2PUT
map m vier --> 4PUT
*** err: duplicate in mapAdd(m, zwei, 2ADDDUP)
tstMapLong eins keys 3
tstMapLong zweiMal keys 48
tstMapLong dreiMal keys 93
tstMapLong vier keys 138
tstMapLong <fuenf> keys 188
tstMap clear keys 0
inline1 3
inline1 1 == inline1 eins==
inline1 2 ====
inline1 3 == inline1 drei==
inline2 1 1 == inline2 eins==
inline3 ?
$/tstMap/ */
/*
$=/tstMapInline1/
inline1 eins
inline1 drei
$/tstMapInline1/ */
/*
$=/tstMapInline2/
inline2 eins
$/tstMapInline2/ */
call tst t, 'tstMap'
m = mapNew('K')
ky = mapKeys(m)
call mAdd t'.TRANS', m 'm', ky 'm-keys'
call tstOut t, 'mapNew' m 'keys' ky m.ky.0
call mapAdd m, 'eins', 1
call mapAdd m, 'zwei', 2
call mapAdd m, 'drei', 3
call mapAdd m, 'vier', 4
call tstMapShow m, 'zwei'
call tstMapShow m, 'Zwei'
call tstMapShowSt m, mapKeys(m)
call mapAdd m, 'eins', 1
call mapReset m, '='
call tstMapShow m, 'zwei'
call mapAdd m, 'eins', 1
call mapAdd m, 'zwei', 2
call mapPut m, 'zwei', 2Put
call mapPut m, 'vier', 4Put
call mapReset q, '='
call mapAdd q, 'zw', 2q
call mapAdd q, 'dr', 3q
call tstOut t, 'q' m.q.0 m.q.1 m.q.2
call tstMapShowSt q, mapKeys(q)
call tstMapShowSt m, mapKeys(m)
call mapAdd m, 'zwei', 2addDup
call tstMapLong m, 'eins' ,201, 2000, -2, 2
call tstMapLong m, 'zweiMal' ,201, 2000, -2, 2
call tstMapLong m, 'dreiMal' ,201, 2000, 2,-2
call tstMapLong m, 'vier ' ,2010, 201, -2, 2
call tstMapLong m, '<fuenf>' ,2010, 201, 2,-2
call mapClear m
keys = mapKeys(m)
call tstOut t, 'tstMap clear keys' m.keys.0
i = mapInline('tstMapInline1')
call tstOut t, 'inline1' m.i.0
do x=1 to m.i.0
call tstOut t, 'inline1' x '=='m.i.x'=='
end
i = mapInline('tstMapInline2')
call tstOut t, 'inline2' m.i.0 '1 =='m.i.1'=='
call tstOut t, 'inline3' mapInline('tstMapInline3', 'r')'?'
call tstEnd t
return
endProcedure tstMap
tstMapLong: procedure expose m.
parse arg m, w, f1, t1, f2, t2
if f1 < t1 then
b1 = 201
else
b1 = -201
if f2 < t2 then
b2 = 1
else
b2 = -1
lo = copies(w, 2100 % length(w))
keys = mapKeys(m)
keyCn = m.keys.0
call tstOut t, 'tstMapLong' w 'keys' keyCn
do x = f1 by b1 to t1
do y = x+f2 by b2 to x+t2
k = left(lo, y)
if mapHasKey(m, k) then
call err 'mapLong hasKey before' w y
call mapAdd m, k, w y
if \ mapHasKey(m, k) then
call err 'mapLong \ hasKey after' w y
if mapGet(m, k) \== w y then
call err 'mapLong \ get <> ' w y
keys = mapKeys(m)
if keyCn + 1 \= m.keys.0 then
call err 'mapLong keys .0 <> ' w y
keyCn = m.keys.0
if k \== m.keys.keyCn then
call err 'mapLong keys . ' keyCn '<>' w y
end
end
return
endProcedure tstMapLong
tstMapVia: procedure expose m.
/*
$=/tstMapVia/
### start tst tstMapVia ###########################################
map M K --> A
mapVia(m, K) A
*** err: missing m.A at 3 in mapVia(M, K|)
mapVia(m, K|) M.A
mapVia(m, K|) valAt m.a
mapVia(m, K|) valAt m.a
*** err: missing m.A.aB at 5 in mapVia(M, K|aB)
mapVia(m, K|aB) M.A.aB
mapVia(m, K|aB) valAt m.A.aB
*** err: missing m.valAt m.a at 4 in mapVia(M, K||)
mapVia(m, K||) M.valAt m.a
mapVia(m, K||) valAt m.valAt m.a
mapVia(m, K||F) valAt m.valAt m.a.F
$/tstMapVia/ */
call tst t, 'tstMapVia'
u = 'A.aB'
v = 'valAt m.a'
drop m.a m.u m.v m.v.f
call mapReset m, 'K'
call mapAdd m, k, a
call tstMapShow m, k
call tstOut t, 'mapVia(m, K) ' mapVia(m, 'K')
call tstOut t, 'mapVia(m, K|) ' mapVia(m, 'K|')
m.a = v
call tstOut t, 'mapVia(m, K|) ' mapVia(m, 'K|')
call tstOut t, 'mapVia(m, K|) ' mapVia(m, 'K|')
call tstOut t, 'mapVia(m, K|aB) ' mapVia(m, 'K|aB')
m.u = 'valAt m.'u
call tstOut t, 'mapVia(m, K|aB) ' mapVia(m, 'K|aB')
call tstOut t, 'mapVia(m, K||) ' mapVia(m, 'K||')
v = m.a
m.v = 'valAt m.'v
m.v.f = 'valAt m.'v'.F'
call tstOut t, 'mapVia(m, K||) ' mapVia(m, 'K||')
call tstOut t, 'mapVia(m, K||F) ' mapVia(m, 'K||F')
call tstEnd t
return
endProcedure tstMapVia
tstMapShow: procedure expose m.
parse arg a, key
if mapHasKey(a, key) then
call tstOut t, 'map' a key '-->' mapGet(a, key)
else
call tstOut t, 'map' a key 'is not defined'
return
endProcedure tstMapShow
tstMapShowSt: procedure expose m.
parse arg a, st
call tstOut t, 'map stem' st m.st.0
do wx=1 to m.st.0
call tstMapShow a, m.st.wx
end
return
endProcedure tstMapShow
tstClass2: procedure expose m.
/*
$=/tstClass2/
### start tst tstClass2 ###########################################
@CLASS.8 :class = u
. choice u union
. .NAME = class
. stem 8
. .1 refTo @CLASS.3 :class = u
. choice u union
. .NAME = v
. stem 2
. .1 refTo @CLASS.1 :class = m
. choice m union
. .NAME = asString
. .MET = return m.m
. stem 0
. .2 refTo @CLASS.2 :class = m
. choice m union
. .NAME = o2File
. .MET = return file(m.m)
. stem 0
. .2 refTo @CLASS.11 :class = c
. choice c union
. .NAME = u
. stem 1
. .1 refTo @CLASS.10 :class = u
. choice u union
. .NAME = .
. stem 1
. .1 refTo @CLASS.9 :class = f
. choice f union
. .NAME = NAME
. stem 1
. .1 refTo @CLASS.3 done :class @CLASS.3
. .3 refTo @CLASS.12 :class = c
. choice c union
. .NAME = f
. stem 1
. .1 refTo @CLASS.10 done :class @CLASS.10
. .4 refTo @CLASS.14 :class = c
. choice c union
. .NAME = s
. stem 1
. .1 refTo @CLASS.13 :class = u
. choice u union
. .NAME = .
. stem 0
. .5 refTo @CLASS.15 :class = c
. choice c union
. .NAME = c
. stem 1
. .1 refTo @CLASS.10 done :class @CLASS.10
. .6 refTo @CLASS.16 :class = c
. choice c union
. .NAME = r
. stem 1
. .1 refTo @CLASS.13 done :class @CLASS.13
. .7 refTo @CLASS.19 :class = c
. choice c union
. .NAME = m
. stem 1
. .1 refTo @CLASS.18 :class = u
. choice u union
. .NAME = .
. stem 2
. .1 refTo @CLASS.9 done :class @CLASS.9
. .2 refTo @CLASS.17 :class = f
. choice f union
. .NAME = MET
. stem 1
. .1 refTo @CLASS.3 done :class @CLASS.3
. .8 refTo @CLASS.21 :class = s
. choice s union
. stem 1
. .1 refTo @CLASS.20 :class = r
. choice r union
. stem 1
. .1 refTo @CLASS.8 done :class @CLASS.8
$/tstClass2/
*/
call classIni
call tst t, 'tstClass2'
call classOut m.class_C, m.class_C
call tstEnd t
return
endProcedure tstClass2
tstClass3: procedure expose m.
/*
$=/tstClass3/
### start tst tstClass3 ###########################################
met v#o2String return m.m
met w#o2String return substr(m, 2)
met w#o2String return substr(m, 2)
*** err: no method nonono in class w
met w#nonono 0
t1 4 fldD .FV, .FR
clear q1 FV= FR= FW= FO=
orig R1 FV=valFV FR=refFR FW=!valFW FO=obj.FO
copy <s1> FV=valFV FR=refFR FW=!valFW FO=obj.FO
t2 2 fldD .EINS.ZWEI, .
clear q2 EINS.ZWEI= val=
orig R2 EINS.ZWEI=valR2.eins.zwei val=valR2Self
copy <s2> EINS.ZWEI=valR2.eins.zwei val=valR2Self
t3 0 fldD M.<class tst...Tf33>.FLDD.1, M.<class tst...Tf33>.FLDD.2
clear q3 s1.0=0
orig R3 s1.0=1 s1.1=M.R3.S1.1 s1.1.f1=M.R3.S1.1.F1 s1.1.s2.0=2 s1.1+
..s2.1.f2=M.R3.S1.1.S2.1.F2 s1.1.s2.2.f2=M.R3.S1.1.S2.2.F2
copy <s3> s1.0=1 s1.1=M.R3.S1.1 s1.1.f1=M.R3.S1.1.F1 s1.1.s2.0=2 s1+
..1.s2.1.f2=M.R3.S1.1.S2.1.F2 s1.1.s2.2.f2=M.R3.S1.1.S2.2.F2
$/tstClass3/ */
call classIni
call tst t, 'tstClass3'
call mAdd t.trans, m.class_C '<class class>'
call tstOut t, 'met v#o2String' classMet(m.class_V, 'o2String')
call tstOut t, 'met w#o2String' classMet(m.class_W, 'o2String')
call tstOut t, 'met w#o2String' classMet(m.class_W, 'o2String')
call tstOut t, 'met w#nonono' classMet(m.class_W, 'nonono')
all = classNew('n? tstClassTf31 u f FV v, f FR r, f FW w,f FO o'),
classNew('n? tstClassTf32 u f EINS f ZWEI v, v') ,
classNew('n? tstClassTf33 u f S1' classNew('s u v, f F1 v,',
'f S2 s f F2 v'))
call mAdd t.trans, word(all, 3) '<class tst...Tf33>'
m.r1.fv = 'valFV'
m.r1.fr = 'refFR'
m.r1.fw = '!valFW'
m.r1.fo = 'obj.FO'
m.r2 = 'valR2Self'
m.r2.eins.zwei = 'valR2.eins.zwei'
m.r3.s1.0 = 1
m.r3.s1.1.s2.0 = 2
o.1 = "q 'FV='m.q.FV 'FR='m.q.fr 'FW='m.q.fw 'FO='m.q.fo"
o.2 = "q 'EINS.ZWEI='m.q.EINS.zwei 'val='m.q"
o.3 = "q 's1.0='m.q.s1.0"
p.1 = o.1
p.2 = o.2
p.3 = "q 's1.0='m.q.s1.0 's1.1='m.q.s1.1 's1.1.f1='m.q.s1.1.f1" ,
"'s1.1.s2.0='m.q.s1.1.s2.0 's1.1.s2.1.f2='m.q.s1.1.s2.1.f2",
"'s1.1.s2.2.f2='m.q.s1.1.s2.2.f2"
do tx=1 to words(all)
t1 = word(all, tx)
u1 = classFldD(t1)
q = 'q'tx
call tstOut t, 't'tx m.u1.0 'fldD' m.u1.1',' m.u1.2
call utInter("m='"q"';" classMet(t1, 'oClear'))
interpret "call tstOut t, 'clear'" o.tx
q = 'R'tx
interpret "call tstOut t, 'orig'" p.tx
q = utInter("m='"q"';t='';" classMet(t1, 'oCopy'))
call mAdd t.trans, q '<s'tx'>'
interpret "call tstOut t, 'copy'" p.tx
end
call tstEnd t
return
endProcedure tstClass3
tstClass: procedure expose m.
/*
$=/tstClass/
### start tst tstClass ############################################
Q u =className= tstClassTf12
Q.eins.zwei v ==> M.Q.eins.zwei
*** err: bad type v: classNew(v tstClassTf12)
R u =className= uststClassTf12
R u =className= uststClassTf12in
R u =className= tstClassTf12
R.eins.zwei v ==> M.R.eins.zwei
R s =stem.0= 2
R.1 r ==> M.R.1 :CLASS.7
R.1 u =className= tstClassTf12
R.1.eins.zwei v ==> M.R.1.eins.zwei
R.2 r ==> M.R.2 :CLASS.7
R.2 u =className= tstClassTf12
R.2.eins.zwei v ==> M.R.2.eins.zwei
S u =className= TstClass7
S s =stem.0= 2
S.1 u =className= TstClass7s
S.1.eins v ==> M.S.1.eins
S.1 m =met-metA--> say "metA"
S.1 m =met-metB--> say "metB"
S.2 u =className= TstClass7s
S.2.zwei v ==> M.S.2.zwei
S.2 m =met-metA--> say "metA"
S.2 m =met-metB--> say "metB"
class of mutate qq tstClassTf12
$/tstClass/ */
f = 'eins.zwei'
e = 'eins'
z = 'zwei'
drop m.q.f m.r.f m.r.0 m.r.1 m.r.1.f m.r.2 m.r.2.f
drop m.s.0 m.s.1 m.s.1.e m.s.2 m.s.2.z
call classIni
call tst t, 'tstClass'
t1 = classNew('n? tstClassTf12 u f eins f zwei v')
call tstClassOut t, t1, q
z = m.class.0
if class4name('tstClassB', '') == '' then
t2 = classNew('n tstClassB u n tstClassC u tstClassTf12,',
's u v tstClassTf12')
else /* the second time we would get a duplicate error */
call tstOut t, '*** err: bad type v: classNew(v tstClassTf12)'
t2 = classNew('n? uststClassTf12 u' ,
'n? uststClassTf12in u tstClassTf12',
, classNew('s u r, tstClassTf12'))
m.r.0 = 2
call tstClassOut t, t2, r
t3 = classNew('n? TstClass7 u s',
classNew('n? TstClass7s u c 1 f eins v, c 2 f zwei v',
,'m', 'metA say "metA"', 'metB say "metB"'))
m.s.0 = 2
m.s.1 = 1
m.s.2 = 2
call tstClassOut t, t3, s
call oMutatName qq, 'tstClassTf12'
tt = objClass(qq)
call tstOut t, 'class of mutate qq' className(tt)
call tstEnd t
return
endProcedure tstClass
tstClassOut: procedure expose m.
parse arg o, t, a
if wordPos(t, m.class_V m.class_W m.class_O) > 0 then
return tstOut(o, a m.t.name '==>' m.a)
if m.t == 'r' then
return tstOut(o, a m.t '==>' m.a ':'if(m.t.0==0,'',m.t.1))
if m.t == 'u' & m.t.name \== '' then
call tstOut o, a m.t '=className=' m.t.name
if m.t == 'f' then
return tstClassOut(o, m.t.1, a'.'m.t.name)
if m.t = 'u' then do
do ux=1 to m.t.0
call tstClassOut o, m.t.ux, a
end
return 0
end
if m.t = 's' then do
call tstOut o, a m.t '=stem.0=' m.a.0
do ux=1 to m.a.0
call tstClassOut o, m.t.1, a'.'ux
end
return 0
end
if m.t = 'c' then do
if m.t.name = m.a then
call tstClassOut o, m.t.1, a
return 0
end
if m.t = 'm' then
return tstOut(o, a m.t '=met-'m.t.name'-->' m.t.met)
call err 'bad class type' m.t
endProcedure tstClassOut
tstClass4: procedure expose m.
parse arg
/*
$=/tstClass4/
### start tst tstClass4 ###########################################
f 1 eins
f 2 zwei
f 3 drei
f 4 vier
f 5 acht
s 1 fuenf
s 2 sechs
s 3 sie
$/tstClass4/
*/
call classIni
call tst t, 'tstClass4'
x = classNew('n* TstClass4a u f eins v, f%v zwei drei, f vier v',
', f%s-v fuenf sechs sie, f acht v')
ff = classFlds(x)
do fx=1 to m.ff.0
call tstOut t, 'f' fx m.ff.fx
end
st = classMet(x, 'stms')
do sx=1 to m.st.0
call tstOut t, 's' sx m.st.sx
end
call tstEnd t
return
endProcedure tstClass4
tstO: procedure expose m.
/*
$=/tstO/
### start tst tstO ################################################
o1.class <class_S>
o1.class <class T..1>
o1#met1 metEins
o1#met2 metZwei
o1#new m = mNew('<class T..1>'); call oMutate m, '<class T..1>'; ca+
ll classClear '<class T..1>', m;
$/tstO/
*/
call classIni
call tst t, 'tstO'
call mAdd t.trans, m.class_s '<class_S>'
c1 = classNew('n? TstOCla1 u', 'm', 'met1 metEins', 'met2 metZwei')
call mAdd t.trans, c1 '<class T..1>'
o1 = 'tst_o1'
call tstOut t, 'o1.class' objClass(o1)
o1 = oMutate('o1', c1)
call tstOut t, 'o1.class' objClass(o1)
call tstOut t, 'o1#met1' objMet(o1, 'met1')
call tstOut t, 'o1#met2' objMet(o1, 'met2')
call tstOut t, 'o1#new' objMet(o1, 'new')
call tstEnd t
return
endProcedure tstO
tstOEins: procedure expose m.
/*
$=/tstOEins/
### start tst tstOEins ############################################
class method calls of TstOEins
. met Eins.eins M
flds of <obj e of TstOEins> FEINS, FZWEI
methodcalls of object e of TstOEins
. met Eins.eins <obj e of TstOEins>
. met Eins.zwei <obj e2 of TstOEins>
*** err: no method nein in class TstOEins
*** err: no method nein in class String
class method calls of TstOEins
. met Elf.zwei M
flds of <obj f of TstOElf> FEINS, FZWEI, FELF
methodcalls of object f of TstOElf
. met Eins.eins <obj f of TstOElf>
. met Elf.zwei <obj f of TstOElf>
. met Elf.drei <obj f of TstOElf>
oCopy c1 of class TstOEins, c2
C1 u =className= TstOEins
C1.FEINS v ==> M.C1.FEINS
C1.FZWEI v ==> M.C1.FZWEI
C1 m =met-eins--> call tstOut t, " met Eins.eins" m
C1 m =met-zwei--> call tstOut t, " met Eins.zwei" m
C2 u =className= TstOEins
C2.FEINS v ==> M.C1.FEINS
C2.FZWEI v ==> M.C1.FZWEI
C2 m =met-eins--> call tstOut t, " met Eins.eins" m
C2 m =met-zwei--> call tstOut t, " met Eins.zwei" m
oCopy c3 of class TstOElf, c4
C4 u =className= TstOElf
C4 u =className= TstOEins
C4.FEINS v ==> M.C3.FEINS
C4.FZWEI v ==> M.C3.FZWEI
C4 m =met-eins--> call tstOut t, " met Eins.eins" m
C4 m =met-zwei--> call tstOut t, " met Eins.zwei" m
C4.FELF r ==> M.C3.FELF :<class O>
C4 m =met-zwei--> call tstOut t, " met Elf.zwei" m
C4 m =met-drei--> call tstOut t, " met Elf.drei" m
tEinsDop <class TstOEins>
oRun 7*3 21
oRun 12*12 144
$/tstOEins/ */
call classIni
call tst t, 'tstOEins'
tEins = classNew('n? TstOEins u f FEINS v,f FZWEI v', 'm',
, 'eins call tstOut t, " met Eins.eins" m',
, 'zwei call tstOut t, " met Eins.zwei" m')
call mAdd t.trans, tEins '<class TstOEins>' ,
, m.class_o '<class O>'
call tstOut t, 'class method calls of TstOEins'
interpret classMet('TstOEins', 'eins')
e = oNew('TstOEins')
e2 = oNew('TstOEins')
call mAdd t.trans, e '<obj e of TstOEins>'
call mAdd t.trans, e2 '<obj e2 of TstOEins>'
call tstOut t, 'flds of' e mCat(oFlds(e), ', ')
call tstOut t, 'methodcalls of object e of TstOEins'
call tstOmet e, 'eins'
call tstOmet e2, 'zwei'
call tstOmet e, 'nein'
call tstOmet 'noObj', 'nein'
tElf = classNew('n? TstOElf u TstOEins, f FELF r', 'm',
, 'zwei call tstOut t, " met Elf.zwei" m',
, 'drei call tstOut t, " met Elf.drei" m')
call tstOut t, 'class method calls of TstOEins'
interpret classMet('TstOElf', 'zwei')
f = oNew('TstOElf')
call mAdd t.trans, f '<obj f of TstOElf>'
call tstOut t, 'flds of' f mCat(oFlds(f), ', ')
call tstOut t, 'methodcalls of object f of TstOElf'
call tstOmet f, 'eins'
call tstOmet f, 'zwei'
call tstOmet f, 'drei'
call oMutatName c1, 'TstOEins'
call tstOut t, 'oCopy c1 of class TstOEins, c2'
call tstClassOut t, tEins, c1
call oCopy c1, c2
call tstClassOut t, tEins, c2
call tstOut t, 'oCopy c3 of class TstOElf, c4'
call oMutatName c3, 'TstOElf'
call oCopy c3, c4
call tstClassOut t, tElf, c4
/* tEinsDop = classNew('n TstOEins u f FEINS v,f FZWEI v', 'm',
, 'eins call tstOut t, " met Eins.eins" m',
, 'zwei call tstOut t, " met Eins.zwei" m')
*/ tEinsDop = tEins
call tstOut t, 'tEinsDop' tEinsDop
e3 = oNew('TstOEins')
if e3 <<= e | e3 <<= e2 then
call err 'doppelt reinitialised objects'
rr = oRunner('return 7 * 3')
call tstOut t, 'oRun 7*3' oRun(rr)
r12 = oRunner('return 12 * 12')
call tstOut t, 'oRun 12*12' oRun(r12)
call tstEnd t
return
endProcedure tstOEins
tstOmet: procedure expose m.
parse arg m, met
interpret objMet(m, met)
return
endProcedure tstOmet
tstOStr: procedure expose m.
/*
$=/tstOStr/
### start tst tstOStr #############################################
. kindOfStri 1
. asString .
. asString - .
. o2String .
abc kindOfStri 1
abc asString abc
abc asString - abc
abc o2String abc
!defg kindOfStri 1
!defg asString defg
!defg asString - defg
!defg o2String defg
TST_STR kindOfStri 0
*** err: TST_STR is not a kind of string but has class TstStr
TST_STR asString 0
TST_STR asString - -
*** err: no method o2String in class TstStr
*** err: o2String did not return
TST_STR o2String 0
lllllll... kindOfStri 1
lllllll... asString llllllllll
lllllll... asString - llllllllll
lllllll... o2String llllllllll
$/tstOStr/
*/
call classIni
o = oMutate(tst_str, classNew('n? TstStr u'))
call mAdd mCut(tstStr, 0), '', 'abc', '!defg', o, left('',500,'l')
call tst t, 'tstOStr'
do ix=1 to m.tstStr.0
e = m.tstStr.ix
f = e
if length(e) > 10 then
f = left(e, 7)'...'
call tstOut t, f 'kindOfStri' oKindOfString(e)
call tstOut t, f 'asString ' strip(left(oAsString(e),10))
call tstOut t, f 'asString -' strip(left(oAsString(e,'-'),10))
call tstOut t, f 'o2String ' strip(left(o2String(e),10))
end
call tstEnd t
return
endProcedure tstOStr
tstO2Text: procedure expose m.
/*
$=/o2Text/
### start tst o2Text ##############################################
. > .
und _s abc > und so
und _s lang > und so und so und so und so und so und so und so und+
. so und so ....
!und _w abc > und so
o1 > tstO2T1=¢fEins=v_o1_fEins fZwei=v_o1_fZwei fDrei=v_o+
1_fDrei!
o1 lang > tstO2T1=¢fEins=v_o1_fEins fZwei=v_o1_fZweiv_o1_fZwei+
v_o1_fZwei...!
o2 > tstO2T2=¢f2f=v_o2_f2f =value_o2!
runner > <tstRunObj>=¢<tstRunCla>!
file > <tstFileObj>=¢File!
$/o2Text/
*/
call catIni
cl = classNew('n* TstO2Text1 u f fEins v, f fZwei v, f fDrei v')
o1 = oMutate('tstO2T1', cl)
o1 = oMutate('tstO2T1', cl)
call oMutate o1, cl
call mPut o1'.fEins', 'v_o1_fEins'
call mPut o1'.fZwei', 'v_o1_fZwei'
call mPut o1'.fDrei', 'v_o1_fDrei'
call tst t, 'o2Text'
c2 = classNew('n? TstO2Text2 u f f2f v, v')
o2 = oMutate('tstO2T2', c2)
call mPut o2'.f2f', 'v_o2_f2f'
call mPut o2 , 'value_o2'
maxL = 66
call tstOut t, ' >' o2Text(' ', maxL)
call tstOut t, 'und _s abc >' o2Text('und so ', maxL)
call tstOut t, 'und _s lang >' o2Text(copies('und so ',33), maxL)
call tstOut t, '!und _w abc >' o2Text('und so ', maxL)
call tstOut t, 'o1 >' o2Text(o1 , maxL)
call mPut o1'.fZwei', copies('v_o1_fZwei',33)
call tstOut t, 'o1 lang >' o2Text(o1 , maxL)
call tstOut t, 'o2 >' o2Text(o2 , maxL)
f = file('abc.efg')
r = oRunner('say o2Text test')
call mAdd t.trans, r '<tstRunObj>',
, className(objClass(r)) '<tstRunCla>' ,
, f '<tstFileObj>'
call tstOut t, 'runner >' o2Text(r , maxL)
call tstOut t, 'file >' o2Text(f , maxL)
call mAdd t.trans, r '<tstRunnerObj>',
, className(objClass(r)) '<tstRunnerCla>'
call tstEnd t
return
endProcedure tstO2Text
tstJSay: procedure expose m.
/*
$=/tstJSay/
### start tst tstJSay #############################################
*** err: bad option openArg in jOpen(<obj j of JRW>, openArg)
*** err: jWrite(<obj j of JRW>) but not open+
ed w
*** err: can only write JSay#jOpen(<obj s of JSay>, <)
*** err: jWrite(<obj s of JSay>) but not op+
ened w
*** err: JRWEof#open(<obj e of JRWEof>, >)
*** err: jRead(<obj e of JRWEof>) but not opened r
read e vor open 0 m.xx valueBefore
read e nach open 0 m.xx valueBefore
out eins
#jIn 1# tst in line 1 eins ,
out zwei in 1 vv=readAdrVV
#jIn 2# tst in line 2 zwei ; .
out drei in 1 vv=readAdrVV Schluss
$/tstJSay/ */
call jIni
call tst t, 'tstJSay'
jrw = oNew('JRW')
call mAdd t'.TRANS', jrw '<obj j of JRW>'
call jOpen jrw, 'openArg'
call jWrite jrw, 'writeArg'
s = oNew('JSay')
call mAdd t'.TRANS', s '<obj s of JSay>'
call jOpen s, m.j.cRead
s = oNew('JSay')
call mAdd t'.TRANS', s '<obj s of JSay>'
call jWrite s, 'write s vor open'
call jOpen s, '>'
call jWrite s, 'write s nach open'
e = oNew('JRWEof')
call mAdd t'.TRANS', e '<obj e of JRWEof>'
call jOpen e, '>'
e = oNew('JRWEof')
call mAdd t'.TRANS', e '<obj e of JRWEof>'
m.xx = 'valueBefore'
call tstOut t, 'read e vor open' jReadVar(e, xx) 'm.xx' m.xx
call jOpen e, m.j.cRead
call tstOut t, 'read e nach open' jReadVar(e, xx) 'm.xx' m.xx
call out 'out eins'
vv = 'readAdrVV'
m.vv = 'readAdrVVValueBefore'
call out 'out zwei in' in() 'vv='vv
m.vv = 'readAdrVVValueBefore'
call out 'out drei in' inVar(vv) 'vv='vv 'Schluss'
call tstEnd t
return
endProcedure tstJSay
tstJ: procedure expose m.
/*
$=/tstJ/
### start tst tstJ ################################################
out eins
#jIn 1# tst in line 1 eins ,
1 in() tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
2 in() tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
3 in() tst in line 3 drei .schluss..
#jIn eof 4#
in() 3 reads vv VV
line buf line one
line buf line two
line buf line three
line buf line four
*** err: jWrite(<buf b>) but not opened w
$/tstJ/ */
call jIni
call tst t, "tstJ"
b = jOpen(jBuf(), '>')
call mAdd t'.TRANS', b '<buf b>'
call out 'out eins'
do lx=1 by 1 while in()
call out lx 'in()' m.in
end
call out 'in()' (lx-1) 'reads vv' vv
call jOpen b, '>'
call jWrite b, 'buf line one'
call jClose b
call mAdd b'.BUF', 'buf line two', 'buf line three'
call jWrite b, 'buf line four'
call jClose b
call jOpen b, m.j.cRead
do while jRead(b)
call out 'line' m.b
end
call jWrite b, 'buf line five while reading'
call jClose b
call tstEnd t
return
endProcedure tstJ
tstJ2: procedure expose m.
/*
$=/tstJ2/
### start tst tstJ2 ###############################################
class1 <Tst?1 class> <Tst?1 name>
class2 <Tst?1 class> <Tst?1 name>
class3 <Tst?1 class> <Tst?1 name>
b read EINS feld eins, ZWEI feld zwei, DREI feld drei
b read EINS feld eins, ZWEI feld zwei 2, DREI feld drei
c read EINS feld eins, ZWEI feld zwei, DREI drei cat 1
tstR: @tstWriteoV3 isA :<Tst?1 name>
tstR: .EINS = feld eins
tstR: .ZWEI = feld zwei
tstR: .DREI = drei cat 1
c read EINS feld eins, ZWEI feld zwei 2, DREI drei cat 2
tstR: @tstWriteoV4 isA :<Tst?1 name>
tstR: .EINS = feld eins
tstR: .ZWEI = feld zwei 2
tstR: .DREI = drei cat 2
$/tstJ2/ */
call jIni
call tst t, "tstJ2"
ty = classNew('n* Tst u f EINS v, f ZWEI v, f DREI v')
call mAdd t'.TRANS', ty '<Tst?1 class>'
call mAdd t'.TRANS', m.ty.name '<Tst?1 name>'
call tstOut t, 'class1' ty m.ty.name
ty = classNew('n* Tst u f EINS v, f ZWEI v, f DREI v')
call tstOut t, 'class2' ty m.ty.name
ty = classNew('n* Tst u f EINS v, f ZWEI v, f DREI v')
call tstOut t, 'class3' ty m.ty.name
call oMutate qq, ty
m.qq.eins = 'feld eins'
m.qq.zwei = 'feld zwei'
m.qq.drei = 'feld drei'
b = jBuf()
call jOpen b, '>'
call jWrite b, oCopy(qq)
m.qq.zwei = 'feld zwei 2'
call jWrite b, qq
call jOpen jClose(b), m.j.cRead
c = jOpen(jBuf(), '>')
do xx=1 while jRead(b)
res = m.b
call out 'b read EINS' m.res.eins', ZWEI' m.res.zwei,
|| ', DREI' m.res.drei
m.res.drei = 'drei cat' xx
call jWrite c, res
end
call jOpen jClose(c), m.j.cRead
do while jRead(c)
ccc = m.c
call out 'c read EINS' m.ccc.eins', ZWEI' m.ccc.zwei,
|| ', DREI' m.ccc.drei
call out ccc
end
call tstEnd t
return
endProcedure tstJ2
tstCat: procedure expose m.
/*
$=/tstCat/
### start tst tstCat ##############################################
catRead 1 line 1
catRead 2 line 2
catRead 3 line 3
appRead 1 line 1
appRead 2 line 2
appRead 3 line 3
appRead 4 append 4
appRead 5 append 5
$/tstCat/ */
call catIni
call tst t, "tstCat"
i = cat(jBuf('line 1', 'line 2'), jBuf('line 3'))
call jOpen i, m.j.cRead
do lx=1 by 1 while jRead(i)
call tstOut t, 'catRead' lx m.i
end
call jOpen jClose(i), m.j.cApp
call jWrite i, 'append 4'
call jWrite i, 'append 5'
call jOpen jClose(i), m.j.cRead
do lx=1 by 1 while jRead(i)
call tstOut t, 'appRead' lx m.i
end
call tstEnd t
return
endProcedure tstCat
tstEnv: procedure expose m.
call pipeIni
/*
$=/tstEnv/
### start tst tstEnv ##############################################
before pipeBeLa
after pipeEnd
#jIn 1# tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
before writeNow 2 c --> std
before writeNow 1 b --> c
b line eins
b zwei |
nach writeNow 1 b --> c
add nach pop
after push c only
tst in line 1 eins ,
tst in line 2 zwei ; .
tst in line 3 drei .schluss..
nach writeNow 2 c --> std
*** err: jWrite(<jBuf c>) but not opened w
$/tstEnv/ */
call tst t, "tstEnv"
c = jBuf()
call mAdd t'.TRANS', c '<jBuf c>'
call out 'before pipeBeLa'
b = jBuf("b line eins", "b zwei |")
call pipe '+Ff', c, b
call out 'before writeNow 1 b --> c'
call pipeWriteNow
call out 'nach writeNow 1 b --> c'
call pipe '-'
call out 'after pipeEnd'
call mAdd c'.BUF', 'add nach pop'
call pipe '+A', c
call out 'after push c only'
call pipeWriteNow
call pipe '-'
call pipe '+f', , c
call out 'before writeNow 2 c --> std'
call pipeWriteNow
call out 'nach writeNow 2 c --> std'
call pipe '-'
call jWrite c
call tstEnd t
return
endProcedure tstEnv
tstEnvCat: procedure expose m.
call pipeIni
/*
$=/tstEnvCat/
### start tst tstEnvCat ###########################################
c1 contents
c1 line eins |
before writeNow 1 b* --> c*
b1 line eins|
b2 line eins
b2 zwei |
c2 line eins |
after writeNow 1 b* --> c*
c2 contents
c2 line eins |
$/tstEnvCat/ */
call tst t, "tstEnvCat"
b0= jBuf()
b0= jBuf()
b1= jBuf("b1 line eins|")
b2 = jBuf("b2 line eins", "b2 zwei |")
c1 = jBuf("c1 line eins |")
c2 = jBuf("c2 line eins |")
call pipe '+Affff', c1, b0, b1, b2, c2
call out 'before writeNow 1 b* --> c*'
call pipeWriteNow
call out 'after writeNow 1 b* --> c*'
call pipe '-'
call out 'c1 contents'
call pipe '+f' , , c1
call pipeWriteNow
call pipe '-'
call pipe '+f' , , c2
call out 'c2 contents'
call pipeWriteNow
call pipe '-'
call tstEnd t
return
endProcedure tstEnvCat
tstPipe: procedure expose m.
call pipeIni
/*
$=/tstPipe/
### start tst tstPipe #############################################
.+0 vor pipeBegin
#jIn 1# tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
.+7 nach pipeLast
¢7 +6 nach pipe 7!
¢7 +2 nach pipe 7!
¢7 +4 nach nested pipeLast 7!
¢7 (4 +3 nach nested pipeBegin 4) 7!
¢7 (4 (3 +1 nach pipeBegin 3) 4) 7!
¢7 (4 (3 tst in line 1 eins , 3) 4) 7!
¢7 (4 (3 tst in line 2 zwei ; 3) 4) 7!
¢7 (4 (3 tst in line 3 drei .schluss. 3) 4) 7!
¢7 (4 (3 +1 nach writeNow vor pipe 3) 4) 7!
¢7 (4 +3 nach preSuf vor nested pipeLast 4) 7!
¢7 +4 nach preSuf vor nested pipeEnd 7!
¢7 +5 nach nested pipeEnd vor pipe 7!
¢7 +6 nach writeNow vor pipeLast 7!
.+7 nach writeNow vor pipeEnd
.+8 nach pipeEnd
$/tstPipe/ */
say 'x0' m.pipe.0
call tst t, 'tstPipe'
call out '+0 vor pipeBegin'
say 'x1' m.pipe.0
call pipe '+N'
call out '+1 nach pipeBegin'
call pipeWriteNow
call out '+1 nach writeNow vor pipe'
call pipe 'N|'
call out '+2 nach pipe'
call pipe '+N'
call out '+3 nach nested pipeBegin'
call pipePreSuf '(3 ', ' 3)'
call out '+3 nach preSuf vor nested pipeLast'
call pipe 'P|'
call out '+4 nach nested pipeLast'
call pipePreSuf '(4 ', ' 4)'
call out '+4 nach preSuf vor nested pipeEnd'
call pipe '-'
call out '+5 nach nested pipeEnd vor pipe'
call pipe 'N|'
call out '+6 nach pipe'
call pipeWriteNow
say 'out +6 nach writeNow vor pipeLast'
call out '+6 nach writeNow vor pipeLast'
call pipe 'P|'
call out '+7 nach pipeLast'
call pipePreSuf '¢7 ', ' 7!'
call out '+7 nach writeNow vor pipeEnd'
call pipe '-'
call out '+8 nach pipeEnd'
say 'xx' m.pipe.0
call tstEnd t
return
endProcedure tstPipe
tstPipeS: procedure expose m.
/*
$=/tstPipeS/
### start tst tstPipeS ############################################
eine einzige zeile
nach all einzige Zeile
select strip(creator) cr, strip(name) tb,
(row_number()over())*(row_number()over()) rr
from sysibm.sysTables
$/tstPipeS/
*/
call pipeIni
call tst t, "tstPipeS"
call pipe '+s',, 'eine einzige zeile'
call pipeWriteAll
call out 'nach all einzige Zeile'
call pipe 'sss',,
, "select strip(creator) cr, strip(name) tb," ,
, "(row_number()over())*(row_number()over()) rr" ,
, "from sysibm.sysTables"
call pipeWriteAll
call pipe '-'
call tstEnd t
return
endProcedure tstPipeS
tstEnvVars: procedure expose m.
call pipeIni
/*
$=/tstEnvVars/
### start tst tstEnvVars ##########################################
put v1 value eins
v1 hasKey 1 get TST.ADR1
v2 hasKey 0
one to theBur
two to theBuf
v1=TST.ADR1 o=TST.ADR1
v3=v3WieGehts? o=v3WieGehts?
v4=!v4WieGehts? o=!v4WieGehts?
o o0=<o0>
s o0=<o0>
o o0=<o0>
s o0=<o0>
o0&fSt0=rexx o0.fSt0 o=rexx o0.fSt0
o0&fRe0=!rexx o0.fRe0 o=!rexx o0.fRe0
o0&=rexx o0-value o=rexx o0-value
o o0=<o0>
s o0=<o0>
o0&fSt0=put o0.fSt0 o=put o0.fSt0
o0&fRe0=!putO o0.fRe0 o=!putO o0.fRe0
o0&=put o0-value o=put o0-value
$/tstEnvVars/
$=/tstEnvVars1/
### start tst tstEnvVars1 #########################################
m.o1=put-o1-value m.o1.fStr=put-o1.fStr m.o1.fRef=<o0>
o o1=<o1> s o1=<o1>
o1&fStr=put-o1.fStr o=put-o1.fStr
o1&=put-o1-value o=put-o1-value
o1&fRef=<o0> o=<o0>
o1&fRef>fSt0=put o0.fSt0 o=put o0.fSt0
o1&fRef>fRe0=!putO o0.fRe0 o=!putO o0.fRe0
m.o1&fNest.fSt0= put-o1.fNest.fSt0 m.o1&fNest.fRe0= !put-o1&fNest.f+
Re0
o1&fNest.fSt0=put-o1.fNest.fSt0 o=put-o1.fNest.fSt0
o1&fNest&fRe0=!put-o1&fNest.fRe0 o=!put-o1&fNest.fRe0
$/tstEnvVars1/
$=/tstEnvVars2/
### start tst tstEnvVars2 #########################################
o2=<o2> getO(o2)=<o2> getO(o2&fRef)=<o1>
o2&fRef>fStr=put-o1.fStr o=put-o1.fStr
o2&fRef>=put-o1-value o=put-o1-value
o2&fRef>fRef=<o0> o=<o0>
o2&fRef>fRef>fSt0=put o0.fSt0 o=put o0.fSt0
o2&fRef>fRef>fRe0=!putO o0.fRe0 o=!putO o0.fRe0
o2&fRef>fNest.fSt0=put-o1.fNest.fSt0 o=put-o1.fNest.fSt0
o2&fRef>fNest&fRe0=!put-o1&fNest.fRe0 o=!put-o1&fNest.fRe0
$/tstEnvVars2/
$=/tstEnvVarsS/
### start tst tstEnvVarsS #########################################
oS=<oS> oS&fStS=<put oS.fStS>
oS&fStV.0=1 oS&fStV.1=<put oS.fStV.1>
m.oS.fStR.0=2 .2=!<put oS.fStR.2>
oS&fStR.0=2 .1=!<put oS.fStR.1> .2=!<put oS.fStR.2>
m.oS.0=9876 .1234=<put oS.1234>
*** err: undefined var oS&12
oS&0=9876 .12=M. .1234=<put oS.1234>
$/tstEnvVarsS/
$=/tstEnvVars3/
### start tst tstEnvVars3 #########################################
m.<o0>=*o0*val vGet(<o0>>)=*o0*val
m.<o0>.fSt0=*o0.fSt0*val vGet(<o0>>fSt0)=*o0.fSt0*val
m.<o0>.fRe0=<o1> vGet(<o0>>fRe0)=<o1>
m.<o1>=*o1*val vGet(<o0>>fRe0>)=*o1*val
m.<o1>.fStr=*o1.fStr*val vGet(<o0>>fRe0>fStr)=*o1.fStr*val
m.V.tstEnvVar0=<o0> vGet(tstEnvVar0)=<o0>
m.V.tstEnvVar0=<o0> vGet(tstEnvVar0&)=<o0>
m.<o0>=*o0*val vGet(tstEnvVar0&>)=*o0*val
m.<o0>.fSt0=*o0.fSt0*val vGet(tstEnvVar0&fSt0)=*o0.fSt0*val
m.<o0>.fRe0=<o1> vGet(tstEnvVar0&fRe0)=<o1>
m.<o1>=*o1*val vGet(tstEnvVar0&fRe0>)=*o1*val
m.<o1>.fStr=*o1.fStr*val vGet(tstEnvVar0&fRe0>fStr)=*o1.fStr*val
m.<o1>.fVar=tstEnvVar2 vGet(tstEnvVar0&fRe0>fVar)=tstEnvVar2
m.<o2>=*o2*val vGet(tstEnvVar0&fRe0>fVar&)=<o2>
m.<o2>=*o2*val vGet(tstEnvVar0&fRe0>fVar&>)=*o2*val
m.<o2>.fStr=*o2.fStr*val vGet(tstEnvVar0&fRe0>fVar&fStr)=*o2.fStr*v+
al
m.<o0>=*o0*put2 vGet(<o0>>)=*o0*put2
m.<o0>.fSt0=*o0.fSt0*put2 vGet(<o0>>fSt0)=*o0.fSt0*put2
m.<o1>=*o0>fRe0>put2 vGet(<o0>>fRe0>)=*o0>fRe0>put2
m.<o1>.fStr=*o0>fRe0>fStr*put2 vGet(<o0>>fRe0>fStr)=*o0>fRe0>fStr*p+
ut2
m.<o0>=*v0&>*put3 vGet(tstEnvVar0&>)=*v0&>*put3
m.<o0>.fSt0=*v0&fSt0*put3 vGet(tstEnvVar0&fSt0)=*v0&fSt0*put3
m.<o1>=*v0&fRe0>*put3 vGet(tstEnvVar0&fRe0>)=*v0&fRe0>*put3
m.<o1>.fStr=*v0&fRe0>fStr*put3 vGet(tstEnvVar0&fRe0>fStr)=*v0&fRe0>+
fStr*put3
m.<o2>=*v0&fRe0>fVar&>*put3 vGet(tstEnvVar0&fRe0>fVar&>)=*v0&fRe0>f+
Var&>*put3
m.<o2>.fStr=*v0&fRe0>fVar&fStr*put3 vGet(tstEnvVar0&fRe0>fVar&fStr)+
=*v0&fRe0>fVar&fStr*put3
$/tstEnvVars3/
*/
c0 = classNew('n? TstEnvVars0 u f fSt0 v, f = v, f fRe0 r')
c1 = classNew('n? TstEnvVars1 u f fStr v,f fRef r' ,
', f fNest TstEnvVars0, f = v, f fVar v')
o0 = oNew(c0)
o1 = oNew(c1)
o2 = oNew(c1)
call tst t, "tstEnvVars3"
call mAdd t.trans, o0 '<o0>', o1 '<o1>', o2 '<o2>'
fSt0 = 'fSt0'
fRe0 = 'fRe0'
fStr = 'fStr'
fRef = 'fRef'
fVar = 'fVar'
v0 = 'tstEnvVar0'
v2 = 'tstEnvVar2'
m.o0 = '*o0*val'
m.o0.fSt0 = '*o0.fSt0*val'
m.o0.fRe0 = o1
m.o1 = '*o1*val'
m.o1.fStr = '*o1.fStr*val'
m.o1.fRef = o2
m.o1.fVar = v2
m.o2 = '*o2*val'
m.o2.fStr = '*o2.fStr*val'
m.v.v0 = o0
m.v.v2 = o2
call tstEnvVarsMG o0, o0'>'
call tstEnvVarsMG o0'.'fSt0, o0'>'fSt0
call tstEnvVarsMG o0'.'fRe0, o0'>'fRe0
call tstEnvVarsMG o1, o0'>'fRe0'>'
call tstEnvVarsMG o1'.'fStr, o0'>'fRe0'>'fStr
call tstEnvVarsMG v'.'v0, v0
call tstEnvVarsMG v'.'v0, v0'&'
call tstEnvVarsMG o0, v0'&>'
call tstEnvVarsMG o0'.'fSt0, v0'&'fSt0
call tstEnvVarsMG o0'.'fRe0, v0'&'fRe0
call tstEnvVarsMG o1, v0'&'fRe0'>'
call tstEnvVarsMG o1'.'fStr, v0'&'fRe0'>'fStr
call tstEnvVarsMG o1'.'fVar, v0'&'fRe0'>'fVar
call tstEnvVarsMG o2, v0'&'fRe0'>'fVar'&'
call tstEnvVarsMG o2, v0'&'fRe0'>'fVar'&>'
call tstEnvVarsMG o2'.'fStr, v0'&'fRe0'>'fVar'&fStr'
call vPut o0'>', '*o0*put2'
call tstEnvVarsMG o0, o0'>'
call vPut o0'>'fSt0, '*o0.fSt0*put2'
call tstEnvVarsMG o0'.'fSt0, o0'>'fSt0
call vPut o0'>'fRe0'>', '*o0>fRe0>put2'
call tstEnvVarsMG o1, o0'>'fRe0'>'
call vPut o0'>'fRe0'>'fStr, '*o0>fRe0>fStr*put2'
call tstEnvVarsMG o1'.'fStr, o0'>'fRe0'>'fStr
call vPut v0'&>', '*v0&>*put3'
call tstEnvVarsMG o0, v0'&>'
call vPut v0'&'fSt0, '*v0&fSt0*put3'
call tstEnvVarsMG o0'.'fSt0, v0'&'fSt0
call vPut v0'&'fRe0'>', '*v0&fRe0>*put3'
call tstEnvVarsMG o1, v0'&'fRe0'>'
call vPut v0'&'fRe0'>'fStr, '*v0&fRe0>fStr*put3'
call tstEnvVarsMG o1'.'fStr, v0'&'fRe0'>'fStr
call vPut v0'&'fRe0'>'fVar'&>', '*v0&fRe0>fVar&>*put3'
call tstEnvVarsMG o2, v0'&'fRe0'>'fVar'&>'
call vPut v0'&'fRe0'>'fVar'&fStr', '*v0&fRe0>fVar&fStr*put3'
call tstEnvVarsMG o2'.'fStr, v0'&'fRe0'>'fVar'&fStr'
call tstEnd t, "tstEnvVars"
call tst t, "tstEnvVars"
call mAdd t.trans, o0 '<o0>', o1 '<o1>', o2 '<o2>'
call vRemove 'v2'
m.tst.adr1 = 'value eins'
put1 = vPut('v1', oMutate(tst'.'adr1, m.class_V))
call tstOut t, 'put v1' m.put1
call tstOut t, 'v1 hasKey' vHasKey('v1') 'get' vGet('v1')
call tstOut t, 'v2 hasKey' vHasKey('v2')
if 0 then
call tstOut t, 'v2 get' vGet('v2')
call vPut 'theBuf', jBuf()
call pipe '+F' , vGet('theBuf')
call out 'one to theBur'
call out 'two to theBuf'
call pipe '-'
call pipe '+f',, vGet('theBuf')
call pipeWriteNow
call pipe '-'
call tstOut t, 'v1='vGet('v1') 'o='vGet('v1')
call vPut 'v3', 'v3WieGehts?'
call tstOut t, 'v3='vGet('v3') 'o='vGet('v3')
call vPut 'v4', s2o('v4WieGehts?')
call tstOut t, 'v4='vGet('v4') 'o='vGet('v4')
call vPut 'o0', o0
call tstOut t, 'o o0='vGet('o0')
call tstOut t, 's o0='vGet('o0')
fSt0 = 'fSt0'
fRe0 = 'fRe0'
m.o0 = 'rexx o0-value'
m.o0.fSt0 = 'rexx o0.fSt0'
m.o0.fRe0 = s2o('rexx o0.fRe0')
call tstOut t, 'o o0='vGet('o0')
call tstOut t, 's o0='vGet('o0')
call tstOut t, 'o0&fSt0='vGet('o0&fSt0') 'o='vGet('o0&fSt0')
call tstOut t, 'o0&fRe0='vGet('o0&fRe0') 'o='vGet('o0&fRe0')
call tstOut t, 'o0&='vGet('o0&>') 'o='vGet('o0&>')
call vPut 'o0&>', 'put o0-value'
call vPut 'o0&fSt0', 'put o0.fSt0'
call vPut 'o0&fRe0', s2o('putO o0.fRe0')
call tstOut t, 'o o0='vGet('o0')
call tstOut t, 's o0='vGet('o0')
call tstOut t, 'o0&fSt0='vGet('o0&fSt0') 'o='vGet('o0&fSt0')
call tstOut t, 'o0&fRe0='vGet('o0&fRe0') 'o='vGet('o0&fRe0')
call tstOut t, 'o0&='vGet('o0&>') 'o='vGet('o0&>')
call tstEnd t
call tst t, "tstEnvVars1"
call mAdd t.trans, o0 '<o0>', o1 '<o1>', o2 '<o2>'
call vPut 'o1', o1
call vPut 'o1&>', 'put-o1-value'
call vPut 'o1&fStr', 'put-o1.fStr'
call vPut 'o1&fRef', vGet('o0')
call tstOut t, 'm.o1='m.o1 'm.o1.fStr='mGet(o1'.fStr'),
'm.o1.fRef='mGet(o1'.fRef')
call tstOut t, 'o o1='vGet('o1') 's o1='vGet('o1')
call tstOut t, 'o1&fStr='vGet('o1&fStr') 'o='vGet('o1&fStr')
call tstOut t, 'o1&='vGet('o1&>') 'o='vGet('o1&>')
call tstOut t, 'o1&fRef='vGet('o1&fRef') 'o='vGet('o1&fRef')
call tstOut t, 'o1&fRef>fSt0='vGet('o1&fRef>fSt0') ,
'o='vGet('o1&fRef>fSt0')
call tstOut t, 'o1&fRef>fRe0='vGet('o1&fRef>fRe0'),
'o='vGet('o1&fRef>fRe0')
call vPut 'o1&fNest.fSt0', 'put-o1.fNest.fSt0'
call vPut 'o1&fNest.fRe0', s2o('put-o1&fNest.fRe0')
call tstOut t, 'm.o1&fNest.fSt0=' mGet(o1'.fNest.fSt0') ,
'm.o1&fNest.fRe0=' mGet(o1'.fNest.fRe0')
call tstOut t, 'o1&fNest.fSt0='vGet('o1&fNest.fSt0'),
'o='vGet('o1&fNest.fSt0')
call tstOut t, 'o1&fNest&fRe0='vGet('o1&fNest.fRe0'),
'o='vGet('o1&fNest.fRe0')
call tstEnd t
call tst t, "tstEnvVars2"
call mAdd t.trans, o0 '<o0>', o1 '<o1>', o2 '<o2>'
call vPut 'o2', o2
call vPut 'o2&fRef', vGet('o1')
call tstOut t, 'o2='o2 'getO(o2)='vGet('o2'),
'getO(o2&fRef)='vGet('o2&fRef')
call tstOut t, 'o2&fRef>fStr='vGet('o2&fRef>fStr'),
'o='vGet('o2&fRef>fStr')
call tstOut t, 'o2&fRef>='vGet('o2&fRef>'),
'o='vGet('o2&fRef>')
call tstOut t, 'o2&fRef>fRef='vGet('o2&fRef>fRef') ,
'o='vGet('o2&fRef>fRef')
call tstOut t, 'o2&fRef>fRef>fSt0='vGet('o2&fRef>fRef>fSt0') ,
'o='vGet('o2&fRef>fRef>fSt0')
call tstOut t, 'o2&fRef>fRef>fRe0='vGet('o2&fRef>fRef>fRe0'),
'o='vGet('o2&fRef>fRef>fRe0')
call tstOut t, 'o2&fRef>fNest.fSt0='vGet('o2&fRef>fNest.fSt0'),
'o='vGet('o2&fRef>fNest.fSt0')
call tstOut t, 'o2&fRef>fNest&fRe0='vGet('o2&fRef>fNest.fRe0'),
'o='vGet('o1&fNest.fRe0')
call tstEnd t
cS = classNew('n? TstEnvVarsS u f fStS v,f fStV s v, f fStR s r',
', f fNeS s TstEnvVars0, f = s v')
oS = oNew(cS)
call vPut 'oS', oS
oT = oNew(cS)
call tst t, "tstEnvVarsS"
call mAdd t.trans, o0 '<o0>', o1 '<o1>', o2 '<o2>',
, oS '<oS>', oT '<oT>'
call mPut oS'.fStS', '<put oS.fStS>'
call tstOut t, 'oS='vGet('oS') 'oS&fStS='vGet('oS&fStS')
call mPut oS'.fStV.1', '<put oS.fStV.1>'
call mPut oS'.fStV.0', 1
call tstOut t, 'oS&fStV.0='vGet('oS&fStV.0'),
'oS&fStV.1='vGet('oS&fStV.1')
call mPut oS'.fStR.1', s2o('<put oS.fStR.1>')
call mPut oS'.fStR.2', s2o('<put oS.fStR.2>')
call mPut oS'.fStR.0', 2
call tstOut t, 'm.oS.fStR.0='mGet(oS'.fStR.0'),
'.2='mGet(oS'.fStR.2')
call tstOut t, 'oS&fStR.0='vGet('oS&fStR.0'),
'.1='vGet('oS&fStR.1') '.2='vGet('oS&fStR.2')
call mPut oS'.1234', '<put oS.1234>'
call mPut oS'.0', 9876
call mPut oS'.fStR.0', 2
call tstOut t, 'm.oS.0='mGet(oS'.0'),
'.1234='mGet(oS'.1234')
call tstOut t, 'oS&0='vGet('oS&0'),
'.12='vGet('oS&12') '.1234='vGet('oS&1234')
call tstEnd t
return
endProcedure tstEnvVars
tstEnvVarsMG: procedure expose m.
parse arg m, g
call tstOut t, 'm.'m'='m.m 'vGet('g')='vGet(g)
return
tstvWith: procedure expose m.
/*
$=/tstEW2/
### start tst tstEW2 ##############################################
tstK1 TSTEW1
tstK1& !get1 w
tstK1&f1 get1.f1 v
tstK1&f2 !get1.f2 w
tstK1&F3 get1.f3 v
ttstK1&F3.FEINS get1.f3.fEins v
tstK1&F3.FZWEI !get1.f3.fZwei w
tstK1&F3.FDREI o !get1.f3.fDrei w
tstK1&F3.FDREI !get1.f3.fDrei w
tstK1&F3.1 !get1.f3.1 w
tstK1&F3.2 TSTEW1
tstK1&F3.2>F1 get1.f1 v
tstK1&F3.2>F3.2>F2 !get1.f2 w
*** err: undefined var F1
F1 M..
F1 get1.f1 v
f2 !get1.f2 w
F3 get1.f3 v
F3.FEINS get1.f3.fEins v
F3.FZWEI !get1.f3.fZwei w
F3.FDREI o !get1.f3.fDrei w
F3.1 !get1.f3.1 w
pu1 F1 get1.f1 v
pu2 F1 get2.f1 v
po-2 F1 get1.f1 v
*** err: undefined var F1
po-1 F1 M..
$/tstEW2/ */
call pipeIni
c0 = classNew('n? TstEW0 u f FEINS v,f FZWEI w, f FDREI r,v,s r')
call classMet c0, 'oFlds' /* new would do it, but we donot use it*/
cl = classNew('n? TstEW u r TstEW0, f F1 v, f F2 r, f F3 TstEW0')
call classMet cl, 'oFlds' /* new would do it, but we donot use it*/
call oMutate tstEW1, cl
m.tstEW1 = s2o('get1 w')
m.tstEW1.f1 = 'get1.f1 v'
m.tstEW1.f2 = s2o('get1.f2 w')
m.tstEW1.f3 = 'get1.f3 v'
m.tstEW1.f3.fEins = 'get1.f3.fEins v'
m.tstEW1.f3.fZwei = s2o('get1.f3.fZwei w')
m.tstEW1.f3.fDrei = s2o('get1.f3.fDrei w')
m.tstEW1.f3.0 = 3
m.tstEW1.f3.1 = s2o('get1.f3.1 w')
m.tstEW1.f3.2 = tstEW1
m.tstEW1.f3.3 = s2o('get1.f3.3 w')
call oMutate tstEW2, cl
m.tstEW2 = s2o('get2 w')
m.tstEW2.f1 = 'get2.f1 v'
m.tstEW2.f2 = s2o('get2.f2 w')
call vPut 'tstK1', tstEW1
call tst t, 'tstEW2'
call tstOut t, 'tstK1 ' vGet('tstK1')
call tstOut t, 'tstK1& ' vGet('tstK1&>')
call tstOut t, 'tstK1&f1 ' vGet('tstK1&F1')
call tstOut t, 'tstK1&f2 ' vGet('tstK1&F2')
call tstOut t, 'tstK1&F3 ' vGet('tstK1&F3')
call tstOut t, 'ttstK1&F3.FEINS ' vGet('tstK1&F3.FEINS')
call tstOut t, 'tstK1&F3.FZWEI ' vGet('tstK1&F3.FZWEI')
call tstOut t, 'tstK1&F3.FDREI o ' vGet('tstK1&F3.FDREI')
call tstOut t, 'tstK1&F3.FDREI ' vGet('tstK1&F3.FDREI')
call tstOut t, 'tstK1&F3.1 ' vGet('tstK1&F3.1')
call tstOut t, 'tstK1&F3.2 ' vGet('tstK1&F3.2')
call tstOut t, 'tstK1&F3.2>F1 ' vGet('tstK1&F3.2>F1')
call tstOut t, 'tstK1&F3.2>F3.2>F2' ,
vGet('tstK1&F3.2>F3.2>F2')
call tstOut t, 'F1 ' vGet('F1')
call vWith '+', tstEW1
call tstOut t, 'F1 ' vGet('F1')
call tstOut t, 'f2 ' vGet('F2')
call tstOut t, 'F3 ' vGet('F3')
call tstOut t, 'F3.FEINS ' vGet('F3.FEINS')
call tstOut t, 'F3.FZWEI ' vGet('F3.FZWEI')
call tstOut t, 'F3.FDREI o ' vGet('F3.FDREI')
call tstOut t, 'F3.1 ' vGet('F3.1')
call tstOut t, 'pu1 F1 ' vGet('F1')
call vWith '+', tstEW2
call tstOut t, 'pu2 F1 ' vGet('F1')
call vWith '-'
call tstOut t, 'po-2 F1 ' vGet('F1')
call vWith '-'
call tstOut t, 'po-1 F1 ' vGet('F1')
call tstEnd t
/*
$=/tstEW3/
### start tst tstEW3 ##############################################
. s c3&F1 = v(c3&f1)
*** err: null address at &FEINS in c3&F1&FEINS
*** err: undefined var c3&F1&FEINS
. s c3&F1&FEINS = M..
*** err: null address at &FEINS in c3&F3&FEINS
*** err: null address at &FEINS in c3&F3&FEINS
*** err: undefined var c3&F3&FEINS
. s c3&F3&FEINS = M..
. s c3&F3.FEINS = val(c3&F3.FEINS)
*** err: undefined var c3&FEINS
. s c3&FEINS = M..
getO c3&
aft Put s c3&>FEINS = v&&fEins
Push c3 s F3.FEINS = val(c3&F3.FEINS)
aftPut= s F3.FEINS = pushPut(F3.FEINS)
push c4 s F1 = v(c4&f1)
put f2 s F2 = put(f2)
put .. s F3.FEINS = put(f3.fEins)
popW c4 s F1 = v(c3&f1)
*** err: undefined var F1
popW c3 s F1 = M..
. s F222 = f222 pop stop
$/tstEW3/
*/
call tst t, 'tstEW3'
c3 = oNew('TstEW')
call mAdd t.trans, c3 '<c3>'
m.c3.f1 = 'v(c3&f1)'
call vPut 'c3', c3
call tstEnvSG , 'c3&F1'
call tstEnvSG , 'c3&F1&FEINS'
call tstEnvSG , 'c3&F3&FEINS'
call vPut 'c3&F3.FEINS', 'val(c3&F3.FEINS)'
call tstEnvSG , 'c3&F3.FEINS'
call tstEnvSG , 'c3&FEINS'
call tstOut t, 'getO c3&', vGet('c3&')
call vPut 'c3&>', oNew('TstEW0')
call vPut 'c3&>FEINS', 'v&&fEins'
call tstEnvSG 'aft Put', 'c3&>FEINS'
call vWith '+', c3
call tstEnvSG 'Push c3', 'F3.FEINS'
call vPut 'F3.FEINS', 'pushPut(F3.FEINS)'
call tstEnvSG 'aftPut=', 'F3.FEINS'
c4 = oNew('TstEW')
call mAdd t.trans, c4 '<c4>'
m.c4.f1 = 'v(c4&f1)'
call vPut f222, 'f222 no stop'
call vWith '+', c4
call tstEnvSG 'push c4', f1
call vPut f2, 'put(f2)'
call tstEnvSG 'put f2', f2
call vPut f222, 'f222 stopped', 1
call vPut 'F3.FEINS', 'put(f3.fEins)'
call tstEnvSG 'put .. ', 'F3.FEINS'
call vWith '-'
call tstEnvSG 'popW c4', f1
call vWith '-'
call vPut f222, 'f222 pop stop'
call tstEnvSG 'popW c3', f1
call tstEnvSG , f222
call tstEnd t
return
endProcedure tstvWith
tstEnvSG: procedure expose m. t
parse arg txt, nm
call tstOut t, left(txt,10)'s' left(nm, 15)'=' vGet(nm)
return
tstPipeLazy: procedure expose m.
call pipeIni
/*
$=/tstPipeLazy/
### start tst tstPipeLazy #########################################
a1 vor pipeBegin loop lazy 0 writeNow *** <class TstPipeLazyBuf>
bufOpen <
bufClose
#jIn 2# tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
a5 vor 2 writeNow in inIx 4
a2 vor writeNow jBuf
jBuf line 1
jBuf line 2
a3 vor writeNow in inIx 1
tst in line 2 zwei ; .
tst in line 3 drei .schluss..
a4 vor barLast inIx 4
a6 vor barEnd inIx 4
a7 nach barEnd lazy 0 writeNow ***
b1 vor barBegin lazy 0 writeNow *** <class TstPipeLazyRdr>
RdrOpen <
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
rdrClose
b4 vor writeNow
b2 vor writeNow rdr inIx 2
jRead lazyRdr
tst in line 3 drei .schluss..
jRead lazyRdr
b3 vor barLast inIx 4
b5 vor barEnd inIx 4
b6 nach barEnd lazy 0 writeNow ***
a1 vor pipeBegin loop lazy 1 writeAll *** +
.<class TstPipeLazyBuf>
a5 vor 2 writeAll in inIx 0
a2 vor writeAll jBuf
bufOpen <
jBuf line 1
jBuf line 2
bufClose
a3 vor writeAll in inIx 0
#jIn 1# tst in line 1 eins ,
tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
tst in line 3 drei .schluss..
#jIn eof 4#
a4 vor barLast inIx 0
a6 vor barEnd inIx 4
a7 nach barEnd lazy 1 writeAll ***
b1 vor barBegin lazy 1 writeAll *** <class TstPipeLazyRdr>
b4 vor writeAll
b2 vor writeAll rdr inIx 1
RdrOpen <
jRead lazyRdr
#jIn 2# tst in line 2 zwei ; .
tst in line 2 zwei ; .
jRead lazyRdr
#jIn 3# tst in line 3 drei .schluss..
tst in line 3 drei .schluss..
jRead lazyRdr
#jIn eof 4#
rdrClose
b3 vor barLast inIx 1
b5 vor barEnd inIx 4
b6 nach barEnd lazy 1 writeAll ***
$/tstPipeLazy/ */
call tst t, "tstPipeLazy"
do lz=0 to 1
if lz then
w = 'writeAll'
else
w = 'writeNow'
m.t.inIx = 1-lz
ty = classNew('n? TstPipeLazyBuf u JRWDeleg', 'm',
, 'jOpen call tstOut "T", "bufOpen" opt;',
'call jOpen m.m.deleg, opt',
, 'jClose call tstOut "T", "bufClose";',
'call jClose m.m.deleg')
if \ lz then
call mAdd t'.TRANS', ty '<class TstPipeLazyBuf>'
call out 'a1 vor pipeBegin loop lazy' lz w '***' ty
call pipe '+N'
call out 'a2 vor' w 'jBuf'
b = oNew('TstPipeLazyBuf', jBuf('jBuf line 1','jBuf line 2'))
interpret 'call pipe'w 'b'
call out 'a3 vor' w 'in inIx' m.t.inIx
interpret 'call pipe'w
call out 'a4 vor barLast inIx' m.t.inIx
call pipe 'P|'
call out 'a5 vor 2' w 'in inIx' m.t.inIx
interpret 'call pipe'w
call out 'a6 vor barEnd inIx' m.t.inIx
call pipe '-'
call out 'a7 nach barEnd lazy' lz w '***'
ty = classNew('n? TstPipeLazyRdr u JRW', 'm',
, 'jOpen call tstOut "T", "RdrOpen" opt',
, 'jRead call out "jRead lazyRdr"; mr = m.m.rdr;' ,
'm.rStem.0 = jRead(mr); m.rStem.1 = m.mr',
, 'jClose call tstOut "T", "rdrClose";')
if \ lz then
call mAdd t'.TRANS', ty '<class TstPipeLazyRdr>'
r = oNew('TstPipeLazyRdr')
m.r.rdr = m.j.in
if lz then
call mAdd t'.TRANS', r '<lazyRdr>'
m.t.inIx = 2-lz
call out 'b1 vor barBegin lazy' lz w '***' ty
call pipe '+N'
call out 'b2 vor' w 'rdr inIx' m.t.inIx
interpret 'call pipe'w 'r'
call out 'b3 vor barLast inIx' m.t.inIx
call pipe 'P|'
call out 'b4 vor' w
interpret 'call pipe'w
call out 'b5 vor barEnd inIx' m.t.inIx
call pipe '-'
call out 'b6 nach barEnd lazy' lz w '***'
end
call tstEnd t
return
endProcedure tstPipeLazy
tstEnvClass: procedure expose m.
call pipeIni
/*
$=/tstEnvClass/
### start tst tstEnvClass #########################################
a0 vor pipeBegin loop lazy 0 writeNow *** TY
#jIn 2# tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
a5 vor writeNow
a1 vor jBuf()
a2 vor writeNow b
tstR: @<o20 of TstEnvClass10> isA :TstEnvClass10
tstR: .f11 = .
tstR: .F12 = value F12 of o1 <o20 of TstEnvClass10>
tstR: .f13 = .
WriteO o2
tstR: @<oc0 of TstEnvClass20> isA :TstEnvClass20 = valueO2Lazy0
tstR: .f24 = .
tstR: .F25 = value F25 of o20 <o20 of TstEnvClass20>
a3 vor writeNow
tst in line 2 zwei ; .
tst in line 3 drei .schluss..
a4 vor barLast inIx 4
a6 vor barEnd
a7 nach barEnd lazy 0 writeNow ***
a0 vor pipeBegin loop lazy 1 writeAll *** TY
a5 vor writeAll
a1 vor jBuf()
a2 vor writeAll b
tstR: @<o21 of TstEnvClass10> isA :TstEnvClass10
tstR: .f11 = .
tstR: .F12 = value F12 of o1 <o21 of TstEnvClass10>
tstR: .f13 = .
WriteO o2
tstR: @<oc1 of TstEnvClass20> isA :TstEnvClass20 = valueO2Lazy1
tstR: .f24 = .
tstR: .F25 = value F25 of o21 <o21 of TstEnvClass20>
a3 vor writeAll
#jIn 1# tst in line 1 eins ,
tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
tst in line 3 drei .schluss..
#jIn eof 4#
a4 vor barLast inIx 0
a6 vor barEnd
a7 nach barEnd lazy 1 writeAll ***
$/tstEnvClass/ */
call tst t, "tstEnvClass"
t10 = classNew('n? TstEnvClass10 u f f11 v, f F12 v, f f13 v')
t20 = classNew('n? TstEnvClass20 u v, f f24 v, f F25 v')
do lz=0 to 1
if lz then
w = 'writeAll'
else
w = 'writeNow'
m.t.inIx = 1-lz
call out 'a0 vor pipeBegin loop lazy' lz w '***' ty
call pipe '+N'
call out 'a1 vor jBuf()'
b = jOpen(jBuf(), m.j.cWri)
o1 = oNew('TstEnvClass10')
m.o1.F12 = 'value F12 of o1' o1
call mAdd t'.TRANS', o1 '<o2'lz 'of TstEnvClass10>'
call jWrite b, o1
call jWrite b, 'WriteO o2'
o2 = oNew('TstEnvClass20')
m.o2 = 'valueO2Lazy'lz
m.o2.F25 = 'value F25 of o2'lz o2
oc = oCopy(oCopy(o2))
call mAdd t'.TRANS', o2 '<o2'lz 'of TstEnvClass20>'
call mAdd t'.TRANS', oc '<oc'lz 'of TstEnvClass20>'
call jWrite b, oc
call out 'a2 vor' w 'b'
interpret 'call pipe'w jClose(b)
call out 'a3 vor' w
interpret 'call pipe'w
call out 'a4 vor barLast inIx' m.t.inIx
call pipe 'P|'
call out 'a5 vor' w
interpret 'call pipe'w
call out 'a6 vor barEnd'
call pipe '-'
call out 'a7 nach barEnd lazy' lz w '***'
end
call tstEnd t
m.t.trans.0 = 0
return
endProcedure tstEnvClass
tstDsn: procedure expose m.
/*
$=/tstDsn/
### start tst tstDsn ##############################################
aa has 4 members: created
- aa(DREI) 3 lines, aa(drei) 1/3, aa(drei) 2/3, aa(drei) 3/3
- aa(EINS) 1 lines, aa(eins) 1/1
- aa(NULL) 0 lines
- aa(ZWEI) 2 lines, aa(zwei) 1/2, aa(zwei) 2/2
bb has 1 members: copy eins, eins1
- bb(EINS1) 1 lines, aa(eins) 1/1
$/tstDsn/
$=/tstDsnL/
### start tst tstDsnL #############################################
bb has 2 members: copy zwei
- bb(EINS1) 1 lines, aa(eins) 1/1
- bb(ZWEI) 2 lines, aa(zwei) 1/2, aa(zwei) 2/2
cc has 1 members: copy drei cc new
- cc(DREI) 3 lines, aa(drei) 1/3, aa(drei) 2/3, aa(drei) 3/3
bb has 5 members: copy
- bb(DREI) 3 lines, aa(drei) 1/3, aa(drei) 2/3, aa(drei) 3/3
- bb(EINS) 1 lines, aa(eins) 1/1
- bb(EINS1) 1 lines, aa(eins) 1/1
- bb(NULL) 0 lines
- bb(ZWEI) 2 lines, aa(zwei) 1/2, aa(zwei) 2/2
bb has 8 members: copy null eins drei >*4
- bb(DREI) 3 lines, aa(drei) 1/3, aa(drei) 2/3, aa(drei) 3/3
- bb(DREI4) 3 lines, aa(drei) 1/3, aa(drei) 2/3, aa(drei) 3/3
- bb(EINS) 1 lines, aa(eins) 1/1
- bb(EINS1) 1 lines, aa(eins) 1/1
- bb(EINS4) 1 lines, aa(eins) 1/1
- bb(NULL) 0 lines
- bb(NULL4) 0 lines
- bb(ZWEI) 2 lines, aa(zwei) 1/2, aa(zwei) 2/2
bb has 7 members: delete null4
- bb(DREI) 3 lines, aa(drei) 1/3, aa(drei) 2/3, aa(drei) 3/3
- bb(DREI4) 3 lines, aa(drei) 1/3, aa(drei) 2/3, aa(drei) 3/3
- bb(EINS) 1 lines, aa(eins) 1/1
- bb(EINS1) 1 lines, aa(eins) 1/1
- bb(EINS4) 1 lines, aa(eins) 1/1
- bb(NULL) 0 lines
- bb(ZWEI) 2 lines, aa(zwei) 1/2, aa(zwei) 2/2
bb has 3 members: delete eins4 drei4 eins drei
- bb(EINS1) 1 lines, aa(eins) 1/1
- bb(NULL) 0 lines
- bb(ZWEI) 2 lines, aa(zwei) 1/2, aa(zwei) 2/2
bb has 3 members: delete drei4
- bb(EINS1) 1 lines, aa(eins) 1/1
- bb(NULL) 0 lines
- bb(ZWEI) 2 lines, aa(zwei) 1/2, aa(zwei) 2/2
before seqFuenf 5 lines, seqFuenf 1/5, seqFuenf 2/5, seqFue+
nf 3/5, seqFuenf 4/5, seqFuenf 5/5
copy zwei seqFuenf 2 lines, aa(zwei) 1/2, aa(zwei) 2/2
copy null seqFuenf 0 lines
before seqVier 4 lines, seqVier 1/4, seqVier 2/4, seqVier +
3/4, seqVier 4/4
bb has 4 members: copy .seqVier
- bb(EINS1) 1 lines, aa(eins) 1/1
- bb(FROVIER) 4 lines, seqVier 1/4, seqVier 2/4, seqVier +
3/4, seqVier 4/4
- bb(NULL) 0 lines
- bb(ZWEI) 2 lines, aa(zwei) 1/2, aa(zwei) 2/2
delete seqFuenf does not exist
delete seqFuenf does not exist
$/tstDsnL/
*/
do sx=0 to m.tst_csmRZ \== ''
sys = copies(m.tst_csmRz'/', sx)
say 'csm/sys='sys '+++++++++++++++++++++++++++'
call tst t, 'tstDsn'
pr = tstFileName(sys'tstDsn', 'r')
call tstDsnWr pr'.aa(null) ::f', 0
call tstDsnWr pr'.aa(eins)', 1
call tstDsnWr pr'.aa(zwei)', 2
call tstDsnWr pr'.aa(drei)', 3
call tstDsnWr pr'.seqVier ::f', 4
call tstDsnWr pr'.seqFuenf ::f', 5
call tstDsnRL t, pr'.aa', 'created'
call dsnCopy pr'.aa(eins)', pr'.bb(eins1)'
call tstDsnRL t, pr'.bb', 'copy eins, eins1'
call tstEnd t
if sx & \ m.tst_long then
iterate
call tst t, 'tstDsnL'
call dsnCopy pr'.aa(zwei)', pr'.bb'
call tstDsnRL t, pr'.bb', 'copy zwei'
call dsnCopy pr'.aa(drei)', pr'.cc'
call tstDsnRL t, pr'.cc', 'copy drei cc new'
call dsnCopy pr'.aa(*', pr'.bb'
call tstDsnRL t, pr'.bb', 'copy'
call dsnCopy pr'.aa', pr'.bb', 'null>null4 eins>eins4' ,
'drei>drei4'
call tstDsnRL t, pr'.bb', 'copy null eins drei >*4'
call dsnDel pr'.bb(null4)'
call tstDsnRL t, pr'.bb', 'delete null4'
call dsnDel pr'.bb(eins)'
call dsnDel pr'.bb(eins4)'
call dsnDel pr'.bb', 'drei drei4'
call tstDsnRL t, pr'.bb', 'delete eins4 drei4 eins drei'
call dsnDel pr'.bb(drei4)'
call tstDsnRL t, pr'.bb', 'delete drei4'
call tstOut t, 'before' tstDsnr1(pr'.seqFuenf')
call dsnCopy pr'.aa(zwei)', pr'.seqFuenf'
call tstOut t, 'copy zwei' tstDsnr1(pr'.seqFuenf')
call dsnCopy pr'.aa(null)', pr'.seqFuenf'
call tstOut t, 'copy null' tstDsnr1(pr'.seqFuenf')
call tstOut t, 'before' tstDsnr1(pr'.seqVier')
call dsnCopy pr'.seqVier', pr'.bb(froVier)'
call tstDsnRL t, pr'.bb', 'copy .seqVier'
call dsnDel pr'.seqFuenf'
call tstOut t, 'delete' tstDsnr1(pr'.seqFuenf')
call dsnDel pr'.seqFuenf'
call tstOut t, 'delete' tstDsnr1(pr'.seqFuenf')
/* delete all to avoid mixup in next loop */
pr = tstFileName(sys'tstDsn', 'r')
call tstEnd t
end
return
endProcedure tstDsn
tstDsnWr: procedure expose m.
parse arg dsn suf, li
q = strip(substr(dsn, lastPos('.', dsn) + 1))
do ox=1 to li
o.ox = q ox'/'li
end
call writeDsn dsn suf, o., li, 1
return
endProcedure tstDsnWr
tstDsnR1: procedure expose m.
parse arg dsn
q = strip(substr(dsn, lastPos('.', dsn) + 1))
if \ dsnExists(dsn) then
return q 'does not exist'
call readDsn dsn, i.
r = q i.0 'lines'
do ix=1 to i.0
r = r',' strip(i.ix)
end
return r
endProcedure tstDsnR1
tstDsnRL: procedure expose m.
parse arg t, dsn, msg
q = strip(substr(dsn, lastPos('.', dsn) + 1))
call mbrList tst_dsnL, dsn
call tstOut t, q 'has' m.tst_dsnL.0 'members:' msg
do mx=1 to m.tst_dsnL.0
call tstOut t, '-' tstDsnR1(dsn'('m.tst_dsnL.mx')')
end
return
endProcedure tstDsnRL
tstDsn2: procedure expose m.
/*
$=/tstDsnEq/
### start tst tstDsnEq ############################################
seq= TSTDSNS 1 lines, TSTDSNS 1/1
p2s= TSTDSNS 2 lines, TSTDSNP(eins) 1/2, TSTDSNP(eins) 2/2
TSTDSNP has 1 members: par=
- TSTDSNP(ZWEI) 2 lines, TSTDSNP(eins) 1/2, TSTDSNP(eins) 2/2
TSTDSNP has 4 members: s>*=
- TSTDSNP(DREI) 2 lines, TSTDSNP(eins) 1/2, TSTDSNP(eins) 2/2
- TSTDSNP(EINS) 2 lines, TSTDSNP(eins) 1/2, TSTDSNP(eins) 2/2
- TSTDSNP(SEQ) 1 lines, TSTDSNS 1/1
- TSTDSNP(ZWEI) 2 lines, TSTDSNP(eins) 1/2, TSTDSNP(eins) 2/2
$/tstDsnEq/
$=/tstDsnLng/
### start tst tstDsnLng ###########################################
seq= TSTDSNS 1 lines, TSTDSNS 1/1
p2s= TSTDSNS 2 lines, TSTDSNP(eins) 1/2, TSTDSNP(eins) 2/2
TSTDSNP has 1 members: par=
- TSTDSNP(ZWEI) 2 lines, TSTDSNP(eins) 1/2, TSTDSNP(eins) 2/2
TSTDSNP has 4 members: s>*=
- TSTDSNP(DREI) 2 lines, TSTDSNP(eins) 1/2, TSTDSNP(eins) 2/2
- TSTDSNP(EINS) 2 lines, TSTDSNP(eins) 1/2, TSTDSNP(eins) 2/2
- TSTDSNP(SEQ) 1 lines, TSTDSNS 1/1
- TSTDSNP(ZWEI) 2 lines, TSTDSNP(eins) 1/2, TSTDSNP(eins) 2/2
$/tstDsnLng/
$=/tstDsnSht/
### start tst tstDsnSht ###########################################
seq= TSTDSNS 1 lines, TSTDSNS 1/
p2s= TSTDSNS 2 lines, TSTDSNP(ei, TSTDSNP(ei
TSTDSNP has 1 members: par=
- TSTDSNP(ZWEI) 2 lines, TSTDSNP(ei, TSTDSNP(ei
TSTDSNP has 4 members: s>*=
- TSTDSNP(DREI) 2 lines, TSTDSNP(ei, TSTDSNP(ei
- TSTDSNP(EINS) 2 lines, TSTDSNP(ei, TSTDSNP(ei
- TSTDSNP(SEQ) 1 lines, TSTDSNS 1/
- TSTDSNP(ZWEI) 2 lines, TSTDSNP(ei, TSTDSNP(ei
$/tstDsnSht/
*/
call tstIni
tCnt = 0
cRZ = (m.tst_csmRZ \== '') * 3
if m.tst_long then
cSel = ''
else do /* one with iebCopy one with copyW */
cSel = random(0, 10*(cRz+1) - 1)
cSel = cSel + cSel % 5 + 2 random(0, 2*(cRz+1) - 1) * 6 + 1
say 'tstDsn2 selects' cSel
end
do sx=0 to cRz
sFr = copies(m.tst_csmRz'/', sx >= 2)
sTo = copies(m.tst_csmRz'/', sx // 2)
do fx=1 to 2
ff = substr('FV', fx, 1)
fWr = 1
do ty=1 to 2
tx = 1 + (fx <> ty)
tA = word('::F50 ::V54', tx)
tf = substr(tA, 3, 1)
tA = copies(tA, ff <> tf)
do lx=1 to 3 /* 1 + 2 * (ff = tf) */
tCnt = tCnt + 1
if wordPos(tCnt, cSel) < 1 & cSel <> '' then
iterate
if lx = 1 then do
tq = 'Eq'
end
else if lx = 2 then do
tq = 'Lng'
tA = '::'tf'60'
end
else do
tq = 'Sht'
tA = '::'tf || if(tf=='F', 10, 14)
end
if fWr then do
fWr = 0
fS = tstFileName(sFr'fr'ff'.tstDsnS', 'r')
fP = tstFileName(sFr'fr'ff'.tstDsnP', 'r')
call tstDsnWr fS '::'ff'50', 1
call tstDsnWr fP'(eins) ::'ff'50', 2
end
call tst t, 'tstDsn'tq
say '>>>>> csm/sys from' sFr ff 'to' sTo tf tq tA ,
'<<<<<' tCnt 'ff=tf' (ff=tf)
tS = tstFileName(sTo || tq || tf'.tstDsnS', 'r')
tP = tstFileName(sTo || tq || tf'.tstDsnP', 'r')
call dsnCopy fS, tS tA
call tstOut t, 'seq=' tstDsnR1(tS)
call dsnCopy '-' fP'(eins)', tS tA
call tstOut t, 'p2s=' tstDsnR1(tS)
call dsnCopy fP'(eins)', tP'(zwei)' tA
call tstDsnRL t, tP, 'par='
call dsnCopy fS, tP'(seq)' tA
call dsnCopy fP, tP tA, 'eins>drei'
call dsnCopy fP, tP tA
call tstDsnRL t, tP, 's>*='
call tstEnd t
end
end
end
end
return
endProcedure tstDsn2
tstDsnEx: procedure expose m.
/*
$=/tstDsnEx/
### start tst tstDsnEx ############################################
dsnExists(A540769.WK.rexx) 1
dsnExists(RZZ/A540769.WK.rexx) 1
dsnExists(A540769.WK.wk.rexxYY) 0
dsnExists(RZZ/A540769.WK.wk.rexxYY) 0
dsnExists(A540769.WK.rexx(wsh)) 1
dsnExists(RZZ/A540769.WK.rexx(wsh)) 1
dsnExists(A540769.WK.rexx(nonono)) 0
dsnExists(RZZ/A540769.WK.rexx(nonono)) 0
dsnExists(A540769.WK.rxxYY(nonon)) 0
dsnExists(RZZ/A540769.WK.rxxYY(nonon)) 0
*** err: csmExec rc=8 .
. e 1: stmt=allocate SYSTEM(?QZ) DDNAME(MBRLISDD) DATASET('A5407+
69.WK.RXXYY') DISP(SHR) timeout(30) .
. e 2: CSMSI77E INVALID SYSTEM NAME (MUST BE * OR A VALID NAME) +
(COL:8)
. e 3: CSMSI77E SYSTEM=?QZ,TIMEOUT=30 .
%%%
dsnExists(?qZ/A540769.WK.rxxYY(nonon)) 0
$/tstDsnEx/
*/
call tst t, 'tstDsnEx'
lst = 'rexx wk.rexxYY rexx(wsh) rexx(nonono) rxxYY(nonon)'
rz = m.tst_csmRZ
do lx =1 to words(lst)
d1 = 'A540769.WK.'word(lst,lx)
call tstOut t, 'dsnExists('d1')' dsnExists(d1)
call tstOut t, 'dsnExists('rz'/'d1')' dsnExists(rz'/'d1)
end
call mAdd t'.TRANS', '00'x '?', '0A'x '?'
call tstOut t, 'dsnExists(?qZ/'d1')' dsnExists('?qz/'d1)
call tstEnd t
return
endProceudre tstDsnEx
tstFile: procedure expose m.
call catIni
/*
$=/tstFile/
### start tst tstFile #############################################
write read 0 last 10 vor anfang
write read 1 last 80 links1 1 und rechts | ..
write read 2 last 80 liinks2 2 und rechts | ..
write read 5 last 80 links5 5 rechts5
write read 99 last 80 links99 99 rechts
write read 100 last 80 links100 100 rechts
write read 101 last 80 links101 101 rechts
write read 999 last 80 links999 999 rechts
write read 1000 last 80 links1000 1000 rechts
write read 1001 last 80 links1001 1001 rechts
write read 2109 last 80 links2109 2109 rechts
out > eins 1 +
. .
out > eins 2 schluss. +
. .
buf eins
buf zwei
buf drei
out > zwei mit einer einzigen Zeile +
. .
. links1 1 und rechts | . +
. .
$/tstFile/ */
call tst t, "tstFile"
pds = tstFilename('lib', 'r')
call tstFileWr pds, 0, ' links0', ' und rechts | . '
call tstFileWr pds, 1, ' links1', ' und rechts | . '
call tstFileWr pds, 2, 'liinks2', ' und rechts | . '
call tstFileWr pds, 5, 'links5', 'rechts5'
call tstFileWr pds, 99, 'links99', 'rechts'
call tstFileWr pds, 100, 'links100', 'rechts'
call tstFileWr pds, 101, 'links101', 'rechts'
call tstFileWr pds, 999, 'links999', 'rechts'
call tstFileWr pds, 1000, 'links1000', 'rechts'
call tstFileWr pds, 1001, 'links1001', 'rechts'
call tstFileWr pds, 2109, 'links2109', 'rechts'
pd2 = tstFilename('li2', 'r')
call pipeIni
call pipe '+F', s2o(tstPdsMbr(pd2, 'eins'))
call out tstFB('out > eins 1') /* simulate fixBlock on linux */
call out tstFB('out > eins 2 schluss.')
call pipe '-'
call pipe '+F', s2o(tstPdsMbr(pd2, 'zwei'))
call out tstFB('out > zwei mit einer einzigen Zeile')
call pipe '-'
b = jBuf("buf eins", "buf zwei", "buf drei")
call pipe '+ffffff', , s2o(tstPdsMbr(pd2, 'eins')), b,
,jBuf(),
,s2o(tstPdsMbr(pd2, 'zwei')),
,s2o(tstPdsMbr(pds, 'wr0')),
,s2o(tstPdsMbr(pds, 'wr1'))
call pipeWriteNow
call pipe '-'
call tstEnd t
return
endProcedure tstFile
/*--- simulate fixBlock 80 on linux ---------------------------------*/
tstFB: procedure expose m.
parse arg line, recL
if m.err_os \== 'LINUX' then
return line
else if recL == '' then
return left(line, 80)
else
return left(line, recL)
endProcedure tstFB
tstPdsMbr: procedure expose m.
parse arg pds, mbr
if m.err_os = 'TSO' then
return pds'('mbr') ::F'
if m.err_os = 'LINUX' then
return pds'.'mbr
call err 'tstPdsMbr implement os' m.err_os
endProcedure tstPdsMbr
tstFileWR: procedure expose m.
parse arg dsn, num, le, ri
io = file(tstPdsMbr(dsn, 'wr'num))
call jOpen io, m.j.cWri
do x = 1 to num /* simulate fixBlock 80 on LINUX*/
call jWrite io, tstFB(le x ri)
end
call jClose io
if num > 100 then
call jReset io, tstPdsMbr(dsn, 'wr'num)
call jOpen io, m.j.cRead
m.io = 'vor anfang'
do x = 1 to num
if \ jRead(io) then
call err x 'not jRead'
else if m.io <> le x ri then
call err x 'read mismatch' m.io
end
if jRead(io) then
call err x 'jRead but should be eof 1'
if jRead(io) then
call err x'+1 jjRead but should be eof 2'
call jClose io
call tstOut t, 'write read' num 'last' length(m.io) strip(m.io,'t')
return
endProcedure tstFileWr
tstFileList: procedure expose m.
call catIni
/*
$=/tstFileList/
### start tst tstFileList #########################################
empty dir
filled dir
<<pref 2 List>>eins
<<pref 2 List>>zwei
<<pref 2 List>>drei
<<pref 2 List>>vier
filled dir recursive
<<pref 2 List>>eins
<<pref 2 List>>zwei
<<pref 2 List>>drei
<<pref 2 List>>vier
<<pref 1 vier>>eins
<<pref 1 vier>>zwei
<<pref 1 vier>>drei
$/tstFileList/ */
/*
$=/tstFileListTSO/
### start tst tstFileListTSO ######################################
empty dir dsnList 0
empty dir fileList
filled dir .* dsnList 3
<<pref 2 LIST>>DREI
<<pref 2 LIST>>EINS
<<pref 2 LIST>>ZWEI
filled dir fileList
<<pref 2 LIST>>DREI
<<pref 2 LIST>>EINS
<<pref 2 LIST>>ZWEI
filled dir dsnList 6
<<pref 2 LIST>>DREI
<<pref 2 LIST>>EINS
<<pref 1 VIER>>DREI
<<pref 1 VIER>>EINS
<<pref 1 VIER>>ZWEI
<<pref 2 LIST>>ZWEI
filled dir fileList recursive
<<pref 2 LIST>>DREI
<<pref 2 LIST>>EINS
<<pref 1 VIER>>DREI
<<pref 1 VIER>>EINS
<<pref 1 VIER>>ZWEI
<<pref 2 LIST>>ZWEI
$/tstFileListTSO/ */
if m.err_os = 'TSO' then
call tst t, "tstFileListTSO"
else
call tst t, "tstFileList"
fi = file(tstFileName('FileList', 'r'))
call fileMkDir fi
fl = fileList(fi)
call tstFileListDsn t, filePath(fi), 'empty dir'
call tstOut t, 'empty dir fileList'
call jWriteNow t, fl
call tstFileListMake t, fi, 2
call tstFileListDsn t, filePath(fi)'.*', 'filled dir .*'
call tstOut t, 'filled dir fileList'
call jWriteNow t, fl
call tstFileListDsn t, filePath(fi), 'filled dir'
call tstOut t, 'filled dir fileList recursive'
call jWriteNow t, fileList(fi, 'r')
call tstEnd t
return
endProcedure tstFileList
tstFileListDsn: procedure expose m.
parse arg t, fi, msg
call tstOut t, msg 'dsnList' dsnList(tst_FileListDsn, fi)
do ox=1 to m.tst_FileListDsn.0
call tstOut t, m.tst_FileListDsn.ox
end
return
endProcedure tstFileListDsn
tstFileListMake: procedure expose m.
parse arg t, fi, lev
if \ fileIsDir(fi) then
call fileMkDir fi
call mAdd t'.TRANS', filePath(fi) || m.file.sep ,
'<<pref' lev right(filePath(fi),4)'>>'
call jCat fileChild(fi, 'eins','::F'),jBuf('zeile eins','eins' lev)
call jCat fileChild(fi, 'zwei','::F'),jBuf('zeile zwei','zwei' lev)
call jCat fileChild(fi, 'drei','::F'),jBuf('zeile drei','drei' lev)
if lev > 1 then
call tstFileListMake t, fileChild(fi, 'vier'), lev-1
return
endProcedure tstFileListMake
/*--- manualTest time -----------------------------------------------*/
tstUtTime: procedure expose m.
say 'begin' utTime() sysvar('sysnode')
do 3000000
end
call sleep 1
say 'end ' utTime()
return
/*--- manualTest Mail -----------------------------------------------*/
tstMail: procedure expose m.
do i=1 to 2
call mailHead xy, 'mail from walter''s rexx' time() i, A540769
call mailText xy, 'und hier kommt der text' ,
, 'und zeile zwei timestamp' i':' date('s') time() ,
, left('und eine lange Zeile 159', 156, '+')159 ,
, left('und eine lange Zeile 160', 157, '+')160 ,
, left('und eine lange Zeile 161', 158, '+')161 ,
, '<ol><li>'left('und eine lange', 200,'+')203 '</li>',
, '<li bgcolor=yellow>und kurz</li></ol>' ,
, '<h1>und Schluss mit html</h1>'
call mailSend xy
call sleep 3
end
return
endprocedure tstMail
tstF: procedure expose m.
/*
$=/tstF/
### start tst tstF ################################################
f(1 23%c345%c67%%8, eins, zwei ) =1 23eins345 zwei 67%8;
f(1\S23%c345%S67%%8, eins, zwei ) =1\S23eins345zwei67%8;
f(1 23%C345%C67%%8, eins, zwei ) =1 23eins345 zwei 67%8;
f(1 23%c345%S67%%8, eins, zwei ) =1 23eins345zwei67%8;
f(1%S2%c3@2%S4@%c5, eins, zwei ) =1eins2 zwei 3zwei4 zwei 5;
f(1%-2C2%3C3@2%3.2C4, eins, zwei ) =1ei2ei 3zwe4;
f(1@F1%c2@f2%c3@F3%c4, eins, zwei ) =1fEins2fZwei3fDrei4;
f(a%(b%3Cc%)d, eins, zwei ) =abinscd;
f(a%(b%3Cc%,d%-3Ce%)f, eins, zwei ) =adbinef;
f(a@2%(b%3Cc%)d, eins, zwei ) =abei cd;
f(a@2%(b%3Cc%,d%-3Ce%)f, eins, zwei ) =adbeief;
tstF2 _ %-9C @%5I @%8I @%+8I @%-8I -----
_ 0 0 0 +0 0 .
_ -1.2 -1 -1 -1 -1 .
_ 2.34 2 2 +2 2 .
_ -34.8765 -35 -35 -35 -35 .
_ 567.91234 568 568 +568 568 .
_ -8901 -8901 -8901 -8901 -8901 .
_ 23456 23456 23456 +23456 23456 .
_ -789012 ***** -789012 -789012 -789012 .
_ 34e6 ***** 34000000 ******** 34000000
_ -56e7 ***** ******** ******** ********
_ 89e8 ***** ******** ******** ********
_ txtli txtli txtli txtli txtli .
_ undEinLan undEi undEinLa undEinLa undEinLa
tstF2 _ %-9C @%5.2I @%12.2I @%+12.2I @%-12.2I -----
_ 0 0.00 0.00 +0.00 0.00 .
_ -1.2 -1.20 -1.20 -1.20 -1.20 .
_ 2.34 2.34 2.34 +2.34 2.34 .
_ -34.8765 ***** -34.88 -34.88 -34.88 .
_ 567.91234 ***** 567.91 +567.91 567.91 .
_ -8901 ***** -8901.00 -8901.00 -8901.00 .
_ 23456 ***** 23456.00 +23456.00 23456.00 .
_ -789012 ***** -789012.00 -789012.00 -789012.00 .
_ 34e6 ***** 34000000.00 +34000000.00 34000000.00 .
_ -56e7 ***** ************ ************ ************
_ 89e8 ***** ************ ************ ************
_ txtli txtli txtli txtli txtli .
_ undEinLan undEi undEinLanger undEinLanger undEinLanger
tstF2 _ %-9C @%7e @% 8E @% 9.3e @% 11.4E -----
_ 0 0.00e00 0.00E00 0.000e00 0.0000E000
_ -1.2 -1.2e00 -1.20E00 -1.200e00 -1.2000E000
_ 2.34 2.34e00 2.34E00 2.340e00 2.3400E000
_ -34.8765 -3.5e01 -3.49E01 -3.488e01 -3.4877E001
_ 567.91234 5.68e02 5.68E02 5.679e02 5.6791E002
_ -8901 -8.9e03 -8.90E03 -8.901e03 -8.9010E003
_ 23456 2.35e04 2.35E04 2.346e04 2.3456E004
_ -789012 -7.9e05 -7.89E05 -7.890e05 -7.8901E005
_ 34e6 3.40e07 3.40E07 3.400e07 3.4000E007
_ -56e7 -5.6e08 -5.60E08 -5.600e08 -5.6000E008
_ 89e8 8.90e09 8.90E09 8.900e09 8.9000E009
_ txtli txtli txtli txtli txtli.
_ undEinLan undEinL undEinLa undEinLan undEinLange
_ 8.76e-07 8.76e-7 8.76E-7 8.760e-7 8.7600E-07
_ 5.43e-11 5.4e-11 5.4E-11 5.43e-11 5.4300E-11
_ -8.76e-07 -8.8e-7 -8.76E-7 -8.760e-7 -8.7600E-07
_ -5.43e-11 -5e-011 -5.4E-11 -5.43e-11 -5.4300E-11
tstF2 _ %-9C @%kt @%kd @%kb -----
_ 0 0s00 0 0 .
_ -1.2 -1s20 -1 -1 .
_ 2.34 2s34 2340m 2 .
_ -34.8765 -0m35 -35 -35 .
_ 567.91234 9m28 568 568 .
_ -8901 -2h28 -9k -9k
_ 23456 6h31 23k 23k
_ -789012 -9d03 -789k -771k
_ 34e6 394d 34M 32M
_ -56e7 -++++ -560M -534M
_ 89e8 +++++ 8900M 8488M
_ txtli txtli txtli txtli
_ undEinLan Text? Text? Text?
_ 8.76e-07 0s00 876n 0 .
_ 5.43e-11 0s00 54p 0 .
_ -8.76e-07 -0s00 -876n -0 .
_ -5.43e-11 -0s00 -54p -0 .
$/tstF/ */
call tst t, 'tstF'
call tstF1 '1 23%c345%c67%%8'
call tstF1 '1\S23%c345%S67%%8'
call tstF1 '1 23%C345%C67%%8'
call tstF1 '1 23%c345%S67%%8'
call tstF1 '1%S2%c3@2%S4@%c5'
call tstF1 '1%-2C2%3C3@2%3.2C4'
call tstF1 '1@F1%c2@f2%c3@F3%c4'
call tstF1 'a%(b%3Cc%)d'
call tstF1 'a%(b%3Cc%,d%-3Ce%)f'
call tstF1 'a@2%(b%3Cc%)d'
call tstF1 'a@2%(b%3Cc%,d%-3Ce%)f'
nums = '0 -1.2 2.34 -34.8765 567.91234 -8901 23456' ,
'-789012 34e6 -56e7 89e8 txtli undEinLangerText?'
call tstF2 '_ %-9C @%5I @%8I @%+8I @%-8I', nums
call tstF2 '_ %-9C @%5.2I @%12.2I @%+12.2I @%-12.2I', nums
num2 = ' 8.76e-07 5.43e-11 -8.76e-07 -5.43e-11'
call tstF2 '_ %-9C @%7e @% 8E @% 9.3e @% 11.4E', nums num2
call tstF2 '_ %-9C @%kt @%kd @%kb', nums num2
call tstEnd t
return
endProcedure tstF
tstF1: procedure expose m.
parse arg fmt
e='eins'
z=' zwei '
f2 = 'f2'
m.e.f1 = 'fEins'
m.e.f2 = 'fZwei'
m.e.f3 = 'fDrei'
call tstOut t, "f("fmt"," e"," z") ="f(fmt, e, z)";"
return
endProcedure tstF1
tstF2: procedure expose m.
parse arg fmt, vals
call tstOut t, 'tstF2' fmt '-----'
do vx=1 to words(vals)
call tstOut t, f(fmt, word(vals, vx))
end
return
endProcedure tstF2
tstFWords: procedure expose m.
/*
$=/tstFWords/
### start tst tstFWords ###########################################
??empty?? .
1space .
, #0-- --
#a%9c#l<<#r>> <<>>
*#a%-7c .
??empty?? eins
1space eins
, #0-- eins
#a%9c#l<<#r>> << eins>>
*#a%-7c eins .
??empty?? einszwei
1space eins zwei
, #0-- eins, zwei
#a%9c#l<<#r>> << eins zwei>>
*#a%-7c eins *zwei .
??empty?? einszweidrei
1space eins zwei drei
, #0-- eins, zwei, drei
#a%9c#l<<#r>> << eins zwei drei>>
*#a%-7c eins *zwei *drei .
$/tstFWords/
*/
ws = ' eins zwei drei '
call tst t, 'tstFWords'
do l=0 to 3
call tstOut t, '??empty?? ' fWords( ,subword(ws,1,l))
call tstOut t, '1space ' fWords(' ' ,subword(ws,1,l))
call tstOut t, ', #0-- ' fWords(', #0--' ,subword(ws,1,l))
call tstOut t, '#a%9c#l<<#r>>',
fWords('#a%9c#l<<#r>>' ,subword(ws,1,l))
call tstOut t, '*#a%-7c ' fWords('*#a%-7c' ,subword(ws,1,l))
end
call tstEnd t
return
endProcedure tstFWords
tstFe: procedure expose m.
/*
$=/tstFe/
### start tst tstFe ###############################################
. 1 < 1.00e00> <1.00e00>
. 0 < 0.00e00> <0.00e00>
. -2.1 <-2.10e00> <-2.1e00>
. .3 < 3.00e-1> <3.00e-1>
. -.45678 <-4.57e-1> <-4.6e-1>
. 901 < 9.01e02> <9.01e02>
. -2345 <-2.35e03> <-2.3e03>
. 678e90 < 6.78e92> <6.78e92>
. 123e-4 < 1.23e-2> <1.23e-2>
. 567e-89 < 5.7e-87> <5.7e-87>
. 12e456 < 1.2e457> <1.2e457>
. 78e-901 < 8e-0900> <8e-0900>
. 2345e5789 < 2e05792> <2e05792>
. 123e-4567 < 1e-4565> <1e-4565>
. 8901e23456 < 9e23459> <9e23459>
. -123e-4567 <-1e-4565> <-0e-999>
. 567e890123 <********> <*******>
. 45678e-901234 < 0e-9999> <0e-9999>
. kurz < kurz> <kurz >
. undLangerText <undLange> <undLang>
$/tstFe/
*/
call tst t, 'tstFe'
vAll = '1 0 -2.1 .3 -.45678 901 -2345 678e90 123e-4' ,
'567e-89 12e456 78e-901 2345e5789 123e-4567 8901e23456' ,
'-123e-4567 567e890123 45678e-901234' ,
'kurz undLangerText'
do vx=1 to words(vAll)
v = word(vAll, vx)
call tstOut t, right(v, 20) '<'fe(v, 8, 2, 'e', ' ')'>' ,
'<'fe(v, 7, 1, 'e', '-')'>'
end
call tstEnd t
return
endProcedure
tstFTst: procedure expose m.
/*
$=/tstFTstS/
### start tst tstFTstS ############################################
1956-01-29-23.34.56.987654 SS => 1956-01-29-23.34.56.987654|
1956-01-29-23.34.56.987654 Ss => 1956-01-29-23.34.56|
1956-01-29-23.34.56.987654 S => 1956-01-29-23.34.56|
1956-01-29-23.34.56.987654 SD => 19560129|
1956-01-29-23.34.56.987654 Sd => 560129|
1956-01-29-23.34.56.987654 SE => 29.01.1956|
1956-01-29-23.34.56.987654 Se => 29.01.56|
1956-01-29-23.34.56.987654 St => 23.34.56|
1956-01-29-23.34.56.987654 ST => 23:34:56.987654|
1956-01-29-23.34.56.987654 SZ => GB29|
1956-01-29-23.34.56.987654 SM => B2923345|
1956-01-29-23.34.56.987654 SH => C33456|
1956-01-29-23.34.56.987654 SY => GB29X3LV|
1956-01-29-23.34.56.987654 SA => C9233456|
1956-01-29-23.34.56.987654 Sj => 56029|
1956-01-29-23.34.56.987654 SJ => 714076|
$/tstFTstS/
$=/tstFTsts/
### start tst tstFTsts ############################################
2014-12-23-16.57.38 sS => 2014-12-23-16.57.38.000000|
2014-12-23-16.57.38 ss => 2014-12-23-16.57.38|
2014-12-23-16.57.38 s => 2014-12-23-16.57.38|
2014-12-23-16.57.38 sD => 20141223|
2014-12-23-16.57.38 sd => 141223|
2014-12-23-16.57.38 sE => 23.12.2014|
2014-12-23-16.57.38 se => 23.12.14|
2014-12-23-16.57.38 st => 16.57.38|
2014-12-23-16.57.38 sT => 16:57:38.000000|
2014-12-23-16.57.38 sZ => EM23|
2014-12-23-16.57.38 sM => M2316573|
2014-12-23-16.57.38 sH => B65738|
2014-12-23-16.57.38 sY => OM23Q5SI|
2014-12-23-16.57.38 sA => C3165738|
2014-12-23-16.57.38 sj => 14357|
2014-12-23-16.57.38 sJ => 735589|
2014-12-23-16.57.38 su +> E1J8X3NE|
2014-12-23-16.57.38 sL +> 00CE3F3AFA6570000000|
$/tstFTsts/
Winterzeit
2014-12-23-16.57.38 su +> E1KCA3JT|
2014-12-23-16.57.38 sL +> 00CE3F48639FB0000000|
Sommerzeit
2014-12-23-16.57.38 su +> E1J8X3NE|
2014-12-23-16.57.38 sL +> 00CE3F3AFA6570000000|
$=/tstFTstD/
### start tst tstFTstD ############################################
23450618 DS => 2345-06-18-00.00.00.000000|
23450618 Ds => 2345-06-18-00.00.00|
23450618 D => 2345-06-18-00.00.00|
23450618 DD => 23450618|
23450618 Dd => 450618|
23450618 DE => 18.06.2345|
23450618 De => 18.06.45|
23450618 Dt => 00.00.00|
23450618 DT => 00:00:00.000000|
23450618 DZ => PG18|
23450618 DM => G1800000|
23450618 DH => A00000|
23450618 DY => UG18A0AA|
23450618 DA => B8000000|
23450618 Dj => 45169|
23450618 DJ => 856296|
$/tstFTstD/
$=/tstFTstd/
### start tst tstFTstd ############################################
120724 dS => 2012-07-24-00.00.00.000000|
120724 ds => 2012-07-24-00.00.00|
120724 d => 2012-07-24-00.00.00|
120724 dD => 20120724|
120724 dd => 120724|
120724 dE => 24.07.2012|
120724 de => 24.07.12|
120724 dt => 00.00.00|
120724 dT => 00:00:00.000000|
120724 dZ => CH24|
120724 dM => H2400000|
120724 dH => A00000|
120724 dY => MH24A0AA|
120724 dA => C4000000|
120724 dj => 12206|
120724 dJ => 734707|
$/tstFTstd/
$=/tstFTstE/
### start tst tstFTstE ############################################
09.12.1345 ES => 1345-12-09-00.00.00.000000|
09.12.1345 Es => 1345-12-09-00.00.00|
09.12.1345 E => 1345-12-09-00.00.00|
09.12.1345 ED => 13451209|
09.12.1345 Ed => 451209|
09.12.1345 EE => 09.12.1345|
09.12.1345 Ee => 09.12.45|
09.12.1345 Et => 00.00.00|
09.12.1345 ET => 00:00:00.000000|
09.12.1345 EZ => PM09|
09.12.1345 EM => M0900000|
09.12.1345 EH => A00000|
09.12.1345 EY => UM09A0AA|
09.12.1345 EA => A9000000|
09.12.1345 Ej => 45343|
09.12.1345 EJ => 491228|
$/tstFTstE/
$=/tstFTste/
### start tst tstFTste ############################################
31.05.24 eS => 2024-05-31-00.00.00.000000|
31.05.24 es => 2024-05-31-00.00.00|
31.05.24 e => 2024-05-31-00.00.00|
31.05.24 eD => 20240531|
31.05.24 ed => 240531|
31.05.24 eE => 31.05.2024|
31.05.24 ee => 31.05.24|
31.05.24 et => 00.00.00|
31.05.24 eT => 00:00:00.000000|
31.05.24 eZ => OF31|
31.05.24 eM => F3100000|
31.05.24 eH => A00000|
31.05.24 eY => YF31A0AA|
31.05.24 eA => D1000000|
31.05.24 ej => 24152|
31.05.24 eJ => 739036|
$/tstFTste/
$=/tstFTstt/
### start tst tstFTstt ############################################
12.34.56 tS => 0001-01-01-12.34.56.000000|
12.34.56 ts => 0001-01-01-12.34.56|
12.34.56 t => 0001-01-01-12.34.56|
12.34.56 tD => 00010101|
12.34.56 td => 010101|
12.34.56 tE => 01.01.0001|
12.34.56 te => 01.01.01|
12.34.56 tt => 12.34.56|
12.34.56 tT => 12:34:56.000000|
12.34.56 tZ => ??01|
12.34.56 tM => ?0112345|
12.34.56 tH => B23456|
12.34.56 tY => ??01M3LV|
12.34.56 tA => A1123456|
12.34.56 tj => 01001|
12.34.56 tJ => 0|
$/tstFTstt/
$=/tstFTstT/
### start tst tstFTstT ############################################
23.45.06.784019 TS => 0001-01-01-23.45.06.784019|
23.45.06.784019 Ts => 0001-01-01-23.45.06|
23.45.06.784019 T => 0001-01-01-23.45.06|
23.45.06.784019 TD => 00010101|
23.45.06.784019 Td => 010101|
23.45.06.784019 TE => 01.01.0001|
23.45.06.784019 Te => 01.01.01|
23.45.06.784019 Tt => 23.45.06|
23.45.06.784019 TT => 23.45.06.784019|
23.45.06.784019 TZ => ??01|
23.45.06.784019 TM => ?0123450|
23.45.06.784019 TH => C34506|
23.45.06.784019 TY => ??01X4MG|
23.45.06.784019 TA => A1234506|
23.45.06.784019 Tj => 01001|
23.45.06.784019 TJ => 0|
$/tstFTstT/
$=/tstFTstYold/
### start tst tstFTstY ############################################
PE25 YS => 2015-04-25-00.00.00.000000|
PE25 Ys => 2015-04-25-00.00.00|
PE25 Y => 2015-04-25-00.00.00|
PE25 YD => 20150425|
PE25 Yd => 150425|
PE25 YE => 25.04.2015|
PE25 Ye => 25.04.15|
PE25 Yt => 00.00.00|
PE25 YT => 00:00:00.000000|
PE25 YZ => ?E25|
PE25 YM => E2500000|
PE25 YH => A00000|
PE25 YY => PE25A0AA|
PE25 YA => C5000000|
PE25 Yj => 15115|
PE25 YJ => 735712|
$/tstFTstYold/
$=/tstFTstM/
### start tst tstFTstM ############################################
I2317495 MS => 0001-08-23-17.49.50.000000|
I2317495 Ms => 0001-08-23-17.49.50|
I2317495 M => 0001-08-23-17.49.50|
I2317495 MD => 00010823|
I2317495 Md => 010823|
I2317495 ME => 23.08.0001|
I2317495 Me => 23.08.01|
I2317495 Mt => 17.49.50|
I2317495 MT => 17:49:50.000000|
I2317495 MZ => ?I23|
I2317495 MM => I2317495|
I2317495 MH => B74950|
I2317495 MY => ?I23R4XP|
I2317495 MA => C3174950|
I2317495 Mj => 01235|
I2317495 MJ => 234|
$/tstFTstM/
$=/tstFTstH/
### start tst tstFTstH ############################################
B23456 HS => 0001-01-01-12.34.56.000000|
B23456 Hs => 0001-01-01-12.34.56|
B23456 H => 0001-01-01-12.34.56|
B23456 HD => 00010101|
B23456 Hd => 010101|
B23456 HE => 01.01.0001|
B23456 He => 01.01.01|
B23456 Ht => 12.34.56|
B23456 HT => 12:34:56.000000|
B23456 HZ => ??01|
B23456 HM => ?0112345|
B23456 HH => B23456|
B23456 HY => ??01M3LV|
B23456 HA => A1123456|
B23456 Hj => 01001|
B23456 HJ => 0|
$/tstFTstH/
$=/tstFTstn/
### start tst tstFTstn ############################################
19560423 17:58:29 nS => 1956-04-23-17.58.29.000000|
19560423 17:58:29 ns => 1956-04-23-17.58.29|
19560423 17:58:29 n => 1956-04-23-17.58.29|
19560423 17:58:29 nD => 19560423|
19560423 17:58:29 nd => 560423|
19560423 17:58:29 nE => 23.04.1956|
19560423 17:58:29 ne => 23.04.56|
19560423 17:58:29 nt => 17.58.29|
19560423 17:58:29 nT => 17:58:29.000000|
19560423 17:58:29 nZ => GE23|
19560423 17:58:29 nM => E2317582|
19560423 17:58:29 nH => B75829|
19560423 17:58:29 nY => GE23R5UJ|
19560423 17:58:29 nA => C3175829|
19560423 17:58:29 nj => 56114|
19560423 17:58:29 nJ => 714161|
$/tstFTstn/
$=/tstFTstN/
### start tst tstFTstN ############################################
32101230 10:21:32.456789 NS => 3210-12-30-10.21.32.456789|
32101230 10:21:32.456789 Ns => 3210-12-30-10.21.32|
32101230 10:21:32.456789 N => 3210-12-30-10.21.32|
32101230 10:21:32.456789 ND => 32101230|
32101230 10:21:32.456789 Nd => 101230|
32101230 10:21:32.456789 NE => 30.12.3210|
32101230 10:21:32.456789 Ne => 30.12.10|
32101230 10:21:32.456789 Nt => 10.21.32|
32101230 10:21:32.456789 NT => 10:21:32.456789|
32101230 10:21:32.456789 NZ => AM30|
32101230 10:21:32.456789 NM => M3010213|
32101230 10:21:32.456789 NH => B02132|
32101230 10:21:32.456789 NY => KM30K2DR|
32101230 10:21:32.456789 NA => D0102132|
32101230 10:21:32.456789 Nj => 10364|
32101230 10:21:32.456789 NJ => 1172426|
$/tstFTstN/
$=/tstFTstY/
### start tst tstFTstY ############################################
RF06R2UT YS => 2017-05-06-17.28.39.000000|
RF06R2UT Ys => 2017-05-06-17.28.39|
RF06R2UT Y => 2017-05-06-17.28.39|
RF06R2UT YD => 20170506|
RF06R2UT Yd => 170506|
RF06R2UT YE => 06.05.2017|
RF06R2UT Ye => 06.05.17|
RF06R2UT Yt => 17.28.39|
RF06R2UT YT => 17:28:39.000000|
RF06R2UT YZ => ?F06|
RF06R2UT YM => F0617283|
RF06R2UT YH => B72839|
RF06R2UT YY => RF06R2UT|
RF06R2UT YA => A6172839|
RF06R2UT Yj => 17126|
RF06R2UT YJ => 736454|
$/tstFTstY/
*/
say "current time '%t '" f('%t ') "'%t D'" f('%t D')
say " '%t S'" f('%t S') "'%t t'" f('%t t') "'%t T'" f('%t T')
call timeIni
allOut = 'Ss DdEetTZMHYAjJ'
allIn = 'S1956-01-29-23.34.56.987654' ,
's2014-12-23-16.57.38' ,
'D23450618' ,
'd120724' ,
'E09.12.1345' ,
'e31.05.24' ,
't12.34.56' ,
'T23.45.06.784019' ,
/* 'YPE25' ,
*/ 'MI2317495' ,
'HB23456' ,
'n19560423*17:58:29' ,
'N32101230*10:21:32.456789',
'YRF06R2UT'
do ix=1 to words(allIn)
parse value word(allIn, ix) with iF 2 iV
iv = translate(iv, ' ', '*')
call tst t, "tstFTst"iF
do ox=1 to length(allOut)
ft = iF || substr(allOut, ox, 1)
call tstOut t, left(iV, 30) ft '=>' f('%t'ft, iV)'|'
if 0 & iF = 'Y' then
say '???' ft '>>>' mGet('F_GEN.%t'ft)
end
if ix=2 then do
call tstOut t, left(iV, 30) iF'u' '+>' f('%t'iF'u', iV)'|'
call tstOut t, left(iV, 30) iF'L' '+>' f('%t'iF'L', iV)'|'
end
call tstEnd t
end
return
endProcedure tstFTst
tstFUnit2: procedure expose m.
/* b
$=/tstFUnit2/
### start tst tstFUnit2 ###########################################
. 12 = 12 12
. 23k = 23000 23552
34 K = 34000 34816
45 M = 45000000 47185920
567G = 567000000000 608811614208
. 678 = 678
$/tstFUnit2/
*/
call tst t, 'tstFUnit2'
call tstOut t, ' 12 =' fUnit2I('d',' 12 ') fUnit2I('b',' 12 ')
call tstOut t, ' 23k =' fUnit2I('d',' 23k') fUnit2I('b',' 23k')
call tstOut t, '34 K =' fUnit2I('d','34 K ') fUnit2I('b','34 K ')
call tstOut t, '45 M =' fUnit2I('d','45 M') fUnit2I('b','45 M')
call tstOut t, '567G =' fUnit2I('d','567G') fUnit2I('b','567G')
call tstOut t, ' 678 =' fUnit2I('t',' 678 ')
/* t umbauen, funktioniert nicht mit jetztigen Metadaten ||||
call tstOut t, ' 78 s ='fUnit2I('t', ' 78 s ')
call tstOut t, '567G' fUnit2I('t', ' 123 ') */
call tstEnd t
return
endProcedure tstFU
tstFmt: procedure expose m.
call pipeIni
/*
$=/tstFmt/
### start tst tstFmt ##############################################
= a2i b3b d4 fl5 ex6
-11 -11 b3 d4-11+d4++++ -111.1000000 -1.11000e-12
-1 -10 b d4-10+d4+++ null1 null3
- -9 b3b-9 d4-9+d4+++ -11.0000000 -1.11900e-10
-8+ -8 b3b- d4-8+d4++ -18.0000000 -1.18000e010
-7 -7 b3b d4-7+d4+ -7.0000000 -1.70000e-07
- -6 b3 d4-6+d4 -0.1111160 -6.00000e006
-5+ -5 b d4-5+d null2 null2
-4 -4 b3b-4 d4-4+ -11114.0000000 -1.11140e008
- -3 b3b- d4-3 -0.1130000 -1.13000e-04
-2+ -2 b3b d4- -0.1200000 -1.20000e001
-1 -1 b3 d4 -0.1000000 -1.00000e-02
0 0 b d null1 null1
1+ 1 b3 d4 0.1000000 1.00000e-02
2++ 2 b3b d42 0.1200000 1.20000e001
3 3 b3b3 d43+ 0.1130000 1.13000e-04
4+ 4 b3b4+ d44+d 11114.0000000 1.11140e008
5++ 5 b d45+d4 null2 null2
6 6 b3 d46+d4+ 0.1111160 1.11116e005
7+ 7 b3b d47+d4++ 0.1111117 7.00000e-08
8++ 8 b3b8 d48+d4+++ 8.0000000 1.80000e009
9 9 b3b9+ d49+d4++++ 0.9000000 1.19000e-08
10 10 b d410+d4++++ null1 null3
11+ 11 b3 d411+d4+++++ 0.1110000 1.00000e-12
1 12 b3b d412+d4++++++ 11112.0000000 2.00000e012
13 13 b3b1 d 1111.3000000 1.13000e-12
14+ 14 b3b14 d4 111111.0000000 1.40000e013
1 15 b d41 null2 null1
16 16 b3 d416 6.0000000 1.16000e003
17+ 17 b3b d417+ 0.7000000 1.11170e-03
1 18 b3b1 d418+d 11.0000000 1.11800e003
19 19 b3b19 d419+d4 0.1190000 9.00000e-05
20+ 20 b d420+d4+ null1 null2
2 21 b3 d421+d4++ 11.1210000 1.11000e-05
22 22 b3b d422+d4+++ 11111.2000000 2.00000e007
23+ 23 b3b2 d423+d4++++ 0.1111123 1.11230e-09
c3L a2i drei d4 fl5 ex6
-11 -1.10E01 b3 d4-11+d -111.1000000 -1.11000e-12
-1 -1.00E01 b d4-10+d null1 null3
- -9.00E00 b3b-9 d4-9+d4 -11.0000000 -1.11900e-10
-8+ -8.00E00 b3b- d4-8+d4 -18.0000000 -1.18000e010
-7 -7.00E00 b3b d4-7+d4 -7.0000000 -1.70000e-07
- -6.00E00 b3 d4-6+d4 -0.1111160 -6.00000e006
-5+ -5.00E00 b d4-5+d null2 null2
-4 -4.00E00 b3b-4 d4-4+ -11114.0000000 -1.11140e008
- -3.00E00 b3b- d4-3 -0.1130000 -1.13000e-04
-2+ -2.00E00 b3b d4- -0.1200000 -1.20000e001
-1 -1.00E00 b3 d4 -0.1000000 -1.00000e-02
0 0.00E00 b d null1 null1
1+ 1.00E00 b3 d4 0.1000000 1.00000e-02
2++ 2.00E00 b3b d42 0.1200000 1.20000e001
3 3.00E00 b3b3 d43+ 0.1130000 1.13000e-04
4+ 4.00E00 b3b4+ d44+d 11114.0000000 1.11140e008
5++ 5.00E00 b d45+d4 null2 null2
6 6.00E00 b3 d46+d4+ 0.1111160 1.11116e005
7+ 7.00E00 b3b d47+d4+ 0.1111117 7.00000e-08
8++ 8.00E00 b3b8 d48+d4+ 8.0000000 1.80000e009
9 9.00E00 b3b9+ d49+d4+ 0.9000000 1.19000e-08
10 1.00E01 b d410+d4 null1 null3
11+ 1.10E01 b3 d411+d4 0.1110000 1.00000e-12
1 1.20E01 b3b d412+d4 11112.0000000 2.00000e012
13 1.30E01 b3b1 d 1111.3000000 1.13000e-12
14+ 1.40E01 b3b14 d4 111111.0000000 1.40000e013
1 1.50E01 b d41 null2 null1
16 1.60E01 b3 d416 6.0000000 1.16000e003
17+ 1.70E01 b3b d417+ 0.7000000 1.11170e-03
1 1.80E01 b3b1 d418+d 11.0000000 1.11800e003
19 1.90E01 b3b19 d419+d4 0.1190000 9.00000e-05
20+ 2.00E01 b d420+d4 null1 null2
2 2.10E01 b3 d421+d4 11.1210000 1.11000e-05
22 2.20E01 b3b d422+d4 11111.2000000 2.00000e007
23+ 2.30E01 b3b2 d423+d4 0.1111123 1.11230e-09
$/tstFmt/ */
call tst t, "tstFmt"
b = jBuf()
st = b'.BUF'
call pipe '+F', b
call tstDataClassOut '. c3 a2i i b3b c5 d4 c13 fl5 f8n2 ex6 e9n3',
, -11, + 23
call pipe '-'
call fTabAuto fTabReset(abc, 1), b
call fTabReset abc, 1
cc = fTabAdd(abc, , , 'c3L')
m.cc.fmt = fTabDetectFmt(st)
call fTabAdd abc, 'a2i', '% 8E'
cc = fTabAdd(abc, 'b3b', ,'drei')
m.cc.fmt = fTabDetectFmt(st, '.b3b')
call fTabAdd abc, 'd4', '%-7C'
cc = fTabAdd(abc, 'fl5')
m.cc.fmt = fTabDetectFmt(st, '.fl5')
cc = fTabAdd(abc, 'ex6')
m.cc.fmt = fTabDetectFmt(st, '.ex6')
call fTab abc, b
call tstEnd t
return
endProcedure tstFmt
tstFTab: procedure expose m.
/*
$=/tstFTab/
### start tst tstFTab #############################################
testData begin
..---------a2i-b3b------------------d4------fl5-----ex6---
-11 -11 b3 -11+d4++++ -111.100 -1e-012
-1 -10 b 4-10+d4+++ null1 null3
- -9 b3b-9 d4-9+d4+++ -11.000 -1e-010
-8+ -8 b3b- d4-8+d4++ -18.000 -1.2e10
-7 -7 b3b d4-7+d4+ -7.000 -1.7e-7
- -6 b3 d4-6+d4 -0.111 -6.0e06
-5+ -5 b d4-5+d null2 null2
-4 -4 b3b-4 d4-4+ ******** -1.1e08
- -3 b3b- d4-3 -0.113 -1.1e-4
-2+ -2 b3b d4- -0.120 -1.2e01
-1 -1 b3 d4 -0.100 -1.0e-2
0 0 b d null1 null1
1+ 1 b3 d4 0.100 1.00e-2
2++ 2 b3b d42 0.120 1.20e01
3 3 b3b3 d43+ 0.113 1.13e-4
4+ 4 b3b4+ d44+d ******** 1.11e08
5++ 5 b d45+d4 null2 null2
6 6 b3 d46+d4+ 0.111 1.11e05
7+ 7 b3b d47+d4++ 0.111 7.00e-8
8++ 8 b3b8 d48+d4+++ 8.000 1.80e09
9 9 b3b9+ d49+d4++++ 0.900 1.19e-8
10 10 b 410+d4++++ null1 null3
11+ 11 b3 11+d4+++++ 0.111 1.0e-12
1 12 b3b 2+d4++++++ ******** 2.00e12
13 13 b3b1 d 1111.300 1.1e-12
14+ 14 b3b14 d4 ******** 1.40e13
1 15 b d41 null2 null1
16 16 b3 d416 6.000 1.16e03
17+ 17 b3b d417+ 0.700 1.11e-3
1 18 b3b1 d418+d 11.000 1.12e03
19 19 b3b19 d419+d4 0.119 9.00e-5
20+ 20 b d420+d4+ null1 null2
2 21 b3 d421+d4++ 11.121 1.11e-5
22 22 b3b d422+d4+++ ******** 2.00e07
23+ 23 b3b2 423+d4++++ 0.111 1.11e-9
..---------a2i-b3b------------------d4------fl5-----ex6---
testData end
$/tstFTab/ */
call pipeIni
call tst t, "tstFTab"
b = jBuf()
st = b'.BUF'
call pipe '+F', b
call tstDataClassOut '. c3 a2i i b3b c5 d4 c13 fl5 f8n2 ex6 e9n3',
, -11, + 23
call pipe 'P|'
call fTabReset ft, 2 1, 1 3, '-'
call fTabAdd ft, '' , '%-6C', '.', , 'testData begin',
, 'testData end'
call fTabAdd ft, 'a2i' , '%6i'
call fTabAdd ft, 'b3b' , '%-12C'
call fTabAdd ft, 'd4' , '%10C'
call fTabAdd ft, 'fl5' , '%8.3I'
call fTabAdd ft, 'ex6' , '%7e'
call fTab ft
call pipe '-'
call tstEnd t
return
endProcedure tstFTab
tstCSV: procedure expose m.
/*
$=/tstCSV/
### start tst tstCSV ##############################################
value,value eins,value zwei
value,"value, , eins",value zwei
value,"","value ""zwei"" oder?"
value,,"value ""zwei"" oder?"
$/tstCSV/ */
m.tstCsv.c.1 = ''
m.tstCsv.c.2 = .eins
m.tstCsv.c.3 = .zwei
m.tstCsv.c.0 = 3
call tst t, "tstCSV"
m.tstCsv.o = 'value'
m.tstCsv.o.eins = 'value eins'
m.tstCsv.o.zwei = 'value zwei'
call tstOut t, csv4O(tstCsv'.'o, tstCsv'.'c, 0)
m.tstCsv.o.eins = 'value, , eins'
call tstOut t, csv4O(tstCsv'.'o, tstCsv'.'c, 0)
m.tstCsv.o.eins = ''
m.tstCsv.o.zwei = 'value "zwei" oder?'
call tstOut t, csv4O(tstCsv'.'o, tstCsv'.'c, 0)
m.tstCsv.o.eins = '---'
call tstOut t, csv4O(tstCsv'.'o, tstCsv'.'c, 1, '---')
call tstEnd t
return
endProcedure tstCSV
tstCSV2: procedure expose m.
/*
$=/tstCSV2/
### start tst tstCSV2 #############################################
w: ¢f1=1 fZwei=eins fDr=r!
w: ¢f1=2 fZwei= zwei , 2 fDr=!
w: ¢f1=3 fZwei=schluss fDr=!
W: ¢F1=1 FZWEI=eins FDR=r!
W: ¢F1=2 FZWEI= zwei , 2 FDR=!
W: ¢F1=3 FZWEI=schluss FDR=!
c: ¢f1=1 fComma=eins fDr=r!
c: ¢f1= 2 fComma= zwei , 2 fDr=!
c: ¢f1=3 fComma=schluss fDr=!
C: ¢F1=1 FCOMMA=eins FDR=r!
C: ¢F1= 2 FCOMMA= zwei , 2 FDR=!
C: ¢F1=3 FCOMMA=schluss FDR=!
o: ¢f1=1 fCol=eins fDr=drei fVie=und vier!
o: ¢f1=222222Z fCol=ccccccccC fDr=dddddddD fVie=vvvvvvvvvvvvvv V!
o: ¢f1=3 fCol=schluss fDr=drei fVie=vier!
O: ¢F1=1 FCOL=eins FDR=drei FVIE=und vier!
O: ¢F1=222222Z FCOL=ccccccccC FDR=dddddddD FVIE=vvvvvvvvvvvvvv V!
O: ¢F1=3 FCOL=schluss FDR=drei FVIE=vier!
$/tstCSV2/
*/
call jIni
call tst t, "tstCSV2"
b = jBuf(' f1 fZwei fDr ', '1 eins r',' 2 " zwei , 2 "',
, '3 schluss')
call tstCsv22 t, 'w', csvWordRdr(b)
call tstCsv22 t, 'W', csvWordRdr(b, 'u')
b = jBuf(' f1 , fComma, fDr ', '1,eins,r',' 2 ," zwei , 2 "',
, '3,schluss')
call tstCsv22 t, 'c', csv2ObjRdr(b)
call tstCsv22 t, 'C', csv2ObjRdr(b, 'u')
b = jBuf(' > f1 >< fCol <fDr fVie',
,' 1eins drei und vier ',
,'222222ZccccccccCdddddddDvvvvvvvvvvvvvv V',
,' 3 schluss dreivier')
call tstCsv22 t, 'o', csvColRdr(b)
call tstCsv22 t, 'O', csvColRdr(b, 'u')
call tstEnd t
return
endProcedure tstCSV2
tstCSV22: procedure expose m.
parse arg t, l, c
call jOpen c, '<'
do while jRead(c)
call tstOut t, l':' o2TexLR(m.c, , '¢', '!')
end
call jCLose c
return
endProcedure tstCSV22
tstCSVExt: procedure expose m.
/*
$=/tstCsvExt/
### start tst tstCsvExt ###########################################
v,string eins, oder nicht?
v,
w,string_W zwei, usw,,,|
c TstCsvExtF class@TstCsvExtF,u f FEINS v,f FZWEI v
o class@TstCsvExtF o1,f1Feins,"f1,fzwei "
c TstCsvExtG class@TstCsvExtG,u f gDrei v,f GVIER v,f gRef r o
f class@TstCsvExtG objG4,
d class@TstCsvExtG objG4,objG4gDrei,objG4.gVier,objG4
d class@TstCsvExtG objG3,,objG3.gVier,objG4
o class@TstCsvExtG G2,g2gDrei,,objG3
b TstCsvExtH class@TstCsvExtH,
m metEins method@metEins,call a b,c,"d e",
c TstCsvExtH class@TstCsvExtH,u v,f rr r o,f rH r class@TstCsvExtH,+
method@metEins
f class@TstCsvExtH H5,
d class@TstCsvExtH H9,H9value,objG3,H5
d class@TstCsvExtH H8,H8value rrWText,!escText,H9
d class@TstCsvExtH H7,H7value rrText,!textli,H8
d class@TstCsvExtH h6,h6-value6 rrLeer,,H7
o class@TstCsvExtH H5,h5Value,o1,h6
$/tstCsvExt/
*/
call jIni
call tst t, "tstCsvExt"
m = 'TST_CsvExt'
call csvExtBegin m
m.o.0 = 0
cF = classNew('n? TstCsvExtF u f FEINS v, f FZWEI v')
cG = classNew('n? TstCsvExtG u f gDrei v, f GVIER v, f gRef r')
cH = class4Name('TstCsvExtH', '-')
if cH == '-' then do
cH = classNew('n TstCsvExtH u')
cH = classNew('n= TstCsvExtH u v, f rr r, f rH r TstCsvExtH',
, 'm metEins call a b,c,"d e",')
end
do cx=1 to m.ch.0 until m.cy == 'm'
cy = m.cH.cx
end
call mAdd t.trans, cF 'class@TstCsvExtF', cG 'class@TstCsvExtG' ,
, cH 'class@TstCsvExtH', cY 'method@'m.cy.name
call csvExt m, o, 'string eins, oder nicht?'
call csvExt m, o
call csvExt m, o, s2o('string_W zwei, usw,,,|')
call csvExt m, o, csv2o('o1',cF, 'f1Feins,"f1,fzwei "')
call csvExt m, o, csv2o(g2, cG, 'g2gDrei,',
|| ','csv2o('objG3', cG, ',objG3.gVier',
|| ','csv2o('objG4', cG, 'objG4gDrei,objG4.gVier,objG4')))
call csvExt m, o, csv2o(h5, cH, 'h5Value,o1',
|| ','csv2o('h6', cH, 'h6-value6 rrLeer,',
|| ','csv2o(h7, cH, 'H7value rrText,textli',
|| ','csv2o(h8, cH, 'H8value rrWText,!escText',
|| ','csv2o(h9, cH, 'H9value,objG3,H5')))))
call outSt o
call tstEnd t
return
endProcedure tstCSVExt
tstCsvV2F: procedure expose m.
/*
$=/tstCsvV2F/
### start tst tstCsvV2F ###########################################
abcd
abcde
abcd&
ef
abc |
abcd&
. |
abcd&
e |
abc&|
abcd&
||
abcd&
e&|
abcd&
efgh
abcd&
efghi
abcd&
efgh&
ij
abcd&
efgh&
ij |
abcd&
efgh&
ijk&|
abcd&
efgh&
ijkl&
||
* f2v
abcd
abcde
abcdef
abc .
abcd .
abcde .
abc&
abcd|
abcde&
abcdefgh
abcdefghi
abcdefghij
abcdefghij .
abcdefghijk&
abcdefghijkl|
* f2v zwei
begin zwei
*** err: csvF2vEnd but strt='drei '
$/tstCsvV2F/
*/
call jIni
call tst t, "tstCsvV2F"
m = 'TST_csvV2F'
call csvV2FBegin m, 5
m.o.0 = 0
call mAdd mCut(i1, 0), 'abcd' ,
, 'abcde' ,
, 'abcdef' ,
, 'abc ' ,
, 'abcd ' ,
, 'abcde ' ,
, 'abc&' ,
, 'abcd|' ,
, 'abcde&' ,
, 'abcdefgh' ,
, 'abcdefghi' ,
, 'abcdefghij' ,
, 'abcdefghij ' ,
, 'abcdefghijk&' ,
, 'abcdefghijkl|'
do ix=1 to m.i1.0
call csvV2F m, o, m.i1.ix
end
call outSt o
call tstOut t, '* f2v'
m.p.0 = 0
call csvF2VBegin m
do ox=1 to m.o.0
call csvF2V m, p, m.o.ox || left(' ', ox // 3)
end
call csvF2VEnd m
call outSt p
call tstOut t, '* f2v zwei'
call mAdd mCut(o2, 0), 'begin zwei', 'drei &'
call csvF2VBegin m
call csvF2V m, mCut(p, 0), m.o2.1
call csvF2V m, p, m.o2.2
call outSt p
call csvF2VEnd m
call tstEnd t
say 'test with 1sRdr'
call tst t, "tstCsvV2F"
b1 = jBuf()
call mAddSt b1'.BUF', i1
call jIni
j1s = csvV2FRdr(b1, 5)
call jWriteAll t, j1s
call tstOut t, '* f2v'
call mAddSt mCut(b1'.BUF', 0), o
j1s = CsvF2VRdr(b1)
call jWriteAll t, j1s
call tstOut t, '* f2v zwei'
call mAddSt mCut(b1'.BUF', 0), o2
j1s = CsvF2VRdr(b1)
call jWriteAll t, j1s
call tstEnd t
return
endProcedure tstCsvV2F
tstCsvInt: procedure expose m.
/*
$=/tstCsvInt/
### start tst tstCsvInt ###########################################
wie geht es, "Dir", denn? .
tstR: @ obj null
wie geht es, "Dir", denn? class_W .
tstR: @tstWriteoV1 isA :TstCsvIntF*2
tstR: .FEINS = f1Feins
tstR: .FZWEI = f1,fzwei .
tstR: @tstWriteoV3 isA :TstCsvIntG*4 = o4Value
tstR: .R1 refTo @tstWriteoV5 :TstCsvIntG*4 = o3Value
tstR: .R1 refTo @tstWriteoV3 done :TstCsvIntG*4 @tstWriteoV3
tstR: @tstWriteoV5 isA :TstCsvIntG*4 = o3Value
tstR: .R1 refTo @tstWriteoV3 :TstCsvIntG*4 = o4Value
tstR: .R1 refTo @tstWriteoV5 done :TstCsvIntG*4 @tstWriteoV5
metEins=call out o, "calling metEins" m.m.R1
$/tstCsvInt/
*/
call jIni
call tst t, "tstCsvInt"
i = 'TST_csvInt'
call csvIntBegin i
call csvInt i, mCut(o, 0), 'v,wie geht es, "Dir", denn? '
call csvInt i, o, 'v,'
call csvInt i, o, 'w,wie geht es, "Dir", denn? class_W '
call csvInt i, o, 'c TstCsvIntF ClassIF,u f FEINS v,f FZWEI v'
call csvInt i, o, 'o ClassIF o1,f1Feins,"f1,fzwei "'
call csvInt i, o, 'b TstCsvIntG ClassIG'
call csvInt i, o, 'm metEins adrM1,call out o,' ,
'"calling metEins" m.m.R1'
call csvInt i, o, 'c TstCsvIntG ClassIG,u v, f R1 r ClassIG, adrM1'
call csvInt i, o, 'f ClassIG o4,'
call csvInt i, o, 'd ClassIG o3,o3Value,o4'
call csvInt i, o, 'o ClassIG o4,o4Value,o3'
call csvInt i, o, 'r o3,'
do ox=1 to m.o.0
call tstTransOc t, m.o.ox
end
call outSt o
ox = m.o.0
call out 'metEins='objMet(m.o.ox, 'metEins')
call tstEnd t
return
endProcedure tstCsvInt
tstFUnit: procedure
/*
$=/tstFUnit/
### start tst tstFUnit ############################################
. 1 ==> 1 =-> -1 =+> +1 =b> 1 .
. 5 ==> 5 =-> -5 =+> +5 =b> 5 .
. 13 ==> 13 =-> -13 =+> +13 =b> 13 .
. 144 ==> 144 =-> -144 =+> +144 =b> 144 .
. 1234 ==> 1234 =-> -1k =+> +1234 =b> 1234 .
. 7890 ==> 7890 =-> -8k =+> +7890 =b> 7890 .
. 0 ==> 0 =-> 0 =+> +0 =b> 0 .
. 234E3 ==> 234k =-> -234k =+> +234k =b> 229k
. 89E6 ==> 89M =-> -89M =+> +89M =b> 85M
. 123E9 ==> 123G =-> -123G =+> +123G =b> 115G
. 4567891E9 ==> 4568T =-> -5P =+> +4568T =b> 4154T
. 0.123 ==> 123m =-> -123m =+> +123m =b> 0 .
. 0.0000456789 ==> 46u =-> -46u =+> +46u =b> 0 .
. 345.567E-12 ==> 346p =-> -346p =+> +346p =b> 0 .
. 123.4567E-15 ==> 123f =-> -123f =+> +123f =b> 0 .
. ABC ==> ABC =-> -ABC =+> ABC =b> ABC
ABCDEFGHIJKLMN ==> JKLMN =-> JKLMN =+> IJKLMN =b> JKLMN
. 1E77 ==> +++++ =-> -++++ =+> ++++++ =b> +++++.
. 1E-77 ==> 0a =-> -0a =+> +0a =b> 0 .
. 18.543E18 ==> 19E =-> -19E =+> +19E =b> 16E
. 20.987E20 ==> 2099E =-> -++++ =+> +2099E =b> 1820E
. 1 ==> 1.000 =-> -1.000 =+> +1.000 =b> 1.000 .
. 5 ==> 5.000 =-> -5.000 =+> +5.000 =b> 5.000 .
. 13 ==> 13.000 =-> -0.013k =+> +0.013k =b> 13.000 .
. 144 ==> 0.144k =-> -0.144k =+> +0.144k =b> 0.141k
. 1234 ==> 1.234k =-> -1.234k =+> +1.234k =b> 1.205k
. 7890 ==> 7.890k =-> -7.890k =+> +7.890k =b> 7.705k
. 0 ==> 0.000 =-> 0.000 =+> +0.000 =b> 0.000 .
. 234E3 ==> 0.234M =-> -0.234M =+> +0.234M =b> 0.223M
. 89E6 ==> 89.000M =-> -0.089G =+> +0.089G =b> 84.877M
. 123E9 ==> 0.123T =-> -0.123T =+> +0.123T =b> 0.112T
. 4567891E9 ==> 4.568P =-> -4.568P =+> +4.568P =b> 4.057P
. 0.123 ==> 0.123 =-> -0.123 =+> +0.123 =b> 0.123 .
. 0.0000456789 ==> 45.679u =-> -0.046m =+> +0.046m =b> 0.000 .
. 345.567E-12 ==> 0.346n =-> -0.346n =+> +0.346n =b> 0.000 .
. 123.4567E-15 ==> 0.123p =-> -0.123p =+> +0.123p =b> 0.000 .
. ABC ==> ABC =-> -ABC =+> ABC =b> ABC
ABCDEFGHIJKLMN ==> HIJKLMN =-> HIJKLMN =+> HIJKLMN =b> HIJKLMN
. 1E77 ==> +++++++ =-> -++++++ =+> +++++++ =b> +++++++.
. 1E-77 ==> 0.000a =-> -0.000a =+> +0.000a =b> 0.000 .
. 18.543E18 ==> 18.543E =-> -++++++ =+> +++++++ =b> 16.083E
. 20.987E20 ==> +++++++ =-> -++++++ =+> +++++++ =b> +++++++.
$/tstFUnit/
$=/tstFUnitT/
### start tst tstFUnitT ###########################################
. .3 ==> 0s30 ++> 0s30 -+> -0s30 --> -0s30
. .8 ==> 0s80 ++> 0s80 -+> -0s80 --> -0s80
. 1 ==> 1s00 ++> 1s00 -+> -1s00 --> -1s00
. 1.2 ==> 1s20 ++> 1s20 -+> -1s20 --> -1s20
. 59 ==> 59s00 ++> 59s00 -+> -0m59 --> -59s00
. 59.07 ==> 59s07 ++> 59s07 -+> -0m59 --> -59s07
. 59.997 ==> 1m00 ++> 1m00 -+> -1m00 --> -1m00
. 60 ==> 1m00 ++> 1m00 -+> -1m00 --> -1m00
. 60.1 ==> 1m00 ++> 1m00 -+> -1m00 --> -1m00
. 611 ==> 10m11 ++> 10m11 -+> -0h10 --> -10m11
. 3599.4 ==> 59m59 ++> 59m59 -+> -1h00 --> -59m59
. 3599.5 ==> 1h00 ++> 1h00 -+> -1h00 --> -1h00
. 3661 ==> 1h01 ++> 1h01 -+> -1h01 --> -1h01
. 83400 ==> 23h10 ++> 23h10 -+> -0d23 --> -23h10
. 84700 ==> 23h32 ++> 23h32 -+> -1d00 --> -23h32
. 86400 ==> 1d00 ++> 1d00 -+> -1d00 --> -1d00
. 89900 ==> 1d01 ++> 1d01 -+> -1d01 --> -1d01
. 8467200 ==> 98d00 ++> 98d00 -+> -98d --> -98d00
. 8595936.00 ==> 99d12 ++> 99d12 -+> -99d --> -99d12
. 8638704.00 ==> 100d ++> 100d -+> -100d --> -100d
. 8640000 ==> 100d ++> 100d -+> -100d --> -100d
. 863913600 ==> 9999d ++> 9999d -+> -++++ --> -9999d
. 863965440 ==> +++++ ++> +++++ -+> -++++ --> -+++++.
. 8.6400E+9 ==> +++++ ++> +++++ -+> -++++ --> -+++++.
$/tstFUnitT/ */
call jIni
call tst t, "tstFUnit"
numeric digits 9
d = 86400
lst = 1 5 13 144 1234 7890 0 234e3 89e6 123e9,
4567891e9 0.123 0.0000456789 345.567e-12 123.4567e-15 ,
abc abcdefghijklmn 1e77 1e-77 18.543e18 20.987e20
do wx=1 to words(lst)
call tstOut t, right(word(lst, wx), 14) ,
'==>' fUnit('d' , word(lst, wx)),
'=->' fUnit('d' , '-'word(lst, wx)),
'=+>' fUnit('d¢+', word(lst, wx)),
'=b>' fUnit('b' , word(lst, wx))
end
do wx=1 to words(lst)
call tstOut t, right(word(lst, wx), 14) ,
'==>' fUnit('d7.3' , word(lst, wx)),
'=->' fUnit('d7.3' , '-'word(lst, wx)),
'=+>' fUnit('d7.3¢+', word(lst, wx)),
'=b>' fUnit('b7.3' , word(lst, wx))
end
call tstEnd t
call tst t, "tstFUnitT"
d = 86400
lst = .3 .8 1 1.2 59 59.07 59.997 60 60.1 611 ,
3599.4 3599.5 3661 d-3000 d-1700 d d+3500 ,
d * 98 d * 99.49 d * 99.985 d*100 d * 9999 d * 9999.6 ,
d * 1e5
do wx=1 to words(lst)
call tstOut t, right(word(lst, wx), 14) ,
'==>' fUnit('t' , word(lst, wx)),
'++>' fUnit('t¢ ', word(lst, wx)),
'-+>' fUnit('t' , '-'word(lst, wx)),
'-->' fUnit('t¢ ', '-'word(lst, wx))
end
call tstEnd t
return
endProcedure tstFUnit
tstSb: procedure expose m.
/*
$=/tstSb/
### start tst tstSb ###############################################
end : 0
char 3 : 1 abc
lit d? : 0 .
lit de : 1 de
lit de ? fg fgh: 1 fg
while HIJ : 0 .
end : 0
while Jih : 1 hi
while ? klj: 1 jklkl ?
end : 1
while ? klj: 0 .
char 3 : 0 .
lit : 0 .
until cba : 0 .
until ?qd : 1 abc
until ?qr : 1 defdef .
until ?qr : 0 .
strEnd ? : 1 ?
strEnd ? : 0 ?
strEnd ? : 1 ab??cd????gh?
strEnd ") ": 1 ab) .
strEnd ") ": 1 ab) cd) ) gh) .
string : 1 'eins?''' v=eins?'
space : 1 >
string : 1 "zwei""" v=zwei"
string ? : 1 ?drei??? v=drei?
*** err: scanErr ending Apostroph missing
. e 1: last token " scanPosition noEnd
. e 2: pos 28 in string 'eins?''' "zwei"""?drei???"noEnd
string : 0 " v=noEnd
$/tstSb/ */
call pipeIni
call tst t, 'tstSb'
call scanSrc s, 'abcdefghijklkl ?'
call out 'end :' scanEnd(s)
call out 'char 3 :' scanChar(s, 3) m.s.tok
call out 'lit d? :' scanLit(s, 'd?') m.s.tok
call out 'lit de :' scanLit(s, 'de') m.s.tok
call out 'lit de ? fg fgh:',
scanLit(s, 'de', '?', 'fg', 'fgh') m.s.tok
call out 'while HIJ :' scanWhile(s, 'HIJ') m.s.tok
call out 'end :' scanEnd(s)
call out 'while Jih :' scanWhile(s, 'Jih') m.s.tok
call out 'while ? klj:' scanWhile(s, '? klj') m.s.tok
call out 'end :' scanEnd(s)
call out 'while ? klj:' scanWhile(s, '? klj') m.s.tok
call out 'char 3 :' scanChar(s, 3) m.s.tok
call out 'lit :' scanLit(s) m.s.tok
call scanSrc s, 'abcdefdef ?'
call out 'until cba :' scanUntil(s, 'cba') m.s.tok
call out 'until ?qd :' scanUntil(s, '?qd') m.s.tok
call out 'until ?qr :' scanUntil(s, '?qr') m.s.tok
call out 'until ?qr :' scanUntil(s, '?qr') m.s.tok
call out 'strEnd ? :' scanStrEnd(s, '?') m.s.tok
call out 'strEnd ? :' scanStrEnd(s, '?') m.s.tok
call scanSrc s, 'ab??cd????gh?ijk'
call out 'strEnd ? :' scanStrEnd(s, '?') m.s.tok
call scanSrc s, 'ab) cd) ) gh) jk) )'
call out 'strEnd ") ":' scanStrEnd(s, ') ') m.s.tok
call out 'strEnd ") ":' scanStrEnd(s, ') ') m.s.tok
call scanSrc s, "'eins?'''" '"zwei"""?drei???"noEnd'
call out 'string :' scanString(s) m.s.tok 'v='m.s.val
call out 'space :' scanWhile(s, ' ') m.s.tok'>'
call out 'string :' scanString(s) m.s.tok 'v='m.s.val
call out 'string ? :' scanString(s, '?') m.s.tok 'v='m.s.val
call out 'string :' scanString(s) m.s.tok 'v='m.s.val
call tstEnd t
return
endProcedure tstSb
tstSb2: procedure expose m.
/*
$=/tstSb2/
### start tst tstSb2 ##############################################
end : 0
char 3 : 1 abc
lit d? : 0 .
lit de : 1 de
lit de ? fg fgh: 1 fg
while HIJ : 0 .
end : 0
while Jih : 1 hi
while ? klj: 1 jklkl ?
end : 1
while ? klj: 0 .
char 3 : 0 .
lit : 0 .
until cba : 0 .
until ?qd : 1 abc
until ?qr : 1 defdef .
until ?qr : 0 .
strEnd ? : 1 ?
strEnd ? : 0 ?
strEnd ? : 1 ab??cd????gh?
strEnd ") ": 1 ab) .
strEnd ") ": 1 ab) cd) ) gh) .
$/tstSb2/ */
call pipeIni
call tst t, 'tstSb2'
call scanSrc s, 'abcdefghijklkl ?'
call out 'end :' scanEnd(s)
call out 'char 3 :' scanChar(s, 3) m.s.tok
call out 'lit d? :' scanLit(s, 'd?') m.s.tok
call out 'lit de :' scanLit(s, 'de') m.s.tok
call out 'lit de ? fg fgh:',
scanLit(s, 'de', '?', 'fg', 'fgh') m.s.tok
call out 'while HIJ :' scanWhile(s, 'HIJ') m.s.tok
call out 'end :' scanEnd(s)
call out 'while Jih :' scanWhile(s, 'Jih') m.s.tok
call out 'while ? klj:' scanWhile(s, '? klj') m.s.tok
call out 'end :' scanEnd(s)
call out 'while ? klj:' scanWhile(s, '? klj') m.s.tok
call out 'char 3 :' scanChar(s, 3) m.s.tok
call out 'lit :' scanLit(s) m.s.tok
call scanSrc s, 'abcdefdef ?'
call out 'until cba :' scanUntil(s, 'cba') m.s.tok
call out 'until ?qd :' scanUntil(s, '?qd') m.s.tok
call out 'until ?qr :' scanUntil(s, '?qr') m.s.tok
call out 'until ?qr :' scanUntil(s, '?qr') m.s.tok
call out 'strEnd ? :' scanStrEnd(s, '?') m.s.tok
call out 'strEnd ? :' scanStrEnd(s, '?') m.s.tok
call scanSrc s, 'ab??cd????gh?ijk'
call out 'strEnd ? :' scanStrEnd(s, '?') m.s.tok
call scanSrc s, 'ab) cd) ) gh) jk) )'
call out 'strEnd ") ":' scanStrEnd(s, ') ') m.s.tok
call out 'strEnd ") ":' scanStrEnd(s, ') ') m.s.tok
call tstEnd t
return
endProcedure tstSb2
tstScan: procedure expose m.
/*
$=/tstScan.1/
### start tst tstScan.1 ###########################################
scan src a034,Und hr123sdfER"st1" 'str2''mit''apo''s' .
scan n tok 4: a034 key val .
scan , tok 1: , key val .
scan n tok 3: Und key val .
scan v tok 1: key val .
scan n tok 10: hr123sdfER key val .
scan q tok 5: "st1" key val st1
scan v tok 1: key val st1
scan a tok 19: 'str2''mit''apo''s' key val str2'mit'apo's
scan v tok 1: key val str2'mit'apo's
$/tstScan.1/ */
call tst t, 'tstScan.1'
call tstScan1 'l"litEins"l"litZwei"ndv" "aq1' ,
,"a034,Und hr123sdfER""st1"" 'str2''mit''apo''s' "
call tstEnd t
/*
$=/tstScan.2/
### start tst tstScan.2 ###########################################
scan src a034,Und hr123sdfER"st1" 'str2''mit''apo''s' .
scan n tok 4: a034 key val .
scan , tok 1: , key val .
scan n tok 3: Und key val .
scan b tok 1: key val .
scan n tok 10: hr123sdfER key val .
scan " tok 5: "st1" key val st1
scan b tok 1: key val st1
scan ' tok 19: 'str2''mit''apo''s' key val str2'mit'apo's
scan b tok 1: key val str2'mit'apo's
$/tstScan.2/ */
call tst t, 'tstScan.2'
call tstScan1 'ndsb1' ,
,"a034,Und hr123sdfER""st1"" 'str2''mit''apo''s' "
call tstEnd t
/*
$=/tstScan.3/
### start tst tstScan.3 ###########################################
scan src a034,'wie 789abc
scan n tok 4: a034 key val .
scan , tok 1: , key val .
*** err: scanErr ending Apostroph missing
. e 1: last token ' scanPosition wie 789abc
. e 2: pos 7 in string a034,'wie 789abc
scan w tok 1: w key val wie 789abc
scan n tok 2: ie key val wie 789abc
scan s tok 1: key val wie 789abc
*** err: scanErr illegal char after number 789
. e 1: last token 789 scanPosition abc
. e 2: pos 14 in string a034,'wie 789abc
scan d tok 3: 789 key val wie 789abc
scan n tok 3: abc key val wie 789abc
$/tstScan.3/ */
call tst t, 'tstScan.3'
call tstScan1 'nds1' ,
,"a034,'wie 789abc"
call tstEnd t
/*
$=/tstScan.4/
### start tst tstScan.4 ###########################################
scan src litEinsefr 23 sdfER'str1'litZwei "str2""mit quo"s .
scan l tok 7: litEins key val .
scan n tok 3: efr key val .
scan b tok 1: key val .
scan d tok 2: 23 key val .
scan b tok 1: key val .
scan n tok 5: sdfER key val .
scan a tok 6: 'str1' key val str1
scan l tok 7: litZwei key val str1
scan b tok 1: key val str1
scan q tok 15: "str2""mit quo" key val str2"mit quo
scan n tok 1: s key val str2"mit quo
scan b tok 1: key val str2"mit quo
$/tstScan.4/ */
call tst t, 'tstScan.4'
call tstScan1 'l"litEins"l"litZwei"ndbaq1' ,
,"litEinsefr 23 sdfER'str1'litZwei ""str2""""mit quo""s "
call tstEnd t
/*
$=/tstScan.5/
### start tst tstScan.5 ###########################################
scan src aha q3 = f ab=cdEf eF='strIng' .
scan s tok 1: key val .
scan k tok 0: key aha val def
scan k tok 1: f key q3 val f
scan s tok 1: key q3 val f
scan k tok 4: cdEf key ab val cdEf
scan s tok 1: key ab val cdEf
scan k tok 8: 'strIng' key eF val strIng
scan s tok 1: key eF val strIng
$/tstScan.5/ */
call tst t, 'tstScan.5'
call tstScan1 'k1'," aha q3 = f ab=cdEf eF='strIng' "
call tstEnd t
return
endProcedure tstScan
/*--- one single test scan with lines to scan in stem ln ------------*/
tstScan1:
parse arg classs, ln
call tstOut t, 'scan src' ln
call scanSrc scanOpt(s), ln
m.s.key = ''
m.s.val = ''
do forever
x = tstScanType(s, classs)
if x == '' then
leave
call tstOut t, 'scan' x 'tok' length(m.s.tok)':' m.s.tok ,
'key' m.s.key 'val' m.s.val
end
return
endProcedure tstScan1
tstScanType: procedure expose m.
parse arg s, opt
cx = 1
a2 = ''
res = 0
do while cx <= length(opt)
f = substr(opt, cx, 1)
cx = cx + 1
if pos(substr(opt, cx, 1), "'""") > 0 then do
m.tstScanType.src = opt
m.tstScanType.pos = cx
call scanString tstScanType
a2 = m.tstScanType.val
cx = m.tstScanType.pos
end
if f == 'a' then
res = scanString(s, "'")
else if f == 'b' then
res = scanSpace(s)
else if f == 'c' then
res = scanChar(s, a2)
else if f == 'd' then
if a2 == 0 then
res = scanNatIA(s)
else
res = scanNat(s)
else if f == 'k' then
res = scanKeyValue(s, 'def')
else if f == 'l' then
res = scanLit(s, a2)
else if f == 'q' then
res = scanString(s, '"')
else if f == 'v' then
res = scanVerify(s, a2)
else if f == 'w' then
res = scanWord(s)
else if f == 'y' then
res = scanVerify(s, a2, 'm')
if res then
return f
end
return scanType(s)
endProcedure tstScanType
tstScanRead: procedure expose m.
/*
$=/tstScanRead/
### start tst tstScanRead #########################################
name erste
space
name Zeile
nextLine
nextLine
space
name dritte
space
name Zeile
space
name schluss
$/tstScanRead/ */
call scanReadIni
call tst t, 'tstScanRead'
b = jBuf('erste Zeile ',,' dritte Zeile schluss ')
s = jOpen(jReset0(scanRead(b)), m.j.cRead)
do while \scanEnd(s)
if scanName(s) then call tstOut t, 'name' m.s.tok
else if scanVerify(s, ' ') then call tstOut t, 'space'
else if scanReadNL(s) then call tstOut t, 'nextLine'
else if \scanEnd(s) then call scanErr s, 'cannot scan'
end
call jClose s
call tstEnd t
/*
$=/tstScanReadMitSpaceLn/
### start tst tstScanReadMitSpaceLn ###############################
name erste
spaceLn
name Zeile
spaceLn
name dritte
spaceLn
name Zeile
spaceLn
name schluss
$/tstScanReadMitSpaceLn/ */
call tst t, 'tstScanReadMitSpaceLn'
s = scanReadOpen(scanRead(b))
do forever
if scanName(s) then call out 'name' m.s.tok
else if scanSpace(s) then call out 'spaceLn'
else if \scanEnd(s) then call scanErr s, 'cannot scan'
else leave
end
call scanReadClose s
call tstEnd t
/*
$=/tstScanJRead/
### start tst tstScanJRead ########################################
1 jRead n tok erste val .
2 jRead s tok val .
3 jRead n tok Zeile val .
4 jRead s tok val .
5 jRead n tok dritte val .
6 jRead s tok val .
7 jRead n tok Zeile val .
8 jRead s tok val .
9 jRead n tok schluss val .
10 jRead s tok val .
11 jRead 0 tok 1 val 1
12 jRead s tok val 1
13 jRead + tok + val 1
14 jRead s tok val 1
15 jRead 0 tok 2. val 2..
16 jRead s tok val 2..
17 jRead + tok + val 2..
18 jRead . tok . val 2..
19 jRead s tok val 2..
20 jRead 0 tok +.3 val +.3
21 jRead 0 tok -45e-3 val -45E-3
22 jRead s tok val -45E-3
23 jRead " tok "a""b" val a"b
24 jRead s tok val a"b
25 jRead ' tok 'c''d' val c'd
className 1: ScanRes 18: ScanRes
$/tstScanJRead/ */
call tst t, 'tstScanJRead'
call jWrite jOpen(b,'>>'), '1 + 2. +. +.3-45e-3 "a""b"' "'c''d'"
s = jOpen(jReset0(scanRead(jClose(b))), '<')
do x=1 while jRead(s)
v = m.s
call out x 'jRead' m.v.type 'tok' m.v.tok 'val' m.v.val
v.x = v
end
call jClose s
call out 'className 1:' className(objClass(v.1)),
'18:' className(objClass(v.18))
call tstEnd t
/*
$=/tstScanReadPos/
### start tst tstScanReadPos ######################################
1
2
345678
4
5678
4
$/tstScanReadPos/ */
call tst t, 'tstScanReadPos'
b = jBuf(1, 2, 345678, 4)
call scanReadOpen scanReadReset(scanOpt(tstScn), b)
do while scanNat(scanSkip(tstScn))
call tstOut t, m.tstScn.tok
end
call scanSetPos tstScn, 3 3
do while scanNat(scanSkip(tstScn))
call tstOut t, m.tstScn.tok
end
call tstEnd t
return
endProcedure tstScanRead
tstScanUtilInto: procedure expose m.
/*
$=/tstScanUtilIntoL/
TEMPLATE P3
DSN('DBAF.DA540769.A802A.P00003.BV5I3NRN.REC')
DISP(OLD,KEEP,KEEP)
TEMPLATE P4
DSN('DBAF.DA540769.A802A.P00004.BV5I3NTK.REC')
DISP(OLD,KEEP,KEEP)
LOAD DATA LOG NO RESUME NO REPLACE COPYDDN(TCOPYD)
STATISTICS INDEX(ALL) REPORT NO UPDATE ALL
EBCDIC CCSID(00500,00000,00000)
SORTKEYS
-- ENFORCE NO
SORTDEVT DISK
SORTNUM 160
WORKDDN(TSYUTD,TSOUTD)
INTO TABLE OA1P.TWB981 PART 1 INDDN TREC134
WORKDDN(TSYUTS,TSOUTS)
INTO TABLE "A540769"
."TWK802A1"
PART 00001 INDDN P0
WHEN(00001:00002) = X'0041'
( "DE1"
POSITION( 00003:00010) DECIMAL
, "CH2"
POSITION( 00011:00015) CHAR(00005)
, "TS3"
POSITION( 00016:00041) TIMESTAMP EXTERNAL
, "TI4"
POSITION( 00042:00049) TIME EXTERNAL
, "DA5"
POSITION( 00050:00059) DATE EXTERNAL
, "IN6"
POSITION( 00060:00063) INTEGER
, "RE7"
POSITION( 00064:00067) FLOAT(21)
)
INTO TABLE "A540769"."TWK802A1"
PART 00002 INDDN P0
WHEN(00001:00002) = X'0041'
( "DE1"
POSITION( 00003:00010) DECIMAL
, "CH2"
POSITION( 00011:00015) CHAR(00005)
)
dobido
$/tstScanUtilIntoL/
$=/tstScanUtilInto/
### start tst tstScanUtilInto #####################################
-- 1 scanUtilInto
. ( "DE1"
. POSITION( 00003:00010) DECIMAL
. , "CH2"
. POSITION( 00011:00015) CHAR(00005)
. , "TS3"
. POSITION( 00016:00041) TIMESTAMP EXTERNAL
. , "TI4"
. POSITION( 00042:00049) TIME EXTERNAL
. , "DA5"
. POSITION( 00050:00059) DATE EXTERNAL
. , "IN6"
. POSITION( 00060:00063) INTEGER
. , "RE7"
. POSITION( 00064:00067) FLOAT(21)
. ) .
. -- table OA1P.TWB981 part 00001
-- 2 scanUtilInto
. ( "DE1"
. POSITION( 00003:00010) DECIMAL
. , "CH2"
. POSITION( 00011:00015) CHAR(00005)
. ) .
. -- table A540769.TWK802A1 part 00002
-- 3 scanUtilInto
$/tstScanUtilInto/ */
call scanReadIni
b = jBuf()
call mAddst b'.BUF', mapInline('tstScanUtilIntoL')
call tst t, 'tstScanUtilInto'
s = jOpen(jReset0(scanUtilOpt(ScanRead(b))), '<')
do ix=1
call out '--' ix 'scanUtilInto'
if \ scanUtilInto(s) then
leave
call out ' -- table' m.s.tb 'part' m.s.part
end
call tstEnd t
return
endProcedure tstSCanUtilInto
tstScanWin: procedure expose m.
/*
$=/tstScanWin/
### start tst tstScanWin ##########################################
info 0: last token scanPosition erste Zeile dr+
itteZe\npos 1 in line 1: erste Zeile
name erste
spaceNL
name Zeile
spaceNL
name dritteZeeeile
info 5: last token dritteZeeeile scanPosition zeile4 +
. fuenfueberSechs\npos 1 in line 4: zeile4
spaceNL
name zeile4
spaceNL
name fuenfueberSechsUnddSiebenUNDundUndUAcht
spaceNL
info 10: last token scanPosition undZehnueberElfundNochWeiterZwoe+
lfundim1\npos 9 in line 10: undZehn
name undZehnueberElfundNochWeiterZwoelfundim13
spaceNL
name Punkt
infoE 14: last token Punkt scanPosition \natEnd after line 13: im13+
. Punkt
$/tstScanWin/ */
call scanWinIni
call tst t, 'tstScanWin'
b = jBuf('?erste Zeile?',,'? dritteZeeeile?', '? zeile4 ',
,'? fuenf?', '?ueberSechsUnddS?', '?iebenUNDundUndU?',
,'?Acht ?', '? ?', '? undZehn?',
,'?ueberElfundNoch?', '?WeiterZwoelfund?', '?im13 Punkt?')
s = jOpen(jReset0(scanWin(b, '15@2')), m.j.cRead)
call tstOut t, 'info 0:' scanInfo(s)
do sx=1 while \scanEnd(s)
if scanSpace(s) then call tstOut t, 'spaceNL'
else if scanName(s) then call tstOut t, 'name' m.s.tok
else if \scanEnd(s) then call scanErr s, 'cannot scan'
if sx // 5 = 0 then
call tstOut t, 'info' sx':' scanInfo(s)
end
call tstOut t, 'infoE' sx':' scanInfo(s)
call tstEnd t
/*
$=/tstScanWinRead/
### start tst tstScanWinRead ######################################
info 0: last token scanPosition erste Zeile z3 +
com Ze\npos 1 in line 1: erste Zeile
name erste
spaceNL
name Zeile
spaceNL
name z3
info 5: last token z3 scanPosition com Zeeeile z4 come4 f+
uenf\npos 4 in line 3: z3 com Zeeeile
spaceNL
name z4
spaceNL
name fuenf
spaceNL
info 10: last token scanPosition com Sechs com sieben comA+
cht com\npos 15 in line 5: fuenf c
name com
spaceNL
name Sechs
spaceNL
name com
info 15: last token com scanPosition sieben comAcht com com +
. com\npos 2 in line 7: m sieben com
spaceNL
name sieben
spaceNL
name Acht
spaceNL
info 20: last token scanPosition ueberElfundNochWeit com elfundim+
13\npos 1 in line 11: ueberElfundNoch
name ueberElfundNochWeit
spaceNL
name im13
spaceNL
name Punkt
info 25: last token Punkt scanPosition \natEnd after line 13: im13 +
. Punkt
infoE 26: last token Punkt scanPosition \natEnd after line 13: im13+
. Punkt
$/tstScanWinRead/ */
call tst t, 'tstScanWinRead'
b = jBuf('?erste Zeile?',,'? z3 com Zeeeile?', '? z4 come4 ',
,'? fuenf c?', '?om Sechs co?', '?m sieben com?',
,'?Acht com com ?', '? com ?', '? com undZehn?',
,'?ueberElfundNoch?', '?Weit com elfund?', '?im13 Punkt?')
s = jReset0(scanWin(b, '15@2'))
call scanOpt s, , , 'com'
call tstOut t, 'info 0:' scanInfo(jOpen(s, m.j.cRead))
do sx=1 while \scanEnd(s)
if scanName(s) then call tstOut t, 'name' m.s.tok
else if scanSpace(s) then call tstOut t, 'spaceNL'
else if \scanEnd(s) then call scanErr s, 'cannot scan'
if sx // 5 = 0 then
call tstOut t, 'info' sx':' scanInfo(s)
end
call tstOut t, 'infoE' sx':' scanInfo(s)
call tstEnd t
/*
$=/tstScanWinPos/
### start tst tstScanWinPos #######################################
infoA1 1: last token 1 scanPosition 2 +
. 3\npos 2 in line 1: 1
1
2
345678
4
infoB1: last token scanPosition \natEnd after line 4: 4
infoC1: last token scanPosition 678 4\npos 4 in line+
. 3: 345678
678
4
infoA0 1: last token -2 scanPosition -1 -0 1 +
. 2\npos 3 in line -2: -2
-2
-1
-0
1
2
345678
4
infoB0: last token scanPosition \natEnd after line 4: 4
infoC0: last token scanPosition 5678 4\npos 3 in line 3: 345678
5678
4
$/tstScanWinPos/ */
call tst t, 'tstScanWinPos'
b = jBuf(1, 2, 345678, 4)
do ox=1 to 0 by -1
if ox then
s = scanWinOpen(scanWinReset(scanOpt(tstScn), b, 20))
else
s = scanWinOpen(scanWinReset(scanOpt(tstScn), b, 10),
,'-2 -1 -0')
do nx=1 while scanNum(scanSkip(s))
if nx = 1 then
call tstOut t, 'infoA'ox nx':' scanInfo(s)
call tstOut t, m.s.tok
end
call tstOut t, 'infoB'ox':' scanInfo(s)
call scanSetPos s, 3 3+ox
call tstOut t, 'infoC'ox':' scanInfo(s)
do while scanNat(scanSkip(s))
call tstOut t, m.s.tok
end
call scanClose s
end
call tstEnd t
return
endProcedure tstScanWin
tstScanSqlStmt: procedure expose m.
/*
$=/tstScanSqlStmt/
### start tst tstScanSqlStmt ######################################
cmd1 select current time stamp from s.1
cmd2 update ";--""'/*"
cmd3 delete '*/''"' / 3 - 1
cmd4 terminator test
cmd5 und so
cmd6 term: ist
cmd7 term> in com nein >
cmd8 .
$/tstScanSqlStmt/ */
call pipeIni
call scanWinIni
call tst t, 'tstScanSqlStmt'
b = jBuf('select -- /* c1', ' /* c1 */ current/* c2 " '' ',
,'c3"', ' c4 */time', 'stamp-- c5', 'from s.1; /* c6 */ ;' ,
,';update ";--""''/*";; del123',
, 'ete ''*/''''"'' / 3 - 1 -- c7', '/*c8 */ ' ,
, ';terminator test; ','terminator|; und-- ', 'so| | |',
, 'term: --#SET TERMINATOR : oder', 'ist: ',
, 'term> /*--#SET TERMINATOR > oder', ' */ in com nein >:')
call scanWinOpen scanSqlStmtOpt(scanWinReset(tstJcat, b, 30), ';')
call scanSqlOpt tstJcat
do sx=1 until nx = ''
nx = scanSqlStmt(tstJCat)
call tstOut t, 'cmd'sx nx
end
call scanReadCLose tstJCat
call tstEnd t
/*
$=/tstScanSqlStmtRdr/
### start tst tstScanSqlStmtRdr ###################################
cmd1 select current time stamp from s.1
cmd2 update ";--""'/*"
cmd3 delete '*/''"' / 3 - 1
cmd4 terminator test
cmd5 und so
cmd6 term: ist
cmd7 term> in com nein >
$/tstScanSqlStmtRdr/ */
call tst t, 'tstScanSqlStmtRdr'
r = jOpen(ScanSqlStmtRdr(b, 30), '<')
do sx=1 while jRead(r)
call tstOut t, 'cmd'sx m.r
end
call jClose r
call tstEnd t
return
endProcedure tstScanSqlStmt
tstScanSql: procedure expose m.
call scanWinIni
/*
$=/tstScanSqlId/
### start tst tstScanSqlId ########################################
sqlId ABC
spaceNL
sqlId AB__345EF
spaceNL
$/tstScanSqlId/ */
call tst t, 'tstScanSqlId'
b = jBuf('abc -- kommentar', right('ab_', 72), '_345ef-- kom')
s = scanOpen(scanSqlReset(tstScn, b))
do sx=1 while \scanEnd(s)
if scanSqlID(s) then call tstOut t, 'sqlId' m.s.val
else if scanSpace(s) then call tstOut t, 'spaceNL'
else call scanErr s, 'cannot scan'
end
call tstEnd t
/*
$=/tstScanSqlDelimited/
### start tst tstScanSqlDelimited #################################
sqlDeId ABC
spaceNL
sqlDeId AB_3F
spaceNL
sqlDeId abc
spaceNL
sqlDeId ab_Ef
spaceNL
$/tstScanSqlDelimited/ */
call tst t, 'tstScanSqlDelimited'
b =jBuf('abc -- kommentar',,' -- ',,right('ab_', 72),'3F-- kom',
, '"abc" -- ko', ' -- ',,right('"ab_', 72),'Ef"-- kom')
s = scanOpen(scanSqlReset(tstScn, b))
do sx=1 while \scanEnd(s)
if scanSqlDeID(s) then call tstOut t, 'sqlDeId' m.s.val
else if scanSpace(s) then call tstOut t, 'spaceNL'
else call scanErr s, 'cannot scan'
end
call tstEnd t
/*
$=/tstScanSqlQualified/
### start tst tstScanSqlQualified #################################
sqlQuId ABC 1 ABC
sqlQuId AB_3F 1 AB_3F
sqlQuId abc 1 abc
sqlQuId ab_Ef 1 ab_Ef
sqlQuId EINS.Zwei.DREI 3 EINS
sqlQuId vi er.fu enf 2 vi er
$/tstScanSqlQualified/ */
call tst t, 'tstScanSqlQualified'
b =jBuf('abc -- kommentar',,' -- ',,right('ab_', 72),'3F-- kom',
, '"abc" -- ko', ' -- ',right('"ab_', 72),'Ef"-- kom',
, 'eins."Zwei', '" -- com', ' . -- com', ' -- com',
, 'drei -- ko', '"vi er"."fu enf " -- co')
s = scanOpen(scanSqlReset(tstScn, b))
do sx=1 while \scanEnd(s)
if scanSqlQuID(s) then
call tstOut t, 'sqlQuId' m.s.val m.s.val.0 m.s.val.1
else if scanSpace(s) then call tstOut t, 'spaceNL'
else call scanErr s, 'cannot scan'
end
call tstEnd t
/*
$=/tstScanSqlNum/
### start tst tstScanSqlNum #######################################
sqlNum 1
spaceNL
sqlNum 2..
spaceNL
sqlNum .3
spaceNL
sqlNum 4.5
spaceNL
sqlNum +6
spaceNL
sqlNum +7.03
spaceNL
sqlNum -8
spaceNL
sqlNum -.9
spaceNL
sqlNum 1E2
spaceNL
sqlNum -2.E-2
spaceNL
sqlNum +.3E+3
spaceNL
$/tstScanSqlNum/ */
call tst t, 'tstScanSqlNum'
b =jBuf('1 2. .3 4.5 +6 + --kom', , ' -- com ', , ' 7.03 -8 - .9',
'1e2 - 2.e-2 + .3e+3')
s = scanOpen(scanSqlReset(tstScn, b))
do sx=1 while \scanEnd(s)
if scanSqlNum(s) then
call tstOut t, 'sqlNum' m.s.val
else if scanSpace(s) then call tstOut t, 'spaceNL'
else call scanErr s, 'cannot scan'
end
call tstEnd t
/*
$=/tstScanSqlNumUnit/
### start tst tstScanSqlNumUnit ###################################
sqlNumUnit 1 KB
spaceNL
sqlNumUnit .3 MB
sqlNumUnit .5
sqlNumUnit +6.E-5 B
spaceNL
sqlNumUnit -7
char *
spaceNL
sqlNumUnit -.8
char T
char B
spaceNL
*** err: scanErr bad unit TB after +9..
. e 1: last token Tb scanPosition .
. e 2: pos 41 in line 1: 1 kb .3mB.5 + 6.e-5B -7* -.8 TB + 9.T+
b
sqlNumUnit +9..
spaceNL
$/tstScanSqlNumUnit/ */
call tst t, 'tstScanSqlNumUnit'
b = jBuf('1 kb .3mB.5 + 6.e-5B -7* -.8 TB + 9.Tb')
s = scanOpen(scanSqlReset(tstScn, b))
do sx=1 while \scanEnd(s)
if scanSqlNumUnit(s, 0, 'B KB MB') then
call tstOut t, 'sqlNumUnit' m.s.val
else if scanSpace(s) then call tstOut t, 'spaceNL'
else if scanChar(s ,1) then call tstOut t, 'char' m.s.tok
else call scanErr s, 'cannot scan'
end
call tstEnd t
/*
$=/tstScanSqlClass/
### start tst tstScanSqlClass #####################################
i a 1 A
d "bC" 1 bC
q d.e 2 D.E
q f." g".h 3 F. g.H
s 'ij''kl' 3 ij'kl
s x'f1f2' 3 12
s X'f3F4F5' 3 345
.. . 3 .
n .0 3 .0
n 123.4 3 123.4
n 5 3 5
i g 1 G
$/tstScanSqlClass/ */
call tst t, 'tstScanSqlClass'
b = jBuf('a "bC" d.e f." g".h' "'ij''kl' x'f1f2' X'f3F4F5'" ,
, '. .0 123.4 5 g')
h = scanOpen(scanSqlReset(tstScn, b))
do sx=1 while scanSqlClass(h)
call tstOut t, m.h.sqlClass m.h.tok m.h.val.0 m.h.val
end
call tstEnd t
return
endProcedure tstScanSql
tstUtc2d: procedure expose m.
/*
$=/tstUtc2d/
### start tst tstUtc2d ############################################
. ff 255
. ffff 65535
. 10000 65536 65536 = 1 * 16 ** 4
. 10001 65537
. ffffff 16777215
. 1000000 16777216 16777216 = 1 * 16 ** 6
. 1000001 16777217
. 20000FF 33554687
. 100000000 4294967296 4294967296 = 1 * 16 ** 8
. 300000000 12884901888 12884901888 = 3 * 16 ** 8
. 3020000EF 12918456559
$/tstUtc2d/
*/
numeric digits 33
call tst t, 'tstUtc2d'
all = 'ff ffff 10000 10001 ffffff 1000000 1000001 20000FF' ,
'100000000 300000000 3020000EF'
do ax = 1 to words(all)
a = word(all, ax)
if substr(a, 2) = 0 then
b = right(left(a, 1) * 16 ** (length(a)-1), 15) ,
'=' left(a, 1) '* 16 **' (length(a)-1)
else
b = ''
call tstout t, right(a, 15)right(utc2d(x2c(a)), 15)b
end
call tstEnd t
return
endProcedure tstUtc2d
/**** tst: test infrastructure ***************************************/
/*--- test hook -----------------------------------------------------*/
wshHook_T: procedure expose m.
parse arg m, rest
do wx=1 to words(rest)
interpret 'call tst'word(rest, wx)
end
if wx > 2 then
call tstTotal
if wx > 1 then
return ''
/* default test */
say ii2rzdb(ee)
say ii2rzdb(eq)
say ii2rzdb(eq)
do y = left(date('s'), 4) - 17 to left(date('s'), 4) + 7
say y timeYear2Y(y) timeY2Year(timeYear2Y(y))
end
do y = left(date('s'), 4) - 69 to left(date('s'), 4) + 30
say y timeYear24(substr(y, 3))
end
d = date('s')
say d 'b' date('b', d , 's')
say d 'b' date('b', 20150101, 's') 'jul' date('j')
say d 'l14' date('b', 20150101, 's') - date('b', 20140101, 's')
say d 'l16' date('b', 20170101, 's') - date('b', 20160101, 's')
say fUnit('d', 3e7)
call err tstEnd
call tstfTst
call sqlConnect DBAF
call catColCom 'cmnBatch', 'DSN_PGROUP_TABLE',
, 'cmnBatch', 'DSN_PGROUP_TABLE_new'
call sqlDisConnect
return ''
endProcedure wshTst
/*--- initialise m as tester with name nm
use inline input nm as compare lines ------------------------*/
tst: procedure expose m.
parse arg m, nm, cmpSt
call tstReset m, nm
m.tst.tests = m.tst.tests+1
if cmpSt == '' then do
cmpSt = mCut(t'.CMP', 0)
call tst4dp cmpSt, mapInline(nm)
end
m.m.cmp = cmpSt
m.m.moreOutOk = 0
call mAdd mCut(m'.IN', 0), 'tst in line 1 eins ,' ,
, 'tst in line 2 zwei ; ' ,
, 'tst in line 3 drei .schluss.'
call tstOut m, left('### start tst' nm '', 67, '#')
call errReset 'hos', 'return tstErrHandler(ggTxt)'
call sqlRetDef
m.m.errCleanup = m.err_cleanup
m.tst_m = m
if m.tst.ini.j == 1 then do
m.m.jWriting = 0
call jOpen jReset(oMutatName(m, 'Tst')), '>'
m.m.in.jReading = 0
call jOpen jReset(oMutatName(m'.IN', 'Tst')), '<'
if m.tst.ini.e \== 1 then do
m.m.oldJin = m.j.in
m.m.oldOut = m.j.out
m.j.in = m'.IN'
m.j.out = m
end
else do
if m.pipe.0 <> 2 then
call tstErr m, 'm.pipe.0' m.pipe.0 '<> 2'
call pipe '+Ff', m , m'.IN'
end
end
if m.tstTime_ini \== 1 then do
m.tstTime_ini = 1
m.tstTimeNm = ''
aE = right(time('L'), 20, 0)
m.tstTimeLaEla = substr(aE, 12) ,
+ 60 * substr(aE, 9, 2) + 3600 * left(aE, 7)
m.tstTimeLaCpu = sysvar('syscpu')
end
return m
endProcedure tst
tstEnd: procedure expose m.
parse arg m, opt opt2
cmp = m.m.cmp
m.m.jReading = 0
m.m.jWriting = 0
drop m.tst_m
if m.tst.ini.j == 1 then do
m.m.jReading = 0
m.m.jWriting = 0
if m.tst.ini.e \== 1 then do
m.j.in = m.m.oldJin
m.j.out = m.m.oldOut
end
else do
if m.j.in \== m'.IN' | m.j.out \== m then
call tstErr m, m.j.in '\==' m '|' m.j.out '\==' m
call pipe '-'
if m.pipe.0 <> 2 then
call tstErr m, 'm.pipe.0' m.pipe.0 '<> 2'
end
end
if m.m.err = 0 then
if m.m.errCleanup \= m.err_cleanup then
call tstErr m, 'err_cleanup' m.err_cleanup '<> old',
m.m.errCleanup
if m.m.out.0 \= m.cmp.0 & \ (m.m.moreOutOk,
& m.m.out.0 > m.cmp.0) then do
call tstErr m, 'old' m.cmp.0 'lines \= new' m.m.out.0
do nx = m.m.out.0 + 1 to min(m.m.out.0+10, m.cmp.0)
say 'old - ' m.cmp.nx
end
end
call errReset 'h'
m.tst.act = ''
soll = 0
if opt = 'err' then do
soll = opt2
if m.m.err \= soll then
call err soll 'errors expected, but got' m.m.err
end
if m.m.err \= soll then do
say 'new lines:' (m.m.out.0 - 1)
call tst2dpSay m.m.name, m'.OUT', 68
end
say left('###' m.m.name 'end with' m.m.err 'errors ', 67, '#')
if 1 & m.m.err \= soll then
call err 'dying because of' m.m.err 'errors'
m.m.trans.0 = m.m.trans.old
nm = strip(m.m.name)
aE = right(time('L'), 20, 0)
aE = substr(aE, 12) + 60 * substr(aE, 9, 2) + 3600 * left(aE, 7)
aC = sysvar('syscpu')
if aE < m.tstTimeLaEla | aC < m.tstTimeLaCpu then
call err 'backward time/cpu'
if m.tstTime.nm \== 1 then do
m.tstTime.nm = 1
m.tstTimeNm = m.tstTimeNm nm
m.tstTime.nm.count = 1
m.tstTime.nm.ela = aE - m.tstTimeLaEla
m.tstTime.nm.cpu = aC - m.tstTimeLaCpu
end
else do
m.tstTime.nm.count = m.tstTime.nm.count + 1
m.tstTime.nm.ela = m.tstTime.nm.ela + aE - m.tstTimeLaEla
m.tstTime.nm.cpu = m.tstTime.nm.cpu + aC - m.tstTimeLaCpu
end
/* say left('%%%time' nm, 20) ,
f('%7.3i %9.3i', aC - m.tstTimeLaCpu , aE - m.tstTimeLaEla) ,
f('cum %6i %7.3i %9.3i', m.tstTime.nm.count, m.tstTime.nm.cpu,
, m.tstTime.nm.ela) */
m.tstTimeLaEla = aE
m.tstTimeLaCpu = aC
return
endProcedure tstEnd
tstTimeTot: procedure expose m.
tCnt = 0
tCpu = 0
tEla = 0
say 'tstTimeTotal'
do tx=1 to words(m.tstTimeNm)
nm = word(m.tstTimeNm, tx)
say left(nm, 12) f('%6i %7.3i %9.3i', m.tstTime.nm.count,
, m.tstTime.nm.cpu, m.tstTime.nm.ela)
tCnt = tCnt + m.tstTime.nm.count
tCpu = tCpu + m.tstTime.nm.cpu
tEla = tEla + m.tstTime.nm.ela
end
say left('total', 12) ,
f('%6i %7.3i %9.3i', tCnt, tCpu, tEla)
return
endProcedre tstTimeTot
tstReset: procedure expose m.
parse arg m, nm
call tstIni
m.m.name = nm
m.m.inIx = 0
m.m.out.0 = 0
m.m.err = 0
m.err.count = 0
m.tst.act = m
if \ datatype(m.m.trans.0, 'n') then
m.m.trans.0 = 0
m.m.trans.old = m.m.trans.0
return
endProcedure tstReset
/*--- tstIni: global initialization ---------------------------------*/
tstIni: procedure expose m.
if m.tst.ini \== 1 then do
m.tst.ini = 1
call mapIni
m.tst.err = 0
m.tst.trc = 0
m.tst.errNames = ''
m.tst.tests = 0
m.tst.act = ''
m.tst_csmRz = 'RZZ'
m.tst_csmDb = 'DE0G'
m.tst_csmRzDb = m.tst_csmRz'/'m.tst_csmDb
m.tst_csmServer = 'CHROI00ZDE0G'
m.tst_long = 0
end
if m.tst.ini.j \== 1 & m.j.ini == 1 then do
m.tst.ini.j = 1
call classNew 'n Tst u JRW', 'm',
, "jOpen",
, "jRead if \ tstRead(m, rStem) then return 0",
, "jWrite call tstWriteBuf m, wStem"
end
if m.tst.ini.e \== 1 & m.pipe_ini == 1 then do
m.tst.ini.e = 1
end
return
endProcedure tstIni
tst2dp: procedure expose m.
parse arg st, dp, ml
dx = m.dp.0
do sx=1 to m.st.0
li = m.st.sx
cx = 1
do until cx > length(li)
c = substr(li, cx, 1)
ou = left('.', strip(c) == '' | pos(c, '.+') > 0)
ex = min(length(li),cx+ml-length(ou)-2)
ou = ou || substr(li, cx, ex+1-cx)
dx = dx + 1
c = right(ou, 1)
if ex < length(li) then
m.dp.dx = ou || '+'
else if strip(c) == '' | pos(c, '.+') > 0 then
m.dp.dx = ou || '.'
else
m.dp.dx = ou
cx = ex +1
end
end
m.dp.0 = dx
return
endProcedure tst2dp
tst2dpSay: procedure expose m.
parse arg name, st, ml
say '$=/'name'/'
call tst2dp st, mCut('TST.TMP', 0), 68
do nx=1 to m.tst.tmp.0
say ' ' m.tst.tmp.nx
end
say '$/'name'/'
return tst2dpSay
tst4dp: procedure expose m.
parse arg st, dp
sx = m.st.0
inData = 0
data = ''
do dx=1 to m.dp.0
li = strip(m.dp.dx)
if pos(left(li, 1), '.+') > 0 then
li = substr(li, 2)
if right(li, 1) == '+' then do
inData = 1
data = data || left(li, length(li)-1)
iterate
end
if right(li, 1) == '.' then
li = left(li, length(li)-1)
sx = sx + 1
m.st.sx = repAll(data || li, '$ä', '/*', '$ö', '*/')
inData = 0
data = ''
end
m.st.0 = sx
if inData then
call err 'end inData'
return
endProcedure tst4dp
/*--- write to test: say lines and compare them ---------------------*/
tstOut: procedure expose m.
parse arg m, arg
do tx=m.m.trans.0 by -1 to 1
arg = repAll(arg, word(m.m.trans.tx, 1),
, subword(m.m.trans.tx, 2))
end
arg = repAll(arg, 'in' m.myWsh':', 'in wsM:')
call mAdd m'.OUT', arg
nx = m.m.out.0
cmp = m.m.cmp
c = m.cmp.nx
if nx > m.cmp.0 then do
if nx = m.cmp.0+1 & \ m.m.moreOutOK then
call tstErr m, 'more new Lines' nx
end
else if c \== arg & c \== '%%%' then do
do cx=1 to min(length(c), length(arg)) ,
while substr(c, cx, 1) == substr(arg, cx, 1)
end
msg = 'old line' nx '<> new overnext, firstDiff' cx',',
'len old' length(c)', new' length(arg)
if cx > 10 then
msg = overlay('|', msg, cx-10)
call tstErr m, msg
say c
end
say arg
return 0
endProcedure tstOut
tstWriteBuf: procedure expose m.
parse arg m, wStem
if wStem == m'.BUF' then do
xStem = mAddSt(mCut(wStem'_tstWriteXStem', 0), wStem)
m.wStem.0 = 0 /* attention avoid infinite recursion | */
end
else
xStem = wStem
do wx=1 to m.xStem.0
call tstWrite m, m.xStem.wx
end
return
endProcedure tstWriteBuf
tstWrite: procedure expose m.
parse arg m, var
cl = objClass(var)
if cl == m.class_N then do
call tstOut m, 'tstR: @ obj null'
end
else if cl == m.class_S then do
call tstOut m, var
end
else if abbrev(var, m.o_escW) then do
call tstOut m, o2String(var)
end
else if cl == m.class_V then do
call tstOut m, m.var
end
else if oKindOf(var, 'JRW') then do
call tstOut m, 'tstWriteO kindOf JRW jWriteNow begin <<<'
call jWriteNow m, var
call tstOut m, 'tstWriteO kindOf JRW jWriteNow end >>>'
end
else if oKindOf(var, 'ORun') then do
call tstOut m, 'tstWriteO kindOf ORun oRun begin <<<'
call oRun var
call tstOut m, 'tstWriteO kindOf ORun oRun end >>>'
end
else do
call tstTransOC m, var
call classOut , var, 'tstR: '
end
return
endProcedure tstWrite
tstTransOC: procedure expose m.
parse arg m, var
cl = objClass(var)
if cl == m.class_N | cl == m.class_S | cl == m.class_W then
return
c1 = className(cl)
vF = 0
do tx=m.m.trans.0 by -1 to 1 until vF & c1 == ''
if word(m.m.trans.tx, 1) == var then
vF = 1
if word(m.m.trans.tx, 1) == c1 then
c1 = ''
end
if \ vF then
call mAdd M'.TRANS', var 'tstWriteoV' ||(m.m.trans.0+1)
if c1 == '' then nop
else if m.cl.name == '' then
call mAdd M'.TRANS', c1 'class*' ||(m.m.trans.0+1)
else if m.cl.name \== m.cl.met then
call mAdd M'.TRANS', c1 m.cl.met ||(m.m.trans.0+1)
return
endProcedure tstTransOC
/*--- translate the tst_csm* variables ------------------------------*/
tstTransCsm: procedure expose m.
parse arg t
say 'csm to' m.tst_csmRzDb m.tst_csmServer
call mAdd t.trans, m.tst_csmRZ '<csmRZ>' ,
, m.tst_csmDb '<csmDB>' ,
, m.tst_csmServer '<csmServer>'
s2 = iirz2sys(m.tst_csmRz)
do sx=0 to 9
call mAdd t.trans, s2 || sx '<csmSys*>'
end
return
endProcedure tstTransCsm
tstRead: procedure expose m.
parse arg mP, rStem
if right(mP, 3) \== '.IN' then
call err 'tstRead bad m' mP
m = left(mP, length(mP)-3)
ix = m.m.inIx + 1
m.m.inIx = ix
m.rStem.0 = ix <= m.mP.0
m.rStem.1 = m.mP.ix
if ix <= m.m.in.0 then
call tstOut m, '#jIn' ix'#' m.m.in.ix
else
call tstOut m, '#jIn eof' ix'#'
return m.rStem.0
endProcedure tstRead
tstFilename: procedure expose m.
parse arg suf, opt
if m.err_os == 'TSO' then do
parse value dsnCsmSys(suf) with sys '/' suf
dsn = dsn2jcl('~tmp.tst.'suf)
if sys \== '*' then
dsn = sys'/'dsn
if opt = 'r' then do
if dsnExists(dsn) then
call dsnDel dsn
do fx=1 to dsnList(tstFileName, dsn)
call dsnDel m.tstFileName.fx
end
end
return dsn
end
else if m.err_os == 'LINUX' then do
if abbrev(suf, '/') then
fn = suf
else
fn = .Stream%%new('~/tmp/tst/'suf)%%qualify /* full path */
cx = lastPos('/', fn)
if cx > 0 then do
dir = left(fn, cx-1)
if \sysIsFileDirectory(dir) then
call adrSh "mkdir -p" dir
if \sysIsFileDirectory(dir) then
call err 'tstFileName could not create dir' dir
end
if opt \= 'r' then
nop
else if sysIsFile(fn) then
call sysFileDelete fn
else if sysIsFileDirectory(fn) then
call adrSh 'rm -r' fn
return fn
end
else
call err 'tstFilename does not implement os' m.err_os
endProcedure tstFilename
/*--- say total errors and fail if not zero -------------------------*/
tstTotal: procedure expose m.
say '######'
/* say '###### astStatsTotals'
do sx=1 to words(m.comp_astStats)
k = word(m.comp_astStats, sx)
say f('%5c %7i %7i %7i', k, m.comp_astStats.k,
, m.comp_astStatT.k, m.comp_astStat1.k)
end
say '######' */
say '######' m.tst.tests 'tests with' ,
m.tst.err 'errors in' m.tst.errNames
say '######'
say '######'
if m.tst.err \== 0 then
call err m.tst.err 'errors total'
return
endProcedure tstTotal
/*--- test err: message, count it and continue ----------------------*/
tstErr: procedure expose m.
parse arg m, msg
say '### error' msg
m.m.err = m.m.err + 1
m.tst.err = m.tst.err + 1
nm = m.m.name
if wordPos(nm, m.tst.errNames) < 1 then
m.tst.errNames = m.tst.errNames nm
return 0
endProcedure tstErr
/*--- tstErrHandler: intercept errors -------------------------------*/
tstErrHandler: procedure expose m.
parse arg ggTxt
m = m.tst.act
if m == '' then
call err ggTxt
m.err.count = m.err.count + 1
call splitNl err, 0, errMsg(' }'ggTxt)
call tstOut m.tst.act, '*** err:' m.err.1
do x=2 to m.err.0
call tstOut m, ' e' (x-1)':' m.err.x
end
return 0
endSubroutine tstErrHandler
tstTrc: procedure expose m.
parse arg msg
m.tst.trc = m.tst.trc + 1
say 'tstTrc' m.tst.trc msg
return m.tst.trc
endProcedure tstTrc
/*--- tstData -------------------------------------------------------*/
tstData: procedure expose m.
parse arg ty 2 le 'n' nu, l, r, num
abs = abs(num)
if nu \== '' then do
if abs // 5 = 0 then
return 'null' || (abs % 5 // nu + 1)
end
if ty = 'c' then do
if le = '' then
le = 8
le = abs // le + 1
if r = '' then
r = '+'
return left(l || num || r, le, right(r, 1))
end
if pos(ty, 'ief') < 1 then
call err 'bad type' ty
nn = abs
if abbrev(num, '-') | abbrev(num, '+') then
parse var num si 2 nn
else
si = ''
if ty == 'e' then
ex = 'e' || left('-', abs // 2) || (abs // 15)
else
ex = ''
if le \== '' then
nn = right(nn, abs // max(1, le - length(si||ex)) + 1, 1)
if ty \== 'i' & (abs // 4) \= 0 & length(nn) > 1 then
nn = overlay('.', nn, length(nn) - abs // length(nn))
return si || nn || ex
endProcedure tstData
tstDataClassFo: procedure expose m.
parse arg flds
ty = ''
do fx=1 by 2 to words(flds)
if word(flds, fx) = '.' then
ty = ty', v'
else
ty = ty', f' word(flds, fx) 'v'
end
t = classNew('n* tstData u' substr(ty, 2))
fo = oNew(m.t.name)
ff = oFldD(fo)
do fx=1 to m.ff.0
f = fo || m.ff.fx
m.f = word(flds, 2*fx)
end
return fo
endProcedure tstDataClassFo
tstDataClassOut: procedure expose m.
parse arg flds, f, t
fo = tstDataClassFo(flds)
ff = oFldD(fo)
do x=f to t
o = oCopy(fo)
do fx=1 to m.ff.0
f = o || m.ff.fx
m.f = tstData(m.f, substr(m.ff.fx, 2),
, '+'substr(m.ff.fx,2)'+', x)
end
call out o
end
return
endProcedure tstDataClassOut
/* copy tstAll end **************************************************/
/* copy unused begin *************************************************/
class2srcMap: procedure expose m.
parse arg m
call mapReset m
call mapPut m, m.class_v, 'v'
call mapPut m, m.class_w, 'w'
call mapPut m, m.class_o, 'o'
return m
endProcedure class2srcMap
tstClass2src: procedure expose m.
/*
$</class2src/
$/class2src/
*/
call jIni
call tst t, 'class2src'
done = class2SrcMap(tstClass2SrcMap)
call class2src m.class_class, done, t
call class2src m.class_jrw, done, t
call class2src m.class_jrwLazy, done, t
call tstEnd t
return
endProcedure class2srcMap
class2src: procedure expose m.
parse arg cl, done, out
res = mapGet(done, cl, '-')
if res \== '-' then
return res
call mapPut done, cl, cl
ty = m.cl
res = 'class' cl':'
if ty == 'u' then do
if m.cl.name == '' then
res = res 'u'
else if right(m.cl.met, 1) \== '*' then
res = res 'n' m.cl.name 'u'
else
res = res 'n*' left(m.cl.met, length(m.cl.met)-1)
if m.cl.0 > 0 then do
do cx=1 to m.cl.0
res = res class2SrcEx(m.cl.cx, done, out)','
end
res = left(res, length(res)-1)
end
end
else if ty == 'm' & m.cl.0 == 0 then
res = res 'm' m.cl.name m.cl.met
else
res = res class2SrcEx(cl, done, out)
call jWrite out, res
return cl
endProcedure class2src
class2srcEx: procedure expose m.
parse arg cl, done, out
res = ''
ch = cl
do forever
g = mapGet(done, cl, '-')
if g \== '-' then
return strip(res g)
else if m.ch == 'u' | m.ch == 'm' then
return strip(res class2Src(ch, done, out))
else if \ (length(m.ch) == 1 & pos(m.ch, 'fscr') >= 1,
& m.ch.0 <= 1 & m.ch.met == '') then
return err('class2src bad cl' ch 'ty='m.ch,
'name='m.ch.name '.0='m.ch.0 'met='m.ch.met)
res = strip(res m.ch m.ch.name)
if m.ch.0 = 0 then
return res
ch = m.ch.1
end
endProcedure class2srcEx
/**********************************************************************
lmd: catalog read ===> ersetzt durch csi
call sequence: lmdBegin, lmdNext*, lmdEnd
mit lmd service (mit save in file und read,
weil list zu langsam und listcat abstürzt)
1. arg (grp) als group dataset für lmd save
und dd name für file read
**********************************************************************/
lmdBegin: procedure expose m.
parse arg grp, lev
call adrIsp 'lmdinit listid(lmdId) level('lev')'
res = adrIsp('lmdlist listid(&lmdId) option(save) group('grp')', 4)
call adrIsp 'lmdfree listid(&lmdId)'
if res = 0 then do
call trc timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') shr dsn('grp'.datasets)'
end
else do
call trc 'no datasets found' timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') dummy'
end
call tsoOpen grp, 'R'
return /* end lmdBegin */
lmdNext:
parse arg ggGrp, ggSt, withVolume
if \ readDD(ggGrp, ggSt) then
return 0
if withVolume \== 1 then
do ggIx=1 to value(ggSt'0')
x = value(ggSt || ggIx, word(value(ggSt || ggIx), 1))
end
return 1
endSubroutin lmdNext
lmdEnd: procedure expose m.
parse arg grp
call tsoClose grp
call adrTso 'free dd('grp')'
return /* end lmdEnd */
lmd: procedure expose m.
parse arg lev, withVol
call lmdBegin gg1, lev
do while lmdNext(gg1, q., withVol)
do x=1 to q.0
call out q.x
end
end
call lmdEnd gg1
return
endProcedure lmd
tstLmdTiming:
parse arg lev
trace ?r
lev = word(lev DSN , 1)
say timing() lev
call lmdBegin abc, lev
c = 0
do while lmdNext(abc, st.)
c = c + st.0
end
call lmdEnd abc
say timing() lev 'with group - without reading' c
call adrIsp 'lmdinit listid(lmdId) level('lev')'
do c=0 while adrIsp('lmdlist listid(&lmdId) dataset(abc)', 8) = 0
end
call adrIsp 'lmdfree listid(&lmdId)'
say timing() lev 'with list' c
return
endProcedure lmdTiming
/**********************************************************************
==> abgeloest mbrList: tso listDS "'"dsn"'" members
member list of a pds: ==> abgeloest mbrList tso
call sequence x=lmmBegin(dsn) lmmNext(x) * lmmEnd(x)
**********************************************************************/
lmm: procedure expose m.
parse arg dsn
id = lmmBegin(dsn)
do ix=1 by 1
m = lmmNext(id)
if m = '' then
leave
call out m
end
call lmmEnd id
return
endProcedure lmm
lmmBegin: procedure expose m.
parse arg dsn
mbr = dsnGetMbr(dsn)
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET('"pds"') ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(INPUT) "
res = lmmId
if mbr <> '' then
res = res 'pattern('mbr')'
return res
endProcedure lmmBegin
lmmEnd: procedure expose m.
parse arg lmmId opt
call adrIsp "LMMLIST DATAID("lmmId") option(free)", 8
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
return
endProcedure lmmEnd
lmmNext: procedure expose m.
parse arg lmmId opt
if adrIsp("LMMLIST DATAID("lmmid")" ,
"OPTION(LIST) MEMBER(Mbr)" opt, 4 8) = 0 then
return strip(mbr)
else
return ''
endProcedure lmmNext
lmmRm: procedure expose m.
parse arg dsn, mbrs
mbrs = dsnGetMbr(dsn) mbrs
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET("pds") ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(OUTPUT) "
err = ''
do wx=1 to words(mbrs)
m1 = word(mbrs, wx)
rr = adrIsp("lmmDel dataid("lmmId") member("m1")", 0 8 12)
if rc = 0 then
say 'removed' m1 'from' pds
else if rc = 8 then
say 'not found' m1 'in' pds
else do
err = 'error deleting' m1 'in' pds 'rc' rr strip(zerrlm)
say err
leave
end
end
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
if err <> '' then
call err err
return
endProcedure lmmRm
/*--- find archived DSN's from listCat ------------------------------*/
listCatClass: procedure expose m.
parse upper arg dsn
rt = adrTso("listcat volume entry('"dsn"')", 4)
/* say 'listct rc =' rt 'lines' m.tso_trap.0 */
cl = ''
vo = ''
if word(m.tso_trap.1, 3) \== dsn then
call out 'err ??? for dsn' dsn 'bad first line' m.tso_trap.1
else if pos('NOT FOUND', m.tso_trap.1) > 0 then
return 'notFound'
else if word(m.tso_trap.1, 1)\== 'NONVSAM' then
call out 'err ??? for dsn' dsn 'bad first line' m.tso_trap.1
do tx=2 to m.tso_trap.0 while vo = '' ,
& left(m.tso_trap.tx, 1) = ' '
/* say m.tso_trap.tx */
p = pos('MANAGEMENTCLASS-', m.tso_trap.tx)
if p > 0 then
vo = strip(word(substr(m.tso_trap.tx, p+16), 1), 'l', '-')
p = pos('VOLSER--', m.tso_trap.tx)
if p > 0 then
vo = strip(word(substr(m.tso_trap.tx, p+6), 1), 'l', '-')
p = pos('DEVCLASS--', m.tso_trap.tx)
dt = strip(word(substr(m.tso_trap.tx, p+8), 1), 'l', '-')
end
/* say 'lc' cl 'vo' vo 'dt' dt 'dsn' dsn */
if vo = '' then
call out '??? err no volume for dsn' dsn
else if vo = 'ARCIVE' then
res = 'arcive'
else if cl = '' then
res = 'tape'
else
res = cl
if abbrev(res, 'ar') \= abbrev(dt, "X'0") ,
| abbrev(res, 'ta') \= abbrev(dt, "X'7") ,
| (left(res, 1) >= 'A') \= abbrev(dt, "X'3") then
call out 'err ??? mismatch cl' cl 'vo' vo 'dt' dt 'dsn' dsn
return res
endProcedure listCatClass
/**** sql stored procedures ******************************************/
/*--- sql call statement ---------------------------------------------
old code: find procedure description in catalog
and use it to create call statement --------------------*/
sqlStmtCall: procedure expose m.
parse arg src, retOk, opt
s = scanSqlReset(scanSrc(sqlstmtcall, src))
if \ scanSqlId(scanSkip(s)) | m.s.val \== 'CALL' then
call scanErr s, 'not a call'
if \ scanSqlQuId(scanSkip(s)) then
call scanErr s, 'qualified id missing after call'
loc = ''
if m.s.val.0 = 1 then
wh = 'name =' quote(m.s.val.1, "'")
else if m.s.val.0 = 2 then
wh = "schema = '"strip(m.s.val.1)"'" ,
"and name = '"strip(m.s.val.2)"'"
else if m.s.val.0 = 3 then do
loc = m.s.val.1
wh = "schema = '"strip(m.s.val.2)"'" ,
"and name = '"strip(m.s.val.3)"'"
end
else
call scanErr s, 'storedProcedureName' m.s.val ,
'has' m.s.val.0 'parts, should have 1, 2 or 3'
pn = m.s.val
da = sqlStmtCallDa(sqlStmtCall, loc, wh)
if \ scanLit(scanSkip(s), '(') then
call scanErr s, '( expected after call' pn
varChars = f
do ax=1
m.da.ax.varName = ''
isEmpty = 0
if scanLit(scanSkip(s), ':') then do
if \ scanVerify(scanSkip(s), m.ut_alfDot) then
call scanErr s, 'variable expected after : in call' pn
m.da.ax.varName = m.s.tok
if m.da.ax.io == 'i' | m.da.ax.io == 'b' then
m.da.ax.sqlData = envGet(m.da.ax.varName)
end
else if scanString(s) then
m.da.ax.sqlData = m.s.val
else if scanVerify(s, ',):;', 'm') then
m.da.ax.sqlData = strip(m.s.tok)
else
isEmpty = 1
if scanLit(scanSkip(s), ')') then
leave
if \ scanLit(s, ',') then
call scanErr s, if(isEmpty, 'value, var, ') ,
|| "',' or ')' expected"
end
if ax \= m.da.sqlD then
if \ (ax=1 & m.da.sqlD = 0 & isEmpty) then
call scanErr s, 'call with' ax 'parms but' ,
pn 'needs' m.da.sqld
caCo = sqlExec('call' pn 'using descriptor :M.'da, 466)
call out '--- called' pn', sqlCode' caCo
do ax=1 to m.da.sqlD
call Out ' parm' ax m.da.ax.io m.da.ax.parmName,
|| if(m.da.ax.varName \== '',' $'m.da.ax.varName),
'=' m.da.ax.sqlData
if m.da.ax.varName \== '' then
call envPut m.da.ax.varName, m.da.ax.sqlData
end
if caCo = 466 then do
drop sqlDP
call sqlExec 'describe procedure :pn into :m.sqlDp'
if m.sqldp.sqlD < 1 then
call err 'bad sqldp sqlD='m.sqldp.sqlD 'for sqlCode' caCo
do dx=1 to m.sqldp.sqlD
call out ' dynamic result set' dx m.sqldp.dx.sqlName ,
'locator='m.sqldp.dx.sqlLocator
end
do dx=1 to m.sqldp.sqlD
drs = 'dynamic result set' dx'='m.sqldp.dx.sqlName 'of' pn
call out '--- begin of' drs
rdr = sqlDRS(m.sqldp.dx.sqlLocator)
if pos('o', opt) > 0 then
call pipeWriteAll rdr
else
call fTabAuto sqlStmtFmt, rdr
call out '---' m.rdr.rowCount 'rows fetched from' drs
end
end
return 'sqlCode' caCo
endProcedure sqlStmtCall
sqlStmtCallDa: procedure expose m.
parse arg da, loc, wh
cr = if(loc=='',,loc'.')'sysIbm'
sql = "select 'SCHEMA=''' || strip(schema) || ''''",
"|| ' and name=''' || strip(name ) || ''''",
"|| ' and specificName=''' || strip(specificName) || ''''",
"|| ' and routineType =''' || strip(routineType ) || ''''",
"|| ' and VERSION =''' || strip(VERSION ) || ''''",
"from" cr".SysRoutines ",
"where" wh "and active = 'Y'"
if sqlpreAllCl(49, sql, rou, ':m.rou') <> 1 then
call err m.rou.0 'routines found for' wh
rdr = jOpen(sqlRdr('select * from' cr'.sysParms where' m.rou,
'order by ordinal'), '<')
do ix=1 while jRead(rdr)
a = m.rdr
if m.a.ordinal <> ix then
call err 'ix' ix 'mismatch ordinal' m.a.ordinal
ty = m.a.dataTypeId
m.da.ix.sqlType = ty
m.da.ix.sqlLen = m.a.length
m.da.ix.sqlLen.sqlPrecision = m.a.length
m.da.ix.sqlLen.sqlScale = m.a.scale
if wordPos(ty, 384 385) > 0 then /* date */
m.da.ix.sqlLen = 10
else if wordPos(ty, 388 389) > 0 then /* time */
m.da.ix.sqlLen = 8
else if wordPos(ty, 392 393) > 0 then /* timestamp */
m.da.ix.sqlLen = 26
m.da.ix.sqlData = ''
m.da.ix.parmName= m.a.parmName
m.da.ix.io = translate(m.a.rowType, 'iob', 'POB')
m.da.ix.sqlInd = 1
end
m.da.sqlD = ix - 1
return da
endProcedure sqlStmtCallDa
tstSqlStored: procedure expose m.
call sqlConnect 'DP4G'
rst = 'NO'
retcode = -9876
e = ''
z = 0
st = "abc"
call sqlExec "call SYSPROC.COMMAND ( :st, :rst)"
say 'after call st='st 'rst='rst
call sqlExec ,
'ASSOCIATE LOCATOR (:RESULTS) WITH PROCEDURE SYSPROC.COMMAND'
say 'results' results
call sqlExec 'ALLOCATE C111 CURSOR FOR RESULT SET :RESULTS'
say 'allocated c111'
do while sqlExec('fetch c111 into :seq, :txt', 0 100) = 0
say 'sysPrint' seq strip(txt, 't')
end
call sqlExec 'close c111'
say 'closed'
call sqlDisconnect
return
endProcedure tstSqlStored
tstSqlStoredWK: procedure expose m.
call sqlConnect 'DBAF'
/* st = "direct wkUtiSub"
rst = 'NO'
say 'before call st='st 'rst='rst
call sqlExec "call A540769.WKUTILSUB ( :st, :rst)"
say 'after call st='st 'rst='rst
*/ rst = 'NO'
retcode = -9876
e = ''
z = 0
prc = 'DB2UTIL.DB2UTIL'
st = "DA540769.A2*" /* DA540769.A1*" */
say "call" prc "("st", ...)"
call sqlExec "call" prc "(:st, :rst)"
say 'after call st='st 'rst='rst
call sqlExec ,
'ASSOCIATE LOCATOR (:RESULTS) WITH PROCEDURE' prc
/* say 'results' results */
call sqlExec 'ALLOCATE C111 CURSOR FOR RESULT SET :RESULTS'
say ''
say '***** utility output'
do while sqlExec('fetch c111 into :seq, :txt', 0 100) = 0
say 'sysPrint' seq strip(txt, 't')
end
call sqlExec 'close c111'
say '***** end output'
call sqlDisconnect
return 0
endProcedure tstSqlStoredWK
tstSqlStoredSQL1: procedure expose m.
call sqlConnect 'DBIA'
rst = 'NO'
retcode = -9876
e = ''
z = 0
st = "DA540769.A2* DA540769.A1*"
call sqlExec "call A540769.WKSQL1 ( :st, :rst)"
say 'after call st='st 'rst='rst
call sqlExec ,
'ASSOCIATE LOCATOR (:RESULTS) WITH PROCEDURE A540769.WKUTIL'
say 'results' results
call sqlExec 'ALLOCATE C111 CURSOR FOR RESULT SET :RESULTS'
say 'allocated c111'
do while sqlExec('fetch c111 into :seq, :txt', 0 100) = 0
say 'sysPrint' seq strip(txt, 't')
end
call sqlExec 'close c111'
say 'closed'
call sqlDisconnect
return
endProcedure tstSqlStoredSQL1
tstSqlUtils: procedure expose m.
call sqlConnect 'DBAF'
id = 'A540769.dsnUtils'
rst = 'NO'
retcode = -9876
e = ''
z = 0
st = "TEMPLATE TCOPYD",
"DSN('&SSID..&JO..&US..P&PART(2)..D&DATE(3)..T&TIME.')",
"DATACLAS(NULL12) MGMTCLAS(COM#A011) STORCLAS(FAR$N)",
"SPACE (150,3750) TRK UNCNT 59;",
"listdef abc include tablespace DA540769.A002* partlevel;",
"listdef mf include tablespace MF01A1A.A110A partlevel;",
"copy list abc copyddn(tcopyd) shrlevel change;"
st = translate(st)
call sqlExec "call SYSPROC.DSNUTILS ( :id, :rst,",
":st,:retcode, :ANY" copies(',:e,:e,:z',12) ")"
call sqlExec ,
'ASSOCIATE LOCATOR (:RESULTS) WITH PROCEDURE SYSPROC.DSNUTILS'
say 'results' results
call sqlExec 'ALLOCATE C111 CURSOR FOR RESULT SET :RESULTS'
say 'allocated c111'
do while sqlExec('fetch c111 into :seq, :txt', 0 100) = 0
say 'sysPrint' seq strip(txt, 't')
end
call sqlExec 'close c111'
say 'closed'
call sqlDisconnect
exit
endProcedure tstSqlUtils
/*--- sql trigger timing --------------------------------------------*/
tstSqlTriggerTiming:
parse upper arg tb ni
m.noInsert = ni == 0
cnt = 200000
if tb = '' then
TB = 'GDB9998.TWK511TRI'
call sqlConnect dbaf
say timing() 'noInsert' m.noInsert 'tb' tb
call sql2St 'select max(pri) MX from' tb, cc
if m.cc.1.mx == m.sqlNull then
m.cc.1.mx = 0
von = m.cc.1.mx + 1
bis = m.cc.1.mx + cnt
say m.cc.0 'max' m.cc.1.mx 'von' von 'bis' bis 'count' cnt tb
if right(tb, 2) = 'A1' then do
call sqlPrepare 3, 'insert into' tb '(pri, short, long, par)' ,
'values (?, ?, ?, ?)'
do ax=von to bis
call sqlExecute 3, ax,
, ax 'wsh short', ax 'wsh long long long long long ',
, (ax-1) // 1000 + 1
end
end
else do
call sqlPrepare 3, 'insert into' tb '(pri, short, long)' ,
'values (?, ?, ?)'
do ax=von to bis
call sqlExecute 3, ax,
, ax 'wsh short', ax 'wsh long long long long long ',
, (ax-1) // 1000 + 1
end
end
/* call sqlLn 5,,, 'select * from' tb 'where pri >=' von */
call sqlCommit
say timing()
call sqlDisconnect
return
endProcedure tstSqlTriggerTiming
/*******????? neu, noch versorgen ???????? ***************************/
tstRts: procedure expose m.
call wshIni
call sqlConnect dbaf
call sqlQuery 3, "select * from sysibm.sysTableSpaceSTats" ,
"where dbName = 'MF01A1A' and name = 'A150A'",
"order by partition asc"
do while sqlFetch(3, rr)
say f('@.DBNAME%-8C.@NAME%-8C @PARTITION %4C' ,rr)
end
call sqlDisconnect
endProcedure tstRts
tstWiki:
call mapReset docs, 'k'
call addFiles docs, 'n', '/media/wkData/literature/notes'
call addFiles docs, 'd', '/media/wkData/literature/docs'
in = jOpen(file('wiki.old'), '<')
out = jOpen(file('wiki.new'), '>')
abc = '(:abc: %l%'
do cx=1 to length(m.ut_lc)
c1 = substr(m.ut_lc, cx, 1)
abc = abc '¢¢#'c1 '|' c1'!!'
end
call jWrite out, abc ':)'
inTxt = 0
li = m.i
do lx=1 while jReadVar(in, i)
if 0 then
say length(m.i) m.i
if m.i = '' then
iterate
li = m.i
do forever
bx = pos('¢=', li)
if bx < 1 then
leave
ex = pos('=!', li)
if ex <= bx then
call err '=! before ¢= in' lx li
li = left(li, bx-1)substr(li,bx+2, ex-bx-2)substr(li,ex+2)
end
li = strip(li)
if abbrev(li, '|') then do
w = word(substr(li, 2), 1)
call jWrite out, '¢¢#'w'!! {$:abc}'
call jWrite out, '|||' substr(li, 2)
inTxt=1
iterate
end
if \ inTxt then do
call jWrite out, li
iterate
end
if \ (abbrev(li, '->') | abbrev(li, '#') ,
| abbrev(li, '¢')) then do
call jWrite out, '-<' li
iterate
end
cx = 1
if substr(li, cx, 2) == '->' then
cx = verify(li, ' ', 'n', cx+2)
hasCross = substr(li, cx, 1) == '#'
if hasCross then
cx = verify(li, ' ', 'n', cx+1)
ex = verify(li, '!:\, ', 'm', cx)
ex = ex - (substr(li, ex, 1) \== '!')
hasBr = substr(li, cx, 1) == '¢'
if \ hasBr then
w = substr(li, cx, ex+1-cx)
else if substr(li, ex, 1) == '!' then
w = substr(li, cx+1, ex-1-cx)
else
call err 'br not closed' substr(w, cx+1,ex-1-cx) 'in' lx li
hasPdf = right(w, 4) == '.pdf'
if hasPdf then
w = left(w, length(w)-4)
if verify(w, '#?', 'm') > 0 then do
w = translate(w, '__', '#?')
say '*** changing to' w 'in' lx li
end
o = '-< {def+'w'}'
o = '-< ¢¢'w'!!'
k = translate(w)
if k.k == 1 then
say '*** doppelter key' k 'in:' lx left(li,80)
k.k = 1
dT = ''
if mapHasKey(docs, k) then do
parse value mapGet(docs, k) with dT dC dN
call mapPut docs, k, dT (dC+1) dN
do tx=1 to length(dT)
t1 = substr(dT, tx, 1)
o = o '¢¢Lit'translate(t1)':'word(dN, tx) '|' t1 '!!'
end
end
qSeq = 'nd'
qq = left(qSeq, 1)
qx = 0
do forever
qx = pos('@'qq, li, qx+1)
if qx < 1 then do
qq = substr(qSeq, 1 + pos(qq, qSeq), 1)
qx=0
if qq = '' then
leave
else
iterate
end
if pos(qq, dT) < 1 then do
say '*** @'qq 'document not found:' lx li
iterate
end
do qb = qx-1 by -1 while substr(li, qb, 1) == ' '
end
do qe = qx+2 by 1 while substr(li, qe, 1) == ' '
end
if substr(li, qb, 1) == '.' & substr(li, qe, 1) == '.' then
li = left(li, qb)substr(li, qe+1)
else
li = left(li, qb) substr(li, qe)
end
o = o':' strip(substr(li, ex+1+(substr(li,ex+1,1)==':')))
if 0 then say left(li, 30) '==>' left(o, 30)
call jWrite out, o
end
dk = mapKeys(docs)
do dx=1 to m.dk.0
parse value mapGet(docs, m.dk.dx) with dT dC dN
if dC < 1 then
say '*** document not used:' dT dC dn
end
call jClose in
call jClose out
return
endProcedure tstWiki
addFiles: procedure expose m.
parse arg m, ty, file
fl = jOpen(fileList(file(file)), '<')
do while jRead(fl)
nm = substr(m.fl, lastPos('/', m.fl)+1)
k = translate(left(nm, pos('.', nm)-1))
if \ mapHasKey(m, k) then do
call mapAdd m, k, ty 0 nm
end
else do
parse value mapGet(m, k) with dT dC dN
call mapPut m, k, dT || ty 0 dN nm
end
end
call jClose fl
return
endProcedure addFiles
/* copU fiLinux begin ************************************************/
/*--- send ggShCmd to shell bash,
fail if rc <> 0 or not listed in ggRet ----------------------*/
adrSh: procedure expose m. /* really no need for variables???? */
parse arg ggShCmd, ggRet
address 'bash' ggShCmd
if rc == 0 then return 0
else if ggRet == '*' then return rc
else if wordPos(rc, ggRet) > 0 then return rc
else
call err 'adrSh rc' rc 'for' ggShCmd
endProcedure adrSh
fileLinuxReset: procedure expose m.
parse arg m, nm
m.m.spec = nm
if abbrev(nm, '&') then do
if nm == '&in' then do
m.m.stream = .input
m.m.jReading = 1
end
else if nm == '&out' then do
m.m.stream = .output
m.m.jWriting = 1
end
else do
call err 'bad spec' nm
end
end
else do
m.m.stream = .Stream%%new(nm)
m.m.stream%%init(m.m.stream%%qualify)
end
return m
endProcedure fileLinuxReset
fileLinuxOpen: procedure expose m.
parse arg m, opt
if opt == m.j.cRead then do
res = m.m.stream%%open(read shareread)
m.m.jReading = 1
end
else do
if opt == m.j.cApp then
res = m.m.stream%%open(write append)
else if opt == m.j.cWri then
res = m.m.stream%%open(write replace)
else
call err 'fileLinuxOpen('m',' opt') with bad opt'
m.m.jWriting = 1
end
if res \== 'READY:' then
call err 'fileLinuxOpen fails' res':' opt ,
"'"m.m.stream%%qualify"'"
return m
endProcedure fileLinuxOpen
fileLinuxClose:
parse arg m
res = m.m.stream%%close
if res \== 'READY:' then
call err 'fileLinuxClose' res':' m.m.stream%%qualify
return m
endProcedure fileLinuxClose
fileLinuxRead: procedure expose m.
parse arg m, var
res = m.m.stream%%lineIn
if res == '' then
if m.m.stream%%state \== 'READY' then
return 0
m.var = res
m.o.o2c.var = m.class_V
return 1
endProcedure fileLinuxRead
fileLinuxWrite: procedure expose m.
parse arg m, line
if m.m.stream%%lineOut(line) then
call err 'fileLinuxWrite'
return
endProcedure fileLinuxWrite
fileLinuxRmDir: procedure expose m.
parse arg m, opt
if opt == '' then
return adrSh('rmdir' m.m.spec)
else if opt == '-r' then
return adrSh('rm -r' m.m.spec)
else
call err 'bad opt' opt 'in fileLinuxRmDir'
endProcedure fileLInuxRmDir
fileLinuxListReset: procedure expose m.
parse arg m, m.m.spec, o
if o == 'r' then
m.m.opt = 'S'
else if o == '' then
m.m.opt = ''
else
call err 'bad opt' o 'in fileLinuxListReset'
m.m.rx = 'closed'
return m
endProcedure fileLinuxListReset
fileLinuxListOpen: procedure expose m.
parse arg m
if m \== translate(m) then
call err 'bad m for fileLinuxList:' m
if m.m.opt == '' then
rc = sysFileTree(m.m.spec'/*', 'm.'m'.LIST')
else
rc = sysFileTree(m.m.spec'/*', 'm.'m'.LIST', m.m.opt)
if rc \== 0 then
call err 'rc' rc 'in sysFileTree('m.m.spec', m.'m'.LIST)'
m.m.rx = 0
m.m.jReading = 1
return m
endProcedure fileLinuxListOpen
fileLinuxListRead: procedure expose m.
parse arg m, var
x = m.m.rx + 1
if x > m.m.list.0 then
return 0
m.var = substr(m.m.list.x, 43)
m.m.rx = x
call oMutate var, m.class_V
return 1
endProcedure fileLinuxListRead
fileLinuxIni: procedure expose m.
if m.fileLinux.ini == 1 then
return
m.fileLinux.ini = 1
m.file.sep = '/'
call jIni
call classNew "n File u JRW", "m",
, "jReset call fileLinuxReset m, arg",
, "jOpen call fileLinuxOpen m, opt",
, "jClose call fileLinuxClose m",
, "jRead return fileLinuxRead(m, var)",
, "jWrite call fileLinuxWrite m, wStem",
, "filePath return m.m.stream%%qualify",
, "fileIsFile return sysIsFile(m.m.stream%%qualify)" ,
, "fileIsDir return sysIsFileDirectory(m.m.stream%%qualify)" ,
, "fileChild return file(m.m.stream%%qualify'/'name)",
, "fileRm return adrSh(m.m.spec)",
, "fileMkDir return adrSh('mkdir' m.m.stream%%qualify)" ,
, "fileRmDir return fileLinuxRmDir(m, opt)"
call classNew "n FileList u JRW", "m",
, "jReset call fileLinuxListReset m, arg, arg2",
, "jOpen call fileLinuxListOpen m, opt",
, "jClose m.m.rx = 'closed'",
, "jRead return fileLinuxListRead(m, var)"
return
endProcedure fileLinuxIni
/* copU fiLinux end ************************************************/
/* copy unused end *************************************************/
}¢--- A540769.WK.REXX(TXO) cre=2012-12-14 mod=2012-12-14-15.59.56 A540769 ------
/* rexx ****************************************************************
tx: testDriver
as editMacro: tx fun
from tso: tx pdsMbr fun
fun = empty execute unprocessed statements
r clear process flags and execute from beginning
c clear process flags
version v2 with wsh from 8.6.11
***********************************************************************/
call errReset 'hI'
call wshIni
parse arg oArgs
args = oArgs
if 0 then
oArgs = 'L DSN.MAREC.DBZF.D090702.T175332.JOB101(STAALL)' ,
'001 YMRCO001 rebu wa'
m.dbConn = ''
m.tx.iniRun = 0
m.tx.isMacro = oArgs == '' & sysVar('sysISPF') = 'ACTIVE'
if m.tx.isMacro then
m.tx.isMacro = adrEdit('macro (oArgs)', '*') == 0
if m.tx.isMacro then do
call adrEdit '(pds) = dataset'
call adrEdit '(mbr) = member'
parse var oArgs o1 o2
if length(o1) > 8 then do
m.tx.isMacro = 0
end
else if length(o1) > 2 then do
args = pds'('o1')' o2
m.tx.isMacro = 0
end
else do
if mbr == '' then
call err 'edit a pds member not' pds
args = pds'('mbr')' oArgs
do sx=1
call adrEdit '(cha) = data_changed'
if sx > 3 then
call err 'cannot save member'
if cha = 'NO' then
leave
say '...saving member' pds'('mbr')'
call adrEdit 'save', '*'
end
end
end
if args = '' | pos('?', args) > 0 then
exit help()
parse var args dsn fun opts
dsn = dsn2jcl(dsn)
call envPut 'dsn', dsn
call envPut 'pds', dsnSetMbr(dsn)
mbr = dsnGetMbr(dsn)
if mbr = '' | length(mbr) > 7 then
call errHelp 'first arg word not a pds with member <=7:' args
call envPut 'mbr', mbr
call envPut 'mpr', if(length(mbr) <= 5, mbr, left(mbr, 5))
call envPut 'ini', dsnSetMbr(dsn, 'INI')
call envPut 'gen', ''
if abbrev(fun, '-') then do
opts = substr(fun, 2) opts
fun = ''
end
call readDsn dsn, 'M.TX.INP.'
m.tx.save = 0
lx = m.tx.inp.0
if fun = '' then do
call txCont opts
end
else if fun = 'c' then do
call txReset tx'.'inp, opts
end
else if fun = 'r' then do
call txReset tx'.'inp, opts
call txSave
call readDsn dsn, 'M.TX.INP.'
call txCont opts
end
else
call errHelp 'bad fun' fun 'in args' oArgs
call txSave
call dbConn
exit
dbConn: procedure expose m.
parse arg sub
if m.dbConn = sub then
return
if m.dbConn \== '' then
call sqlDisconnect
if sub \== '' then
call sqlConnect sub
m.dbConn = sub
say 'connected to' sub
return
endProcedure dbConn
sqlProc: procedure expose m.
parse arg inp, pJ72
say sqlProc 'j72' pJ72
call sqlStmtsOpt inp, if(pJ72==1, 's') 100
return
endProcedure sqlProc
txCmpRun: procedure expose m.
parse arg ki, inpDsn, outDsn
say 'txCmpRun' inpDsn '->' outDsn
call compRun ki, file(inpDsn), file(outDsn)
say 'txCmpRun -> ended'
return
endProcedure txCmpRun
/*--- remove all history information from testcase,
so it will restart from scratch next time --------------------*/
txReset: procedure expose m.
parse arg i
z = 0
do y=1 to m.i.0
if pos(firstNE(m.i.y), '-+') > 0 then
iterate
z = z + 1
m.i.z = m.i.y
end
m.tx.save = z \= m.i.0
m.i.0 = z
return
endProcedure txReset
/*--- save testcase member if necessary ------------------------------*/
txSave: procedure expose m.
if m.tx.save = 0 then
return
if m.tx.save = 1 then do
if \ m.tx.isMacro then do
call writeDsn envGet('dsn'), 'M.TX.INP.', , 1
return
end
call adrEdit 'del .zf .zl'
do y=1 to m.tx.inp.0
li = m.tx.inp.y
call adrEdit 'line_after .zl = (li)'
end
call adrEdit 'save'
return
end
if m.tx.save = 2 then do
ox = 0
ix = 0
if \ m.tx.isMacro then do
do y=1 to m.tx.aft.0
li = m.tx.aft.y
if verify(strip(li), '0123456789') = 0 then do
ax = strip(li)
do while ix < ax
ox = ox + 1
ix = ix + 1
oo.ox = m.tx.inp.ix
end
end
else do
ox = ox + 1
oo.ox = li
end
end
do ix = ix + 1 to m.tx.inp.0
ox = ox + 1
oo.ox = m.tx.inp.ix
end
call writeDsn envGet('dsn'), 'OO.', ox, 1
return
end
added = 0
do y=1 to m.tx.aft.0
li = m.tx.aft.y
if verify(strip(li), '0123456789') = 0 then
ax = strip(li)
else do
call adrEdit 'line_after ' (added+ax) '= (li)'
added = added + 1
end
end
call adrEdit 'save'
call adrEdit 'save'
return
end
call err 'implement save' m.tx.save
endProcedure txSave
/*--- return first non Space (Empty) char from str, '' if all spaces -*/
firstNE: procedure expose m.
parse arg str
c1 = verify(str, ' ')
if c1 > 0 then
return substr(str, c1, 1)
return ''
endProcedure firstNE
/*--- continue testcase
maximal cnt steps,
until testcase has to wait or is at end --------------------*/
txCont: procedure expose m.
parse arg cnt
fx = txNextFun(1)
if fx < 1 then
return
m.tx.save = 2
m.tx.aft.0 = 0
do until fx < 1
call mAdd 'TX.AFT', fx
parse var m.tx.inp.fx fun opts
code = 'txFun'fun'('quote(strip(opts))')'
say 'code' code
m.tx.outSta = 0
interpret 'res =' code
say 'res' res 'outSta' m.tx.outSta 'from' code
if m.tx.outSta = 2 then
return
if m.tx.outsta \== 1 then
call err 'bad outSta' m.tx.outSta 'after' code
fx = txNextFun(fx+1)
end
return
endProcedure txCont
/*--- continue testcase ----------------------------------------------*/
txNextFun: procedure expose m.
parse arg firstLi
i = 'TX.INP'
nf = 0
do y=firstLi to m.i.0
d.y = ''
w1 = word(m.i.y, 1)
if w1 = '' | abbrev(w1, '*') > 0 then
iterate
if abbrev(w1, '=') | abbrev(w1, '-=') then do
d.y = substr(m.i.y, pos('=', m.i.y))
iterate
end
if abbrev(w1, '-') then
iterate
if \ abbrev(w1, '+') then do
if nf = 0 then
nf = y
d.y = 'ini' /* run ini here to ensure
same sequence with assignments*/
end
else do
nf = 0
parse upper var m.i.y '+' sta rest
say 'sta <'sta'>' rest
if wordPos(sta, 'RUN WAIT') > 0 then
return 0
end
end
do y=firstLi to nf /* redo ini and assignments */
if d.y == '' then
iterate
if d.y == 'ini' then do
if \ m.tx.iniRun then do
call compRun '@', file(envGet('ini')), , 1
m.tx.iniRun = 1
end
end
else if abbrev(d.y, '=') then do
e2 = pos('=', m.i.y, 2)
if e2 < 2 then
call err 'bad assignment line' y':' d.y
call envPut strip(substr(m.i.y, 2, e2-2)),
, strip(substr(m.i.y, e2+1))
end
else
call err 'bad d.'y d.y
end
return nf
endProcedure txNextFun
/*--- output a status line -------------------------------------------*/
txOutSta: procedure expose m.
parse arg op fun, rest
fun = strip(fun)
if op == '+' then do
m.tx.outSta = max(m.tx.outSta,
, 1 + (wordPos(translate(fun), 'RUN WAIT') > 0) )
end
else if op == '=' then do
if words(fun) \== 1 then
call err 'bad var name' fun 'in txOutSta('op fun',' rest')'
call envPut fun, strip(rest)
op = '-='
fun = fun '='
end
else if op \== '-' then
call err 'bad op' op 'in txOutSta('op fun',' rest')'
call mAdd 'TX.AFT', op fun strip(rest)
say 'outSta' m.tx.outSta 'after' op fun strip(rest)
return
endProcedure txOutSta
/*--- do nothing and continue-----------------------------------------*/
txFunNop: procedure expose m.
parse arg opts
if envHasKey('nopCount') then
old = envGet('nopCount')
else
old = 0
call txOutSta '= nopCount', old+1
call txOutSta '+ ok', 'nop'
call txOutSta '- nop', 'opts =' opts
call txOutSta '- nop', 'opts =' opts
return 1
endProcedure txFunNop
/*--- Manual action required -----------------------------------------*/
txFunManual: procedure expose m.
parse arg opts
call txOutSta '+ wait', opts
say 'manual <'opts'>'
return 1
endProcedure txFunManual
/*--- creDb: sql creates, date etc. ----------------------------------*/
txFunCreDb: procedure expose m.
parse arg dst pha
say 'txFunCreDb' dst pha 'ddl' envGet('ddl')
if wordPos(dst, 'src trg') < 1 then
call err 'creDb bad dest should be src or trg not' dst
if pha = '' | verify(pha, '0123456789') > 0 then
call err 'creDb not natural number but' pha
call envPut 'phase' , strip(pha)
call envPut 'env' , dst
call envPut 'subsys' , envGet(dst'Subsys' )
call envPut 'db' , envGet(dst'Db' )
call envPut 'creator', envGet(dst'Creator')
gen = envGet('gen')
if gen \== '' then
gen = gen'('envGet('mpr')left(dst, 1)pha') ::f'
call compRun '=', file(envGet('ddl')), file(gen), 1
/* call adrIsp "view dataset('"gen"')"
*/ call dbConn envGet('subsys')
m.sq.ignore.drop = '-204'
j72 = 0
if envHasKey('j72') then
j72 = envGet('j72')
call sqlProc file(gen), j72
call txOutSta '+ ok', 'creDb' gen
return 1
endProcedure txCreDb
/* copy wsh ab hier ???????*/
/* rexx ****************************************************************
wsh: walter's rexx shell
interfaces:
edit macro: for adhoc evaluation or programming
either block selection: q or qq and b or a
oder mit Directives ($#...) im Text
wsh i: tso interpreter
batch: input in dd wsh
docu: http://chsa4212/host/db2wiki/pmwiki.php?n=Main.Wsh
syntax: http://chsa4212/host/db2wiki/pmwiki.php?n=Main.WshSyn
--- history ------------------------------------------------------------------
10. 2.12 w.keller div catTb* und eLong
********/ /*** end of help ********************************************
2. 6.11 w.keller sql error with current location and dsnTiar
2. 5.11 w.keller sqlStmt etc..
16. 3.11 w.keller basic new r '' ==> r m.class.classO
28. 2.11 w.keller compFile by exprBlock, fix $@do forever, |
7. 2.11 w.keller cleanup block / with sqlPush....
2. 2.11 w.keller simplified syntax, ast for blocks, ? for help
19. 6.10 w.keller open/close stacked mit jUsers, framed eliminiert
19. 5.10 w.keller class wird direkt erzeugt ohne temporary
18. 4.10 w.keller scanUtilInto ==> testCase noch einbauen
17. 4.10 w.keller oMutate in fileTsoList eingebaut
14. 1.10 w.keller batch interface no longer dies on openIfNotYet
CSM.RZ1.P0.EXEC korrigiert
***********************************************************************/
/*--- main code wsh --------------------------------------------------*/
call errReset 'hI'
m.wsh.version = 2.2
parse arg spec
if spec = '?' then
return help('wsh version' m.wsh.version)
os = errOS()
isEdit = 0
if spec = '' & os == 'TSO' then do /* z/OS edit macro */
if sysvar('sysISPF') = 'ACTIVE' then
isEdit = adrEdit('macro (spec) NOPROCESS', '*') == 0
if isEdit then do
if spec = '?' then
return help('version' m.wsh.version)
call adrEdit '(d) = dataset'
call adrEdit '(m) = member'
m.editDsn = dsnSetMbr(d, m)
if spec = '' & m.editDsn = 'A540769.WK.REXX(WSH)' then
spec = 't'
end
end
call scanIni
f1 = spec
rest = ''
if pos(verify(f1, m.scan.alfNum), '1 2') > 0 then
parse var spec f1 2 rest
u1 = translate(f1)
if u1 = 'T' then
return wshTst(rest)
else if u1 = 'I' then
return wshInter(rest)
else if u1 = 'S' then
spec = '$#@ call sqlStmtsOpt $.$sqlIn,' quote(rest) '$#sqlIn#='
call wshIni
inp = ''
out = ''
if os == 'TSO' then do
if isEdit then do
parse value wshEditBegin(spec) with inp out
end
else if sysvar('sysEnv') = 'FORE' then do
end
else do
inp = s2o('-wsh')
useOut = listDsi('OUT FILE')
if \ (useOut = 16 & sysReason = 2) then
out = s2o('-out')
end
end
else if os == 'LINUX' then do
inp = s2o('&in')
out = s2o('&out')
end
else
call err 'implemnt wsh for os' os
m.wshInfo = 'compile'
call compRun spec, inp, out, wshInfo
if isEdit then
call wshEditEnd
exit 0
/*--- actual test case ----------------------------------------------*/
wshIni: procedure expose m.
call compIni
call sqlOIni
call scanWinIni
return
endProcedure wshIni
wshTst: procedure expose m.
parse arg rest
if rest = '' then do /* default */
call sqlConnect DBAF
call catColCom 'cmnBatch', 'DSN_PGROUP_TABLE',
, 'cmnBatch', 'DSN_PGROUP_TABLE_new'
call sqlDisConnect DBAF
return 0
end
c = ''
do wx=1 to words(rest)
c = c 'call tst'word(rest, wx)';'
end
if wx > 2 then
c = c 'call tstTotal;'
say 'wsh interpreting' c
interpret c
return 0
endProcedure wshTst
/*--- interpret user input: rexx, expr, data or shell ---------------*/
wshInter: procedure expose m.
parse arg inp
call wshIni
inp = strip(inp)
mode = '*'
do forever
if pos(left(inp, 1), '/;:*@.-=') > 0 then
parse var inp mode 2 inp
if mode == '/' then
return 0
mode = translate(mode, ';', ':')
if inp <> '' then do
say 'as' mode 'interpreting' inp
if mode = ';' then
interpret inp
else if mode = '*' then
interpret 'say' inp
else do
call errReset 'h', 'say "******* intercepting error";',
'call errSay ggTxt; return "";'
call oRun compile(comp(jBuf(inp)), mode)
call errReset 'h'
end
end
say 'enter' mode 'expression, / for end, ; or * for Rexx' ,
'@ . - = for wsh'
parse pull inp
end
endProcedure wshInter
wshEditBegin: procedure expose m.
parse arg spec
dst = ''
li = ''
m.wsh.editHdr = 0
pc = adrEdit("process dest range Q", 0 4 8 12 16)
if pc = 16 then
call err 'bad range must be q'
if pc = 0 | pc = 8 then do
call adrEdit "(rFi) = lineNum .zFrange"
call adrEdit "(rLa) = lineNum .zLrange"
/* say 'range' rFi '-' rLa */
end
else do
rFi = ''
/* say 'no range' */
end
if pc = 0 | pc = 4 then do
call adrEdit "(dst) = lineNum .zDest"
/* say 'dest' dst */
dst = dst + 1
end
else do
/* say 'no dest' */
if adrEdit("find first '$#out' 1", 4) = 0 then do
call adrEdit "(dst) = cursor"
/* say '$#out' dst */
call adrEdit "(li) = line" dst
m.wsh.editHdr = 1
end
end
m.wsh.editDst = dst
m.wsh.editOut = ''
if dst \== '' then do
m.wsh.editOut = jOpen(jBufTxt(), '>')
if m.wsh.editHdr then
call jWrite m.wsh.editOut, left(li, 50) date('s') time()
end
if rFi == '' then do
call adrEdit "(zLa) = lineNum .zl"
if adrEdit("find first '$#' 1", 4) = 0 then do
call adrEdit "(rFi) = cursor"
call adrEdit "(li) = line" rFi
if abbrev(li, '$#out') | abbrev(li, '$#end') then
rFi = 1
if rFi < dst & dst \== '' then
rLa = dst-1
else
rLa = zLa
end
else do
rFi = 1
rLa = zLa
end
end
/* say 'range' c1 'rc' pc':' rFi '-' rLa 'after' dst */
m.wsh.editIn = jOpen(jBuf(), m.j.cWri)
do lx=rFi to rLa
call adrEdit "(li) = line" lx
call jWrite m.wsh.editIn, li
end
call errReset 'h',
, 'return wshEditErrH(ggTxt, ' rFi',' rLa')'
return jClose(m.wsh.editIn) m.wsh.editOut
endProcedure wshEditBegin
wshEditEnd: procedure expose m.
call errReset 'h'
if m.wsh.editOut == '' then
return 0
call jClose(m.wsh.editOut)
lab = wshEditInsLinSt(m.wsh.editDst, 0, , m.wsh.editOut'.BUF')
call wshEditLocate max(1, m.wsh.editDst-7)
return 1
endProcedure wshEditEnd
wshEditLocate: procedure
parse arg ln
call adrEdit '(la) = linenum .zl'
call adrEdit 'locate ' max(1, min(ln, la - 37))
return
endProcedure wshEditLocate
wshEditErrH: procedure expose m.
parse arg ggTxt, rFi, rLa
call errReset 'h'
oldOut = outDst(jOpen(oNew('JStem', mCut(ggStem, 1)), '>'))
call errSay ggTxt
call outDst oldOut
isScan = 0
if wordPos("pos", m.ggStem.4) > 0 ,
& pos(" in line ", m.ggStem.4) > 0 then do
parse var m.ggStem.4 "pos " pos . " in line " lin":"
if pos = '' then do
parse var m.ggStem.4 " line " lin":"
pos = 0
end
isScan = lin \== ''
end
m.ggStem.1 = '***' m.wshInfo 'error ***'
if m.wshInfo=='compile' & isScan then do
do sx=1 to m.ggStem.0
call out m.ggStem.sx
end
lab = rFi + lin
if pos \= '' then
lab = wshEditInsLin(lab, 'msgline', right('*',pos))
lab = wshEditInsLinSt((rFi+lin),0, 'msgline', ggStem)
call wshEditLocate rFi+lin-25
end
else do
if m.wsh.editOut \== '' then do
do sx=1 to m.ggStem.0
call jWrite m.wsh.editOut, m.ggStem.sx
end
lab = wshEditInsLinSt(m.wsh.editDst, 0, ,
, m.wsh.editOut'.BUF')
call wshEditInsLinSt m.wsh.editDst, m.wsh.editHdr,
, msgline, ggStem
call wshEditLocate max(1, m.wsh.editDst-7)
end
else do
do sx=1 to m.ggStem.0
say m.ggStem.sx
end
end
end
call errCleanup
exit
endSubroutine wshEditErrH
wshEditInsLinCmd: procedure
parse arg wh
if dataType(wh, 'n') then do
if adrEdit("label" wh "= .a", 0 8 12) \= 12 then
return 'line_before .a ='
else
return 'line_after .zl ='
end
else if left(wh, 1) == '.' then
return 'line_before' wh '='
else
return wh
endProcedure wshEditInsLinCmd
wshEditInsLin: procedure
parse arg wh, type
cmd = wshEditInsLinCmd(wh)
do ax=3 to arg()
li = strip(arg(ax), 't')
if li == '' then
iterate
if translate(type) = 'MSGLINE' then do while length(li) > 72
sx = lastPos(' ', li, 72)
if sx < 10 then
sx = 72
one = left(li, sx)
li = ' 'strip(substr(li, sx))
call adrEdit cmd type "(one)"
end
call adrEdit cmd type "(li)", 0 4
end
return cmd
endProcedure wshEditInsLin
wshEditInsLinSt: procedure expose m.
parse arg wh, pl, type, st
if wh == '' then do
do ox=1 to m.st.0
say m.st.ox
end
return ''
end
wh = wh + pl
cmd = wshEditInsLinCmd(wh)
do ax=1 to m.st.0
call wshEditInsLin cmd, type, m.st.ax
end
return cmd
endProcedure wshEditInsLinSt
catTbLastCol: procedure expose m.
parse upper arg cr, tb
sql = "select strip(char(colcount)) || ' ' || strip(c.name) " ,
"from sysibm.sysTables t left join sysibm.sysColumns c" ,
"on c.tbCreator = t.creator and c.tbName = t.name" ,
"and c.colNo = t.colCount" ,
"where t.creator = '"cr"' and t.name = '"tb"'"
if sqlPreAllCl(1, sql, ggSt, ':m.ggLC') = 1 then
return m.ggLc
else if m.ggSt.0 = 0 then
return ''
else
call err m.st.0 'rows in catTbLastCol for' cr'.'tb
endProcedur catTbLastCol
catTbCols: procedure expose m.
parse upper arg cr, tb
sql = "select strip(name) " ,
"from sysibm.sysColumns " ,
"where tbcreator = '"cr"' and tbname = '"tb"'"
if sqlPreAllCl(1, sql, ggSt, ':m.ggSt.sx') < 1 then
return ''
res = m.ggst.1
do cx=2 to m.ggst.0
res = res m.ggst.cx
end
return res
endProcedur catTbCols
catIxKeys: procedure expose m.
parse upper arg cr, ix
sql = "select colSeq, colName, ordering" ,
"from sysibm.sysKeys" ,
"where ixCreator = '"cr"' and ixName = '"ix"'" ,
"order by colSeq"
call sqlPreOpen 1, sql
res = ''
do kx=1 while sqlFetchInto(1, ':sq, :col, :ord')
if sq \= kx then
call err 'expected' kx 'but got colSeq' sq ,
'in index' cr'.'ix'.'col
res = res || strip(col) || translate(ord, '<>?', 'ADR')
end
call sqlClose 1
return res
endProcedur catIxKeys
catColCom: procedure expose m.
parse upper arg fCr, fTb, tCr, tTb
sql = "select t.name, t.colType, t.nulls, t.""DEFAULT""" ,
", coalesce(f.nulls, 'new')" ,
"from sysibm.sysColumns t" ,
"left join sysibm.sysColumns f" ,
"on f.tbCreator = '"fCr"' and f.tbName = '"fTb"'" ,
"and f.name = t.name" ,
"where t.tbCreator = '"tCr"' and t.tbName = '"tTb"'" ,
"order by t.colNo"
call sqlPreOpen 1, sql
pr = ' '
do kx=1 while sqlFetchInto(1, ':na, :ty, :nu, :de, :nn')
/* say kx na ty nu de 'nn' nn */
if pos('CHAR', ty) > 0 then
dv = "''"
else if pos('INT' ,ty) > 0 | wordPos(ty, 'REAL FLOAT') > 0 then
dv = 0
else if ty == 'TIMESTMP' then
dv = '0001-01-01-00.00.00'
else if pos('LOB', ty) > 0 then
dv = ty"('')"
else
dv = '???'
if nu = 'Y' then
dv = 'case when 1=0 then' dv 'else null end'
r = '???'
if ty = 'ROWID' then do
r = '--'
end
else if nn == 'new' then do
if de = 'Y' then
r = '--'
else if nu == 'N' then
r = dv
else
r = 'case when 1=0 then' dv 'else null end'
end
else do
if nu = 'Y' | (nu = nn) then
r = ''
else
r = 'coalesce('na',' dv')'
end
if abbrev(r, '--') then do
r = ' ' r
end
else do
r = pr r
pr = ','
end
if pos('???', r) > 0 then
call err 'no default for type' ty 'in' tCr'.'tTb'.'na
call out r na
end
call sqlClose 1
return
endProcedure catColCom
/*** end wsh, begin all copies ****************************************/
/* copy tstAll begin *************************************************/
/*----------- neu, noch versorgen |||||-------------------------------*/
tstWiki:
call mapReset docs, 'k'
call addFiles docs, 'n', '/media/wkData/literature/notes'
call addFiles docs, 'd', '/media/wkData/literature/docs'
in = jOpen(file('wiki.old'), '<')
out = jOpen(file('wiki.new'), '>')
abc = '(:abc: %l%'
do cx=1 to length(m.scan.alfLC)
c1 = substr(m.scan.alfLC, cx, 1)
abc = abc '¢¢#'c1 '|' c1'!!'
end
call jWrite out, abc ':)'
inTxt = 0
li = m.i
do lx=1 while jRead(in, i)
if 0 then
say length(m.i) m.i
if m.i = '' then
iterate
li = m.i
do forever
bx = pos('¢=', li)
if bx < 1 then
leave
ex = pos('=!', li)
if ex <= bx then
call err '=! before ¢= in' lx li
li = left(li, bx-1)substr(li,bx+2, ex-bx-2)substr(li,ex+2)
end
li = strip(li)
if abbrev(li, '|') then do
w = word(substr(li, 2), 1)
call jWrite out, '¢¢#'w'!! {$:abc}'
call jWrite out, '|||' substr(li, 2)
inTxt=1
iterate
end
if \ inTxt then do
call jWrite out, li
iterate
end
if \ (abbrev(li, '->') | abbrev(li, '#') ,
| abbrev(li, '¢')) then do
call jWrite out, '-<' li
iterate
end
cx = 1
if substr(li, cx, 2) == '->' then
cx = verify(li, ' ', 'n', cx+2)
hasCross = substr(li, cx, 1) == '#'
if hasCross then
cx = verify(li, ' ', 'n', cx+1)
ex = verify(li, '!:\, ', 'm', cx)
ex = ex - (substr(li, ex, 1) \== '!')
hasBr = substr(li, cx, 1) == '¢'
if \ hasBr then
w = substr(li, cx, ex+1-cx)
else if substr(li, ex, 1) == '!' then
w = substr(li, cx+1, ex-1-cx)
else
call err 'br not closed' substr(w, cx+1, ex-1-cx) 'in' lx li
hasPdf = right(w, 4) == '.pdf'
if hasPdf then
w = left(w, length(w)-4)
if verify(w, '#?', 'm') > 0 then do
w = translate(w, '__', '#?')
say '*** changing to' w 'in' lx li
end
o = '-< {def+'w'}'
o = '-< ¢¢'w'!!'
k = translate(w)
if k.k == 1 then
say '*** doppelter key' k 'in:' lx left(li,80)
k.k = 1
dT = ''
if mapHasKey(docs, k) then do
parse value mapGet(docs, k) with dT dC dN
call mapPut docs, k, dT (dC+1) dN
do tx=1 to length(dT)
t1 = substr(dT, tx, 1)
o = o '¢¢Lit'translate(t1)':'word(dN, tx) '|' t1 '!!'
end
end
qSeq = 'nd'
qq = left(qSeq, 1)
qx = 0
do forever
qx = pos('@'qq, li, qx+1)
if qx < 1 then do
qq = substr(qSeq, 1 + pos(qq, qSeq), 1)
qx=0
if qq = '' then
leave
else
iterate
end
if pos(qq, dT) < 1 then do
say '*** @'qq 'document not found:' lx li
iterate
end
do qb = qx-1 by -1 while substr(li, qb, 1) == ' '
end
do qe = qx+2 by 1 while substr(li, qe, 1) == ' '
end
if substr(li, qb, 1) == '.' & substr(li, qe, 1) == '.' then
li = left(li, qb)substr(li, qe+1)
else
li = left(li, qb) substr(li, qe)
end
o = o':' strip(substr(li, ex+1+(substr(li,ex+1,1)==':')))
if 0 then say left(li, 30) '==>' left(o, 30)
call jWrite out, o
end
dk = mapKeys(docs)
do dx=1 to m.dk.0
parse value mapGet(docs, m.dk.dx) with dT dC dN
if dC < 1 then
say '*** document not used:' dT dC dn
end
call jClose in
call jClose out
return
endProcedure tstWiki
addFiles: procedure expose m.
parse arg m, ty, file
fl = jOpen(fileList(file(file)), '<')
do while jRead(fl, fi1)
nm = substr(m.fi1, lastPos('/', m.fi1)+1)
k = translate(left(nm, pos('.', nm)-1))
if \ mapHasKey(m, k) then do
call mapAdd m, k, ty 0 nm
end
else do
parse value mapGet(m, k) with dT dC dN
call mapPut m, k, dT || ty 0 dN nm
end
end
call jClose fl
return
endProcedure addFiles
tstAll: procedure expose m.
call tstBase
call tstComp
call tstDiv
if errOS() = 'TSO' then
call tstZos
call tstTut0
return 0
endProcedure tstAll
/* copx tstZos begin **************************************************/
tstZOs:
call tstTime
call sqlIni
call tstSql
call tstSqlB
call tstSqlStmt
call tstSqlStmts
call tstSqlO1
call tstSqlO2
call tstSqls1
call tstSqlO
call tstTotal
return
endProcedure tstZOs
tstWshBatch:
call adrTso 'alloc dd(WSH) shr dsn(WK.TEXT(WSHBATCH))'
call wshBatch
return adrTso('free dd(WSH)')
tstLmdTiming:
parse arg lev
say timing() lev
call lmdBegin abc, lev
c = 0
do while lmdNext(abc, st.)
c = c + st.0
end
call lmdEnd abc
say timing() lev 'with group - without reading' c
call adrIsp 'lmdinit listid(lmdId) level('lev')'
do c=0 while adrIsp('lmdlist listid(&lmdId) dataset(abc)', 8) = 0
end
call adrIsp 'lmdfree listid(&lmdId)'
say timing() lev 'with list' c
return
endProcedure lmdTiming
tstCsi: procedure expose m.
if 0 then do
call lmd 'A540769.*K'
call tstCsiCla 'A540769.WK.REXX'
call tstCsiCla 'A540769.AAA.DATASETS'
call tstCsiCla 'A540769.RRR.DATASETS'
end
if 0 then do
call tstCsiOpNx 'A540769.WK.*E*'
call tstCsiOpNx 'A540769.AAA.DATASETS'
call tstCsiOpNx 'A540769.RRR.DATASETS'
end
if 1 then do
call tstCsiNxCl 'A540769.WK.**'
call tstCsiNxCl 'DBTF.M*.**'
call tstCsiNxCl 'DBTF.BE*.**'
end
return
tstCsi: procedure expose m.
/* call lmd 'A540769.*K' */
call tstCsi1 'A540769.WK.REXX'
call tstCsi1 'A540769.AAA.DATASETS'
call tstCsi1 'A540769.RRR.DATASETS'
return
tstCsiCla:
parse arg ds
say ds '-->' csiCla(ds)
return
tstCsiOpNx: procedure expose m.
parse arg ds
m = 'NUE123'
s = 'res89'
flds = 'devtyp volser mgmtclas comudsiz NOBYTTRK UDATASIZ HARBA'
say 'csiOpen' ds
call csiOpen m, ds, flds
do while csiNext(m, s)
say m.s 'dev' c2x(m.s.devTyp) ,
'vol' m.s.volSer 'cla' m.s.mgmtclas,
'comuDsiz' m.s.comuDsiz 'noBytTrk' m.s.noBytTrk,
'udatasiz' c2x(m.s.udatasiz) ,
'harba' c2x(m.s.harba)
end
return
tstCsiNxCl: procedure expose m.
parse arg ds
m = 'ABC123'
s = 'efg89'
flds = 'devtyp volser mgmtclas'
say 'csiOpen' ds
call csiOpen m, ds, flds
say timing() 'begin'
do i=1 while csiNext(m, s)
nn = csiArcTape(m.s.volser, m.s.mgmtClas, m.s.devtyp, m.s)
/* oo = csiCla(strip(m.s))
if oo <> nn then
say nn '<>' oo m.s
*/ if i // 1000 = 0 then
say timing() i nn m.s
end
say timing() (i-1) nn m.s
return
endProcedure tstCsiNxCl
listCatClass: procedure expose m.
parse upper arg dsn
call outtrap x., '*'
call adrTso "listcat volume entry('"dsn"')", 4
rt = rc
call outtrap off
/* say 'listct rc =' rt 'lines' x.0 */
cl = ''
vo = ''
if word(x.1, 3) \== dsn then
call out 'err ??? for dsn' dsn 'bad first line' x.1
else if pos('NOT FOUND', x.1) > 0 then
return 'notFound'
else if word(x.1, 1)\== 'NONVSAM' then
call out 'err ??? for dsn' dsn 'bad first line' x.1
do x=2 to x.0 while vo = '' & left(x.x, 1) = ' '
/* say x.x */
p = pos('MANAGEMENTCLASS-', x.x)
if p > 0 then
vo = strip(word(substr(x.x, p+16), 1), 'l', '-')
p = pos('VOLSER--', x.x)
if p > 0 then
vo = strip(word(substr(x.x, p+6), 1), 'l', '-')
p = pos('DEVCLASS--', x.x)
dt = strip(word(substr(x.x, p+8), 1), 'l', '-')
end
/* say 'lc' cl 'vo' vo 'dt' dt 'dsn' dsn */
if vo = '' then
call out '??? err no volume for dsn' dsn
else if vo = 'ARCIVE' then
res = 'arcive'
else if cl = '' then
res = 'tape'
else
res = cl
if abbrev(res, 'ar') \= abbrev(dt, "X'0") ,
| abbrev(res, 'ta') \= abbrev(dt, "X'7") ,
| (left(res, 1) >= 'A') \= abbrev(dt, "X'3") then
call out 'err ??? mismatch cl' cl 'vo' vo 'dt' dt 'dsn' dsn
return res
endProcedure listCatClass
/* copx tstZos end **************************************************/
/* copx tstDiv begin **************************************************/
tstDiv:
call tstSorQ
call tstSort
call tstMatch
call tstTotal
return
endProcedure tstDiv
tstSorQ: procedure expose m. /* wkTst??? remove once upon a time */
/*
$=/tstSorQ/
### start tst tstSorQ #############################################
sort 29 c ACHT DREI DREIZEHN EINS ELF FUENF M.I.25 M.I.26 M.I.27 M+
..I.29 NEUN SECHS SIEBEN VIER VIERZEHN ZEHN ZWEI ZWOELF 0 1 1 1 2 2+
. 3 3 4 4
sort 22 c ACHT DREIZEHN ELF M.I.25 M.I.26 M.I.27 M.I.29 NEUN VIERZ+
EHN ZEHN ZWOELF 0 1 1 1 2 2 3 3 4 4
sort 15 c M.I.25 M.I.26 M.I.27 M.I.29 0 1 1 1 2 2 3 3 4 4
sort 8 c M.I.25 M.I.26 M.I.27 M.I.29 0 1 1
sort 1 M.I.29
$/tstSorQ/ */
/*
$=/tstSorQAscii/
### start tst tstSorQAscii ########################################
sort 29 0 1 1 1 2 2 3 3 4 4 ACHT DREI DREIZEHN EINS ELF FUENF M.I.+
25 M.I.26 M.I.27 M.I.29 NEUN SECHS SIEBEN VIER VIERZEHN ZEHN ZWEI Z+
WOELF c
sort 22 0 1 1 1 2 2 3 3 4 4 ACHT DREIZEHN ELF M.I.25 M.I.26 M.I.27+
. M.I.29 NEUN VIERZEHN ZEHN ZWOELF c
sort 15 0 1 1 1 2 2 3 3 4 4 M.I.25 M.I.26 M.I.27 M.I.29 c
sort 8 0 1 1 M.I.25 M.I.26 M.I.27 M.I.29 c
sort 1 M.I.29
$/tstSorQAscii/ */
if errOS() == 'LINUX' then
call tst t, "tstSorQAscii"
else
call tst t, "tstSorQ"
call mAdd mCut(i, 0), eins, zwei, drei, vier, fuenf, sechs,
,sieben, acht, neun, zehn, elf, zwoelf, dreizehn, vierzehn
call mAdd i, 1, 2, 3, 4, 4, 3, 2, 1, 0, 1,
, 'M.I.25', 'M.I.26', 'M.I.27', 'c', 'M.I.29'
do yy = m.i.0 by -1 to 1
do x = 0 to yy
m.i.0 = x
call sort i, o
m = ''
la = ''
if x <> m.o.0 then
call err 'size mismatch' x '<>' m.o.0
do y=1 to m.o.0
m = m m.o.y
if \ (la << m.o.y) then
call err 'sort mismatch' yy x y '\' la '<<' m.o.y
end
end
if yy // 7 = 1 then
call tstOut t, 'sort' yy m
do x = 2 to yy
x1 = x-1
m.i.x1 = m.i.x
end
end
call tstEnd t
return
endProcedure tstSorQ
tstSort: procedure expose m.
call tstSortComp
call tstSortComp '<<='
call tstSortComp 'm.aLe <<= m.aRi'
call tstSortComp 'if 1 then cmp = m.aLe <<= m.aRi; else call err sd'
return
endProcedure tstSort
tstSortComp: procedure expose m.
parse arg cmp
/*
$=/tstSort/
### start tst tstSort #############################################
sort 29 c ACHT DREI DREIZEHN EINS ELF FUENF M.I.25 M.I.26 M.I.27 M+
..I.29 NEUN SECHS SIEBEN VIER VIERZEHN ZEHN ZWEI ZWOELF 0 1 1 1 2 2+
. 3 3 4 4
sort 22 c ACHT DREIZEHN ELF M.I.25 M.I.26 M.I.27 M.I.29 NEUN VIERZ+
EHN ZEHN ZWOELF 0 1 1 1 2 2 3 3 4 4
sort 15 c M.I.25 M.I.26 M.I.27 M.I.29 0 1 1 1 2 2 3 3 4 4
sort 8 c M.I.25 M.I.26 M.I.27 M.I.29 0 1 1
sort 1 M.I.29
$/tstSort/ */
/*
$=/tstSortAscii/
### start tst tstSortAscii ########################################
sort 29 0 1 1 1 2 2 3 3 4 4 ACHT DREI DREIZEHN EINS ELF FUENF M.I.+
25 M.I.26 M.I.27 M.I.29 NEUN SECHS SIEBEN VIER VIERZEHN ZEHN ZWEI Z+
WOELF c
sort 22 0 1 1 1 2 2 3 3 4 4 ACHT DREIZEHN ELF M.I.25 M.I.26 M.I.27+
. M.I.29 NEUN VIERZEHN ZEHN ZWOELF c
sort 15 0 1 1 1 2 2 3 3 4 4 M.I.25 M.I.26 M.I.27 M.I.29 c
sort 8 0 1 1 M.I.25 M.I.26 M.I.27 M.I.29 c
sort 1 M.I.29
$/tstSortAscii/ */
say '### start with comparator' cmp '###'
if errOS() == 'LINUX' then
call tst t, "tstSortAscii"
else
call tst t, "tstSort"
call mAdd mCut(i, 0), eins, zwei, drei, vier, fuenf, sechs,
,sieben, acht, neun, zehn, elf, zwoelf, dreizehn, vierzehn
call mAdd i, 1, 2, 3, 4, 4, 3, 2, 1, 0, 1,
, 'M.I.25', 'M.I.26', 'M.I.27', 'c', 'M.I.29'
do yy = m.i.0 by -1 to 1
do x = 0 to yy
m.i.0 = x
call sort i, o, cmp
m = ''
la = ''
if x <> m.o.0 then
call err 'size mismatch' x '<>' m.o.0
do y=1 to m.o.0
m = m m.o.y
if \ (la << m.o.y) then
call err 'sort mismatch' yy x y '\' la '<<' m.o.y
end
end
if yy // 7 = 1 then
call tstOut t, 'sort' yy m
do x = 2 to yy
x1 = x-1
m.i.x1 = m.i.x
end
end
call tstEnd t
return
endProcedure tstSort
tstMatch: procedure expose m.
/*
$=/tstMatch/
### start tst tstMatch ############################################
match(eins, e?n*) 1 1 2,i,s trans(E?N*) EiNs
match(eins, eins) 1 1 0 trans(EINS) EINS
match(e1nss, e?n*) 1 1 2,1,ss trans(?*) 1ss
match(eiinss, e?n*) 0 0 -9
match(einss, e?n *) 0 0 -9
match(ein s, e?n *) 1 1 2,i,s trans(E?N *) EiN s
match(ein abss , ?i*b*) 1 1 3,e,n a,ss trans(?I*B*) eIn aBss .
match(ein abss wie gehtsssxdirx und auch , ) 0 0 -9
match(ies000, *000) 1 1 1,ies trans(*000) ies000
match(xx0x0000, *000) 1 1 1,xx0x0 trans(*000) xx0x0000
match(000x00000xx, 000*) 1 1 1,x00000xx trans(000*) 000x00000xx
match(000xx, *0*) 1 1 2,00,xx trans(ab*cd*ef) ab00cdxxef
$/tstMatch/ */
call tst t, "tstMatch"
call tstOut t, matchTest1('eins', 'e?n*' )
call tstOut t, matchTest1('eins', 'eins' )
call tstOut t, matchTest1('e1nss', 'e?n*', '?*' )
call tstOut t, matchTest1('eiinss', 'e?n*' )
call tstOut t, matchTest1('einss', 'e?n *' )
call tstOut t, matchTest1('ein s', 'e?n *' )
call tstOut t, matchTest1('ein abss ', '?i*b*' )
call tstOut t, matchTest1('ein abss wie gehtsssxdirx und auch ' )
call tstOut t, matchTest1('ies000', '*000' )
call tstOut t, matchTest1('xx0x0000', '*000' )
call tstOut t, matchTest1('000x00000xx', '000*' )
call tstOut t, matchTest1('000xx', '*0*', 'ab*cd*ef' )
call tstEnd t
return
matchTest1:
parse arg w, m, m2
r = 'match('w',' m')' match(w, m) match(w, m, vv) m.vv.0
do x=1 to m.vv.0
r = r','m.vv.x
end
if m2 = '' then
m2 = translate(m)
if m.vv.0 >= 0 then
r = r 'trans('m2')' matchTrans(m2, vv)
return r
endProcedure matchTest1
tstTime: procedure
/* Winterzeit dez 2011
$=/tstTime/
### start tst tstTime #############################################
Lrsn2Lzt(C5E963363741) 2010-05-01-11.34.56.789008
Achtung: output ist abhaengig von Winter/Sommerzeit und LeapSecs
timeZone 3600.00000 leapSecs 24.0000000
2jul(2011-03-31-14.35.01.234567) 11090
Lrsn2Gmt(C5E963363741) 2010-05-01-10.35.20.789008
Lrsn2Lzt(C5E963363741) 2010-05-01-11.34.56.789008
gmt2Lrsn(2011-03-31-14.35.01.234567) C78D87B86E38
lzt2Lrsn(2011-03-31-14.35.01.234567) C78D7A661758
Lrsn2Gmt(gmt2Lrsn(2011-03-31-14.35.01.234567) 2011-03-31-14.35.01.2+
34560
gmt2Lrsn(Lrsn2Gmt(C5E963363741) C5E963363741
Lrsn2LZt(LZt2Lrsn(2011-03-31-14.35.01.234567) 2011-03-31-14.35.01.2+
34560
LZt2Stc(Lrsn2LZt(C5E963363741)( C5E963363741
$/tstTime/
Sommerzeit Jun 2011
$=/tstTimeSom/
### start tst tstTime #############################################
Lrsn2Lzt(C5E963363741) 2010-05-01-12.34.56.789008 <<<<<
2jul(2011-03-31-14.35.01.234567) 11090
Lrsn2Gmt(C5E963363741) 2010-05-01-10.35.20.789008
Lrsn2Lzt(C5E963363741) 2010-05-01-12.34.56.789008 <<<<<
gmt2Lrsn(2011-03-31-14.35.01.234567) C78D87B86E38
lzt2Lrsn(2011-03-31-14.35.01.234567) C78D6CFCDD18 <<<<<
Lrsn2Gmt(gmt2Lrsn(2011-03-31-14.35.01.234567) 2011-03-31-14.35.01.2+
34560
gmt2Lrsn(Lrsn2Gmt(C5E963363741) C5E963363741
Lrsn2LZt(LZt2Lrsn(2011-03-31-14.35.01.234567) 2011-03-31-14.35.01.2+
34560
LZt2Stc(Lrsn2LZt(C5E963363741)( C5E963363741
$/tstTime/ */
call jIni
call tst t, 'tstTime'
t1 = '2011-03-31-14.35.01.234567'
s1 = 'C5E963363741'
call out 'Lrsn2Lzt('s1')' timeLrsn2Lzt(s1)
call out ,
'Achtung: output ist abhaengig von Winter/Sommerzeit und LeapSecs'
call out 'timeZone' m.timeZone * m.timeStckUnit ,
'leapSecs' m.timeLeap * m.timeStckUnit
call timeReadCvt 1
call out '2jul('t1') ' time2jul(t1)
call out 'Lrsn2Gmt('s1')' timeLrsn2Gmt(s1)
call out 'Lrsn2Lzt('s1')' timeLrsn2Lzt(s1)
call out 'gmt2Lrsn('t1')' timeGmt2Lrsn(t1)
call out 'lzt2Lrsn('t1')' timeLzt2Lrsn(t1)
call out 'Lrsn2Gmt(gmt2Lrsn('t1')' timeLrsn2Gmt(timeGmt2Lrsn(t1))
call out 'gmt2Lrsn(Lrsn2Gmt('s1')' timeGmt2Lrsn(timeLrsn2Gmt(s1))
call out 'Lrsn2LZt(LZt2Lrsn('t1')' timeLrsn2LZt(timeLZt2Lrsn(t1))
call out 'LZt2Stc(Lrsn2LZt('s1')(' timeLZt2Lrsn(timeLrsn2LZt(s1))
call tstEnd t
return
endProcedure tstTime
/* copx tstDiv end **************************************************/
/* copx tstSql begin **************************************************/
tstSqlUtils: procedure expose m.
call sqlConnect 'DBAF'
id = 'A540769.dsnUtils'
rst = 'NO'
retcode = -9876
e = ''
z = 0
st = "TEMPLATE TCOPYD",
"DSN('&SSID..&JO..&US..P&PART(2)..D&DATE(3)..T&TIME.')",
"DATACLAS(NULL12) MGMTCLAS(COM#A011) STORCLAS(FAR$N)",
"SPACE (150,3750) TRK UNCNT 59;",
"listdef abc include tablespace DA540769.A002* partlevel;",
"listdef mf include tablespace MF01A1A.A110A partlevel;",
"copy list abc copyddn(tcopyd) shrlevel change;"
st = translate(st)
call sqlExec "call SYSPROC.DSNUTILS ( :id, :rst,",
":st,:retcode, :ANY" copies(',:e,:e,:z',12) ")"
call sqlExec ,
'ASSOCIATE LOCATOR (:RESULTS) WITH PROCEDURE SYSPROC.DSNUTILS'
say 'results' results
call sqlExec 'ALLOCATE C111 CURSOR FOR RESULT SET :RESULTS'
say 'allocated c111'
do while sqlExec('fetch c111 into :seq, :txt', 0 100) = 0
say 'sysPrint' seq strip(txt, 't')
end
call sqlExec 'close c111'
say 'closed'
call sqlDisconnect
exit
endProcedure tstSqlUtils
tstSqlStored: procedure expose m.
call sqlConnect 'DBAF'
rst = 'NO'
retcode = -9876
e = ''
z = 0
st = "abc"
call sqlExec "call SYSPROC.COMMAND ( :st, :rst)"
say 'after call st='st 'rst='rst
call sqlExec ,
'ASSOCIATE LOCATOR (:RESULTS) WITH PROCEDURE SYSPROC.COMMAND'
say 'results' results
call sqlExec 'ALLOCATE C111 CURSOR FOR RESULT SET :RESULTS'
say 'allocated c111'
do while sqlExec('fetch c111 into :seq, :txt', 0 100) = 0
say 'sysPrint' seq strip(txt, 't')
end
call sqlExec 'close c111'
say 'closed'
call sqlDisconnect
return
endProcedure tstSqlStored
tstSqlStoredWK: procedure expose m.
call sqlConnect 'DBAF'
/* st = "direct wkUtiSub"
rst = 'NO'
say 'before call st='st 'rst='rst
call sqlExec "call A540769.WKUTILSUB ( :st, :rst)"
say 'after call st='st 'rst='rst
*/ rst = 'NO'
retcode = -9876
e = ''
z = 0
prc = 'DB2UTIL.DB2UTIL'
st = "DA540769.A2*" /* DA540769.A1*" */
say "call" prc "("st", ...)"
call sqlExec "call" prc "(:st, :rst)"
say 'after call st='st 'rst='rst
call sqlExec ,
'ASSOCIATE LOCATOR (:RESULTS) WITH PROCEDURE' prc
/* say 'results' results */
call sqlExec 'ALLOCATE C111 CURSOR FOR RESULT SET :RESULTS'
say ''
say '***** utility output'
do while sqlExec('fetch c111 into :seq, :txt', 0 100) = 0
say 'sysPrint' seq strip(txt, 't')
end
call sqlExec 'close c111'
say '***** end output'
call sqlDisconnect
return 0
endProcedure tstSqlStoredWK
tstSqlStoredSQL1: procedure expose m.
call sqlConnect 'DBIA'
rst = 'NO'
retcode = -9876
e = ''
z = 0
st = "DA540769.A2* DA540769.A1*"
call sqlExec "call A540769.WKSQL1 ( :st, :rst)"
say 'after call st='st 'rst='rst
call sqlExec ,
'ASSOCIATE LOCATOR (:RESULTS) WITH PROCEDURE A540769.WKUTIL'
say 'results' results
call sqlExec 'ALLOCATE C111 CURSOR FOR RESULT SET :RESULTS'
say 'allocated c111'
do while sqlExec('fetch c111 into :seq, :txt', 0 100) = 0
say 'sysPrint' seq strip(txt, 't')
end
call sqlExec 'close c111'
say 'closed'
call sqlDisconnect
return
endProcedure tstSqlStoredSQL1
tstSqlTriggerTiming:
parse upper arg tb ni
m.noInsert = ni == 0
cnt = 200000
if tb = '' then
TB = 'GDB9998.TWK511TRI'
call sqlConnect dbaf
say timing() 'noInsert' m.noInsert 'tb' tb
call sql2St 49, '*', cc, 'select max(pri) MX from' tb
if m.cc.1.mx == m.sqlNull then
m.cc.1.mx = 0
von = m.cc.1.mx + 1
bis = m.cc.1.mx + cnt
say m.cc.0 'max' m.cc.1.mx 'von' von 'bis' bis 'count' cnt tb
if right(tb, 2) = 'A1' then do
call sqlPrepare 3, 'insert into' tb '(pri, short, long, par)' ,
'values (?, ?, ?, ?)'
do ax=von to bis
call sqlExecute 3, ax,
, ax 'wsh short', ax 'wsh long long long long long ',
, (ax-1) // 1000 + 1
end
end
else do
call sqlPrepare 3, 'insert into' tb '(pri, short, long)' ,
'values (?, ?, ?)'
do ax=von to bis
call sqlExecute 3, ax,
, ax 'wsh short', ax 'wsh long long long long long ',
, (ax-1) // 1000 + 1
end
end
/* call sqlLn 5,,, 'select * from' tb 'where pri >=' von */
call sqlExImm 'commit'
say timing()
call sqlDisconnect
return
endProcedure tstSqlTriggerTiming
tstSql: procedure expose m.
cx = 2
call sqlConDis
call jIni
/*
$=/tstSql/
### start tst tstSql ##############################################
*** err: SQLCODE = -204: A540769.SYSDUMMY IS AN UNDEFINED NAME
. e 1: stmt = execSql prepare s7 from :src
. e 2: with from :src = select * from sysdummy
fetchA 1 ab= m.abcdef.123.AB abc ef= efg
fetchA 0 ab= m.abcdef.123.AB abc ef= efg
sqlVars :M.STST.A :M.STST.A.sqlInd, :M.STST.B :M.STST.B.sqlInd, :M.+
STST.C :M.STST.C.sqlInd
1 all from dummy1
a=a b=2 c=0
sqlVarsNull 1
a=a b=2 c=---
fetchBT 1 SYSTABLES
fetchBT 0 SYSTABLES
fetchBI 1 SYSINDEXES
fetchBI 0 SYSINDEXES
opAllCl 3
fetchC 1 SYSTABLES
fetchC 2 SYSTABLESPACE
fetchC 3 SYSTABLESPACESTATS
PreAllCl 3
fetchD 1 SYSIBM.SYSTABLES
fetchD 2 SYSIBM.SYSTABLESPACE
fetchD 3 SYSIBM.SYSTABLESPACESTATS
$/tstSql/ */
call tst t, "tstSql"
src = 'select * from sysdummy'
call sqlExec 'prepare s7 from :src'
call sqlPrepare cx, "select 'abc' , 'efg'",
'from sysibm.sysDummy1'
call sqlExec 'declare c'cx 'cursor for s'cx
call sqlOpen cx
a = 'abcdef'
b = 123
do i=1 to 2
call out 'fetchA' sqlFetchInto(cx, ':m.a.b.ab, :m.a.b.ef') ,
'ab= m.'a'.' || b'.'ab m.a.b.ab 'ef=' m.a.b.ef
end
call sqlClose cx
drop stst a b c m.stst.a m.stst.b m.stst.c
sv = sqlVars('M.STST', A B C , 1)
call out 'sqlVars' sv
call out sqlPreAllCl(cx,
, "select 'a', 2, case when 1=0 then 1 else null end ",
"from sysibm.sysDummy1",
, stst, sv) 'all from dummy1'
call out 'a='m.stst.a 'b='m.stst.b 'c='m.stst.c
call out 'sqlVarsNull' sqlVarsNull(stst, A B C)
call out 'a='m.stst.a 'b='m.stst.b 'c='m.stst.c
call sqlPreDeclare cx, "select name" ,
"from sysibm.sysTables" ,
"where creator = 'SYSIBM' and name = ?"
call sqlOpen cx, 'SYSTABLES'
call out 'fetchBT' sqlFetchInto(cx, ':NM') nm
call out 'fetchBT' sqlFetchInto(cx, ':NM') nm
call sqlClose cx
call sqlOpen cx, 'SYSINDEXES'
a = 'a b c'
b = 1234565687687234
call out 'fetchBI' sqlFetchInto(cx, ':NM') nm
call out 'fetchBI' sqlFetchInto(cx, ':NM') nm
call sqlClose cx
src = 'select name' ,
"from sysibm.sysTables" ,
"where creator = 'SYSIBM' and name like 'SYSTABLES%'",
"fetch first 3 rows only"
call sqlPreDeclare cx, src
st = 'wie geht'' s'
call out 'opAllCl' sqlOpAllCl(cx, st, ':M.ST.SX.NAME')
do x=1 to m.st.0
call out 'fetchC' x m.st.x.name
end
st = 'auch noch'
src = "select strip(creator) || '.' || strip(name)" substr(src,12)
call out 'PreAllCl' sqlPreAllCl(cx+11, src, st, ':M.ST.SX.NAME')
do x=1 to m.st.0
call out 'fetchD' x m.st.x.name
end
call tstEnd t
return
endProcedure tstSql
tstSqlB: procedure expose m.
/*
$=/tstSqlB/
### start tst tstSqlB #############################################
#jIn 1# select strip(name) "tb", strip(creator) cr
#jIn 2# , case when name = 'SYSTABLES' then 1 else null end
#jIn 3# from sysibm.sysTables
#jIn 4# where creator = 'SYSIBM' and name like 'SYSTABLES%'
#jIn 5# .
#jIn 6# order by name
#jIn 7# fetch first 3 rows only
#jIn eof 8#
dest1.fet: SYSTABLES SYSIBM 1
dest2.fet: SYSTABLESPACE SYSIBM ---
dest3.fet: SYSTABLESPACESTATS SYSIBM ---
$/tstSqlB/ */
call tst t, "tstSqlB"
cx = 9
call sqlConDis
call jIni
call mAdd mCut(t'.IN', 0),
, 'select strip(name) "tb", strip(creator) cr' ,
, ", case when name = 'SYSTABLES' then 1 else null end" ,
, "from sysibm.sysTables" ,
, "where creator = 'SYSIBM' and name like 'SYSTABLES%'", ,
, "order by name",
, "fetch first 3 rows only"
call sqlPreOpen cx
do qx=1 while sqlFetch(cx, 'dest'qx'.fet', 'n')
dst = 'dest'qx'.fet'
call out dst':' m.dst.tb m.dst.cr m.dst.col3
drop m.dst.tb m.dst.cr m.dst.col3
end
call tstEnd t
return
endProcedure tstSqlB
tstSqlO: procedure expose m.
/*
$=/tstSqlO/
### start tst tstSqlO #############################################
*** err: SQLCODE = -204: A540769.SYSDUMMY IS AN UNDEFINED NAME
. e 1: stmt = execSql prepare s7 from :src
. e 2: with from :src = select * from sysdummy
REQD=Y col=123 case=--- .sqlInd:-1 col5=anonym geburri=1956-04-01+
-06.00.00.000000
$/tstSqlO/
*/
call sqlOConnect
call sqlStmt 'set current schema = A540769';
call tst t, "tstSqlO"
src = 'select * from sysdummy'
call sqlExec 'prepare s7 from :src'
r = sqlRdr( ,
"select d.*, 123, timestamp('01.04.1956','06:00:00')" ,
'"geburri walter",',
'case when 1=0 then 1 else null end caseNull,',
"'anonym'" ,
'from sysibm.sysdummy1 d')
call jOpen r, '<'
do while assNN('o', jReadO(r))
call out 'REQD='m.o.IBMREQD 'col='m.o.col2,
'case='m.o.CASENULL '.sqlInd:'m.o.caseNull.sqlInd,
'col5='m.o.col5,
'geburri='m.o.GEBURRI
end
call jClose r
call tstEnd t
return
endProcedure tstSqlO
tstSqlO1: procedure expose m.
/*
$=/tstSqlO1/
### start tst tstSqlO1 ############################################
tstR: @tstWriteoV2 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLEPART
tstR: @tstWriteoV3 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLEPART_HIST
tstR: @tstWriteoV4 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLES
tstR: @tstWriteoV5 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLESPACE
--- writeAll
tstR: @tstWriteoV6 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLEPART
tstR: @tstWriteoV7 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLEPART_HIST
tstR: @tstWriteoV8 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLES
tstR: @tstWriteoV9 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLESPACE
$/tstSqlO1/
*/
call sqlOConnect
call tst t, "tstSqlO1"
sq = sqlRdr("select strip(creator) cr, strip(name) tb",
"from sysibm.sysTables",
"where creator='SYSIBM' and name like 'SYSTABL%'",
"order by 2 fetch first 4 rows only")
call jOpen sq, m.j.cRead
do while assNN('ABC', jReadO(sq))
if m.sq.rowCount = 1 then
call mAdd t.trans, className(m.sq.type) '<tstSqlO1Type>'
call outO abc
end
call jClose sq
call out '--- writeAll'
call pipeWriteAll sq
call tstEnd t
return 0
endProcedure tstSqlO1
tstSqlO2: procedure expose m.
/*
$=/tstSqlO2/
### start tst tstSqlO2 ############################################
CR TB RR
SYSIBM SYSTABLEPART 1
SYSIBM SYSTABLEPART_HIST 4
SYSIBM SYSTABLES 9
SYSIBM SYSTABLESPACE 16
$/tstSqlO2/
*/
call sqlOConnect
call tst t, "tstSqlO2"
call pipeBegin
call out "select strip(creator) cr, strip(name) tb,"
call out "(row_number()over())*(row_number()over()) rr"
call out "from sysibm.sysTables"
call out "where creator='SYSIBM' and name like 'SYSTABL%'"
call out "order by 2 fetch first 4 rows only"
call pipe
call sqlSel
call pipeLast
call fmtFTab abc
call pipeEnd
call tstEnd t
return 0
endProcedure tstSqlO2
tstSqlS1: procedure expose m.
/*
$=/tstSqlS1/
### start tst tstSqlS1 ############################################
select c, a from sysibm.sysDummy1
tstR: @tstWriteoV2 isA :<cla sql c a>
tstR: .C = 1
tstR: .A = a
select ... where 1=0
tstR: @ obj null
$/tstSqlS1/
*/
call sqlOIni
call tst t, "tstSqlS1"
call sqlConnect dbaf
s1 = fileSingle( ,
sqlRdr("select count(*) c, 'a' a from sysibm.sysdummy1"))
call mAdd t.trans, className(objClass(s1)) '<cla sql c a>'
call out 'select c, a from sysibm.sysDummy1'
call tstWriteO t, s1
call out 'select ... where 1=0'
call tstWriteO t, fileSingle( ,
sqlRdr("select*from sysibm.sysdummy1 where 1=0"), '')
call tstEnd t
return
endProcedure tstSqlS1
tstSqlStmt: procedure expose m.
/*
$=/tstSqlStmt/
### start tst tstSqlStmt ##########################################
*** err: SQLCODE = -713: THE REPLACEMENT VALUE FOR CURRENT SCHEMA I+
S
. e 1: INVALID
. e 2: stmt = execSql execute immediate :ggSrc
. e 3: with immediate :ggSrc = set current schema = 'sysibm'
sqlCode -713: set current schema = 'sysibm'
sqlCode 0: set current schema = sysibm
tstR: @tstWriteoV2 isA :<sql?sc>
tstR: .C = SYSIBM
1 rows fetched: select current schema c from sysDummy1
tstR: @tstWriteoV3 isA :<sql?sc>
tstR: .C = SYSIBM
1 rows fetched: (select current schema c from sysDummy1)
$/tstSqlStmt/ */
call sqlOConnect
call tst t, "tstSqlStmt"
cn = className(classNew('n* SQL u f C v'))
call mAdd t.trans, cn '<sql?sc>'
call tstOut t, sqlStmt("set current schema = 'sysibm'")
call tstOut t, sqlStmt(" set current schema = sysibm ")
call tstOut t, sqlStmt(" select current schema c from sysDummy1",
, ,'o')
call tstOut t, sqlStmt(" (select current schema c from sysDummy1)",
, ,'o')
call tstEnd t
return
endProcedure tstSqlStmt
tstSqlStmts: procedure expose m.
/*
$=/tstSqlStmts/
### start tst tstSqlStmts #########################################
*** err: SQLCODE = -104: ILLEGAL SYMBOL "BLABLA". SOME SYMBOLS THAT
. e 1: MIGHT BE LEGAL ARE: <ERR_STMT> <WNG_STMT> GET SQL SAV+
EPOINT HOLD
. e 2: FREE ASSOCIATE
. e 3: src blabla
. e 4: > <<<pos 1 of 7<<<
. e 5: stmt = execSql blabla .
sqlCode -104: blabla
sqlCode 0: set current schema= sysIbm
C
1
1 rows fetched: select count(*) "c" from sysDummy1 with /* comm */+
. ur
C
1
1 rows fetched: select count(*) "c" from sysDummy1 with ur
#jIn 1# set current -- sdf
#jIn 2# schema = s100447;
sqlCode 0: set current schema = s100447
#jIn eof 3#
$/tstSqlStmts/ */
call sqlOConnect
call scanReadIni
call scanWinIni
call tst t, "tstSqlStmts"
call sqlStmts "blabla ;;set current schema= sysIbm "
b = jBuf('select count(*) "c" from sysDummy1 --com' ,
,'with /* comm */ ur;')
call sqlStmts b
call sqlStmts b, , '-c72'
call mAdd mCut(t'.IN', 0), 'set current -- sdf', 'schema = s100447;'
call sqlStmts
call tstEnd t
return
endProcedure tstSqlStmts
/* copx tstSql end ***************************************************/
/* copx tstComp begin **************************************************
test the wsh compiler
***********************************************************************/
tstComp: procedure expose m.
call compIni
call tstCompDataConst
call tstCompDataVars
call tstCompShell
call tstCompPrimary
call tstCompExpr
call tstCompFile
call tstCompStmt
call tstCompStmtA
call tstCompDir
call tstCompObj
call tstCompORun
call tstCompDataIO
call tstCompPipe
call tstCompRedir
call tstCompComp
call tstCompSyntax
call tstCompSql
call tstTotal
return
endProcedure tstComp
tstComp1: procedure expose m.
parse arg ty nm cnt
c1 = 0
if cnt = 0 |cnt = '+' then do
c1 = cnt
cnt = ''
end
call jIni
src = jBuf()
call jOpen src, m.j.cWri
do sx=2 to arg()
call jWrite src, arg(sx)
end
call tstComp2 nm, ty, jClose(src), , c1, cnt
return
endProcedure tstComp1
tstComp2: procedure expose m.
parse arg nm, spec, src, compSt
call compIni
call tst t, nm, compSt
if src == '' then do
src = jBuf()
call tst4dp src'.BUF', mapInline(nm'Src')
end
m.t.moreOutOk = abbrev(strip(arg(5)), '+')
cmp = comp(src)
call out 'compile' spec',' (m.src.buf.0) 'lines:' m.src.buf.1
r = compile(cmp, spec)
noSyn = m.t.errHand = 0
coErr = m.t.err
say if( noSyn, "compiled", "*** syntaxed") r ":" objMet(r, 'oRun')
cnt = 0
do ax = 5 to max(arg(), 5) while m.t.err = coErr & noSyn
a1 = strip(arg(ax))
if a1 == '' & arg() >= 5 then
iterate
if abbrev(a1, '+') then do
m.t.moreOutOk = 1
a1 = strip(substr(a1, 2))
end
if datatype(a1, 'n') then
cnt = a1
else if a1 \== '' then
call err 'tstComp2 bad arg('ax')' arg(ax)
if cnt = 0 then do
call mCut 'T.IN', 0
call out "run without input"
end
else do
call mAdd mCut('T.IN', 0),
,"eins zwei drei", "zehn elf zwoelf?",
, "zwanzig 21 22 23 24 ... 29|"
do lx=4 to cnt
call mAdd 'T.IN', left(lx "line" lx, lx+9, '-')';'
end
call out "run with" cnt "inputs"
end
m.t.inIx = 0
call oRun r
end
call tstEnd t
return
endProcedure tstComp2
tstCompDataConst: procedure expose m.
/*
$=/tstCompDataConst/
### start tst tstCompDataConst ####################################
compile =, 8 lines: Lline one, $** asdf
run without input
. Lline one, .
line two..
line threecontinued on 4
line five fortsetzung
line six fortsetzung
$/tstCompDataConst/ */
call tstComp1 '= tstCompDataConst',
, ' Lline one, $** asdf',
, 'line two.',
, 'line three$*+ bla bla' ,
, 'continued on 4',
, 'line five $*( und so',
, 'weiter $abc $? $''$*)'' $"$*)" und weiter $*) fortsetzung',
, 'line six $*( und $*( $** $*( so',
, 'weiter $abc $? $*)'' $"$*)" und weiter $*) fortsetzung'
/*
$=/tstCompDataConstBefAftComm1/
### start tst tstCompDataConstBefAftComm1 #########################
compile =, 3 lines: $*(anfangs com.$*) $*(plus$*) $** x
run without input
the only line;
$/tstCompDataConstBefAftComm1/ */
call tstComp1 '= tstCompDataConstBefAftComm1',
, ' $*(anfangs com.$*) $*(plus$*) $** x',
, 'the only line;',
, ' $*(end kommentar$*) '
/*
$=/tstCompDataConstBefAftComm2/
### start tst tstCompDataConstBefAftComm2 #########################
compile =, 11 lines: $*(anfangs com.$*) $*(plus$*) $*+ x
run without input
the first non empty line;
. .
befor an empty line with comments;
$/tstCompDataConstBefAftComm2/ */
call tstComp1 '= tstCompDataConstBefAftComm2',
, ' $*(anfangs com.$*) $*(plus$*) $*+ x',
, ' $*(forts Zeile com.$*) $*(plus$*) $** x',
, ' $*(comment 2. Zeile$*) $*(plus$*) $*+ x',
, ' $*(forts Zeile com.$*) $*(plus$*) $** x',
, 'the first non empty line;',
, ' ',
, 'befor an empty line with comments;',
, ' $*(comment 4. Zeile$*) $*(plus$*) $*+ x',
, ' $*(forts 4.Zeile com.$*) $*(plus$*) $** x',
, ' $*(end kommentar$*) $*+',
, ' $*(forts end com.$*) $*(plus$*) $** x'
return
endProcedure tstCompDataComm
tstCompDataVars: procedure expose m.
/*
$=/tstCompDataVars/
### start tst tstCompDataVars #####################################
compile =, 5 lines: Lline one, $** asdf
run without input
. Lline one, .
lline zwei output
lline 3 .
variable v1 = valueV1 ${v1}= valueV1; .
. $-.{""$v1} = valueV1; .
$/tstCompDataVars/ */
call tstComp1 '= tstCompDataVars',
, ' Lline one, $** asdf',
, ' $$ lline zwei output',
, 'lline 3 $=v1= valueV1 ' ,
, 'variable v1 = $v1 $"${v1}=" ${ v1 }; ',
, ' $"$-.{""""$v1} =" $-.{""$v1}; '
return
endProcedure tstCompDataVars
tstCompShell: procedure expose m.
/*
$=/tstCompShell/
### start tst tstCompShell ########################################
compile @, 12 lines: $$ Lline one, $** asdf
run without input
Lline one,
lline zwei output
v1 = valueV1 ${v1}= valueV1|
REXX OUT L5 CONTINUED L6 CONTINUED L7
L8 ONE
L9 TWO
valueV1
valueV1 valueV2
out valueV1 valueV2
SCHLUSS
$/tstCompShell/ */
call tstComp1 '@ tstCompShell',
, ' $$ Lline one, $** asdf',
, ' $$ lline zwei output',
, ' $=v1= valueV1 ' ,
, '$$ v1 = $v1 $"${v1}=" ${ v1 }| ' ,
, 'call out rexx out l5, ' ,
, ' continued l6 , ' ,
, ' continued l7 ' ,
, 'call out l8 one ' ,
, 'call out l9 two$=v2=valueV2 ',
, '$$- $v1 $$- $v1 $v2 ',
, 'call out "out " $v1 $v2 ',
, '$$- schluss '
/*
$=/tstCompShell2/
### start tst tstCompShell2 #######################################
compile @, 13 lines: $@do j=0 to 1 $@¢ $$ do j=$j
run without input
do j=0
after if 0 $@¢ $!
after if 0 $=@¢ $!
do j=1
if 1 then $@¢ a
a2
if 1 then $@=¢ b
b2
after if 1 $@¢ $!
after if 1 $=@¢ $!
end
$/tstCompShell2/ */
call tstComp1 '@ tstCompShell2',
, '$@do j=0 to 1 $@¢ $$ do j=$j' ,
, 'if $j then $@¢ ',
, '$$ if $j then $"$@¢" a $$a2' ,
, '$!',
, 'if $j then $@=¢ ',
, '$$ if $j then $"$@=¢" b $$b2' ,
, '$!',
, 'if $j then $@¢ $!' ,
, '$$ after if $j $"$@¢ $!"' ,
, 'if $j then $@=¢ $!' ,
, '$$ after if $j $"$=@¢ $!"' ,
, '$!',
, '$$ end'
return
endProcedure tstCompShell
tstCompPrimary: procedure expose m.
call compIni
/*
$=/tstCompPrimary/
### start tst tstCompPrimary ######################################
compile =, 16 lines: Strings $"$""$""""$""" $'$''$''''$'''
run without input
Strings $"$""$" $'$''$'
rexx $-{ 3 * 5 } = 15
rexx $-¢ 5 * 7 $! = 35
rexx $-// 7 * 11 $// = 77
rexx $-/abcEf/ 11 * 13 $/abcEf/ = 143
data line three line four bis hier
shell line five line six bis hier
var get v1 value Eins, v1 value Eins .
var isDef v1 1, v2 0 .
#jIn eof 1#
var read >1 0 rr undefined
#jIn eof 2#
var read >2 0 rr undefined
no call abc$-{4*5} $-{efg$-{6*7} abc20 EFG42
brackets $-{$-{1+9}*$-¢7+3$!*$-/b/5+5$/b/} 1000
run with 3 inputs
Strings $"$""$" $'$''$'
rexx $-{ 3 * 5 } = 15
rexx $-¢ 5 * 7 $! = 35
rexx $-// 7 * 11 $// = 77
rexx $-/abcEf/ 11 * 13 $/abcEf/ = 143
data line three line four bis hier
shell line five line six bis hier
var get v1 value Eins, v1 value Eins .
var isDef v1 1, v2 0 .
#jIn 1# eins zwei drei
var read >1 1 rr eins zwei drei
#jIn 2# zehn elf zwoelf?
var read >2 1 rr zehn elf zwoelf?
no call abc$-{4*5} $-{efg$-{6*7} abc20 EFG42
brackets $-{$-{1+9}*$-¢7+3$!*$-/b/5+5$/b/} 1000
$/tstCompPrimary/ */
call envRemove 'v2'
call tstComp1 '= tstCompPrimary 3',
, 'Strings $"$""$""""$"""' "$'$''$''''$'''",
, 'rexx $"$-{ 3 * 5 } =" $-{ 3 * 5 }' ,
, 'rexx $"$-¢ 5 * 7 $! =" $-¢ 5 * 7 $!' ,
, 'rexx $"$-// 7 * 11 $// =" $-// 7 * 11 $//' ,
, 'rexx $"$-/abcEf/ 11 * 13 $/abcEf/ ="',
'$-/abcEf/ 11 * 13 $/abcEf/' ,
, 'data $-=¢ line three',
, 'line four $! bis hier' ,
, 'shell $-@¢ $$ line five',
, '$$ line six $! bis hier' ,
, '$= v1 = value Eins $=rr=undefined $= eins = 1 ',
, 'var get v1 $v1, v1 ${ v1 } ',
, 'var isDef v1 ${? v${ eins } }, v2 ${?v2 } ',
, 'var read >1 ${> rr} rr $rr' ,
, 'var read >2 ${> rr} rr $rr',
, 'no call $"abc$-{4*5} $-{efg$-{6*7}"',
'abc$-{4*5} $-{efg$-{6*7}}',
, 'brackets $"$-{$-{1+9}*$-¢7+3$!*$-/b/5+5$/b/}"',
'$-{$-{1+9}*$-¢7+3$!*$-/b/5+5$/b/}'
return
endProcedure tstCompPrimary
tstCompExpr: procedure expose m.
call compIni
/*
$=/tstCompExprStr/
### start tst tstCompExprStr ######################################
compile -, 3 lines: $=vv=vvStr
run without input
vv=vvStr
o2String($.$vv)=vvStr
$/tstCompExprStr/ */
call tstComp1 '- tstCompExprStr',
, '$=vv=vvStr' ,
, '"vv="$vv' ,
, '$"o2String($.$vv)="o2String($.$vv)'
/*
$=/tstCompExprObj/
### start tst tstCompExprObj ######################################
compile ., 5 lines: $=vv=vvStr
run without input
vv=
vvStr
s2o($.$vv)=
vvStr
$/tstCompExprObj/ */
call tstComp1 '. tstCompExprObj',
, '$=vv=vvStr' ,
, '"!vv="', '$vv',
, '$"s2o($.$vv)="', 's2o($-$vv)'
/*
$=/tstCompExprDat/
### start tst tstCompExprDat ######################################
compile =, 4 lines: $=vv=vvDat
run without input
vv=vvDat
$.$vv= !vvDat
$.-{"abc"}=!abc
$/tstCompExprDat/ */
call tstComp1 '= tstCompExprDat',
, '$=vv=vvDat' ,
, 'vv=$vv',
, '$"$.$vv=" $.$vv',
, '$"$.-{""abc""}="$.-{"abc"}'
/*
$=/tstCompExprRun/
### start tst tstCompExprRun ######################################
compile @, 3 lines: $=vv=vvRun
run without input
vv=vvRun
o2string($.$vv)=vvRun
$/tstCompExprRun/ */
call tstComp1 '@ tstCompExprRun',
, '$=vv=vvRun' ,
, 'call out "vv="$vv',
, 'call out $"o2string($.$vv)="o2string($.$vv)'
/*
$=/tstCompExprCon/
$/tstCompExprCon/ */
/* wkTst sinnvolle Erweiterung ???
call tstComp1 '# tstCompExprCon',
, '$=vv=vvCon' ,
, 'call out "vv="$vv',
, 'call out $"o2string($.$vv)="o2string($.$vv)'
*/
return
endProcedure tstCompExpr
tstCompStmt: procedure expose m.
/*
$=/tstCompStmt1/
### start tst tstCompStmt1 ########################################
compile @, 8 lines: $= v1 = value eins $= v2 =- 3*5*7 .
run without input
data v1 value eins v2 105
eins
zwei
drei
vier
fuenf
elf
zwoelf dreiZ
. vierZ .
fuenfZ
lang v1 value eins v2 945
oRun ouput 1
$/tstCompStmt1/ */
call pipeIni
call envPutO 'oRun', oRunner('call out "oRun ouput" (1*1)')
call envRemove 'v2'
call tstComp1 '@ tstCompStmt1',
, '$= v1 = value eins $= v2 =- 3*5*7 ',
, '$$ data v1 $v1 v2 ${ v2 }',
, '$$eins $@¢$$ zwei $$ drei ',
, ' $@¢ $! $@{ } $@// $// $@/q r s / $/q r s /',
' $@/eins/ $@¢ $$vier $! $/eins/ $! $$fuenf',
, '$$elf $@=¢$@={ zwoelf dreiZ } ',
, ' $@=¢ $! $@=¢ $@=¢ vierZ $! $! $! $$fuenfZ',
, '$$- "lang v1" $v1 "v2" ${v2}*9',
, '$@$oRun""' /* String am schluss -> $$ "" statment||||| */
/*
$=/tstCompStmt2/
### start tst tstCompStmt2 ########################################
compile @, 1 lines: $@for qq $$ loop qq $qq
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
loop qq eins zwei drei
#jIn 2# zehn elf zwoelf?
loop qq zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
loop qq zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
$/tstCompStmt2/ */
call tstComp1 '@ tstCompStmt2 3',
, '$@for qq $$ loop qq $qq'
/*
$=/tstCompStmt3/
### start tst tstCompStmt3 ########################################
compile @, 9 lines: $$ 1 begin run 1
2 ct zwei
ct 4 mit assign .
run without input
1 begin run 1
3 run 3 ctV = ct 4 assign ctV|
run 5 procCall $@$prCa
out in proc at 8
run 6 vor call $@prCa()
out in proc at 8
9 run end
run with 3 inputs
1 begin run 1
3 run 3 ctV = ct 4 assign ctV|
run 5 procCall $@$prCa
out in proc at 8
run 6 vor call $@prCa()
out in proc at 8
9 run end
$/tstCompStmt3/ */
call tstComp1 '@ tstCompStmt3 3',
, '$$ 1 begin run 1',
, '$@ct $$ 2 ct zwei',
, '$$ 3 run 3 ctV = $ctV|',
, '$@ct $@=¢ct 4 mit assign $=ctV = ct 4 assign ctV $!',
, '$$ run 5 procCall $"$@$prCa" $@$prCa',
, '$$ run 6 vor call $"$@prCa()"',
, '$@prCa()',
, '$@proc prCa $$out in proc at 8',
, '$$ 9 run end'
/*
$=/tstCompStmt4/
### start tst tstCompStmt4 ########################################
compile @, 4 lines: $=eins=vorher
run without input
eins vorher
eins aus named block eins .
$/tstCompStmt4/ */
call tstComp1 '@ tstCompStmt4 0',
, '$=eins=vorher' ,
, '$$ eins $eins' ,
, '$=/eins/aus named block eins $/eins/' ,
, '$$ eins $eins'
/*
$=/tstCompStmtDo/
### start tst tstCompStmtDo #######################################
compile @, 2 lines: ti=0$@do y=3 to 4 $@do 2 $@¢
run without input
y=3 ti1 z=7
y=3 ti1 z=8
y=3 ti2 z=7
y=3 ti2 z=8
y=4 ti3 z=7
y=4 ti3 z=8
y=4 ti4 z=7
y=4 ti4 z=8
$/tstCompStmtDo/ */
call tstComp1 '@ tstCompStmtDo', 'ti=0$@do y=3 to 4 $@do 2 $@¢',
, 'ti = ti + 1',
'$@do $*(sdf$*) z $*(sdf$*) = 7 to 8 $$ y=$y ti$-{ti} z=$z $!'
/*
$=/tstCompStmtDo2/
### start tst tstCompStmtDo2 ######################################
compile @, 7 lines: $$ $-=/sqlSel/
run without input
select 1 abc select 2 abc after table .
$/tstCompStmtDo2/ */
call tstComp1 '@ tstCompStmtDo2',
, '$$ $-=/sqlSel/',
, '$=ty = abc ',
, '$@do tx=1 to 2 $@=/table/',
, 'select $tx $ty',
, '$/table/',
, '$=ty = abc',
, 'after table',
'$/sqlSel/'
return
endProcedure tstCompStmt
tstCompStmtA: procedure expose m.
call pipeIni
/*
$=/tstCompStmtAssAtt/
### start tst tstCompStmtAssAtt ###################################
compile @, 19 lines: call tstCompStmtAA "begin", "tstAssAtt"
run without input
begin tstAssAtt F1=F1val1 F2= F3= FR=
gugus1
ass1 tstAssAtt F1=F1val1 F2=F2ass1 F3=F3ass1 FR=
ass2 tstAssAtt F1=F1val1 F2=F2ass1 F3=F3ass1 FR=<oAAR2>
ass2 tstAssAr2 F1=FRF1ass2 F2= F3= FR=
gugus3
ass3 tstAssAtt F1=F1val1 F2=F2ass3 F3=F3ass1 FR=<oAAR2>
ass3 tstAssAr2 F1=FRF1ass2 F2=FrF2ass3 F3= FR=<oAAR3>
ass3 tstAssAr3 F1=r2F1as3 F2=r2F2as3 F3= FR=
*** err: no field falsch in class tstAssAtt in EnvPut(falsch, +
falsch, 1)
$/tstCompStmtAssAtt/
*/
call classNew 'n? tstAssAtt u f F1 v, f F2 v,' ,
'f F3 v, f FR r tstAssAtt'
call envPutO 'tstAssAtt', mNew('tstAssAtt')
call envPut 'tstAssAtt.F1', 'F1val1'
call tstComp1 '@ tstCompStmtAssAtt',
, 'call tstCompStmtAA "begin", "tstAssAtt"',
, '$=tstAssAtt=:¢F2=F2ass1 $$gugus1',
, 'F3=F3ass1',
, '!',
, 'call tstCompStmtAA "ass1", "tstAssAtt"',
, '$=tstAssAtt.FR.F1 = FRF1ass2',
, '$=tstAssAr2 =. ${tstAssAtt.FR}',
, 'call mAdd T.trans, $.$tstAssAr2 "<oAAR2>"',
, 'call tstCompStmtAA "ass2", "tstAssAtt"',
';call tstCompStmtAA "ass2", "tstAssAr2"',
, '$=tstAssAtt=:¢F2=F2ass3 $$gugus3',
, ':/FR/ F2= FrF2ass3',
, 'FR=:¢F1=r2F1as3',
, 'F2=r2F2as3',
, ' * blabla $$ sdf',
, '!',
, '/FR/ !',
, '$=tstAssAr3 =. ${tstAssAtt.FR.FR}',
, 'call mAdd T.trans, $.$tstAssAr3 "<oAAR3>";',
'call tstCompStmtAA "ass3", "tstAssAtt";',
'call tstCompStmtAA "ass3", "tstAssAr2";',
'call tstCompStmtAA "ass3", "tstAssAr3"',
, '$=tstAssAtt=:¢falsch=falsch$!'
/*
$=/tstCompStmtAsSuTy/
### start tst tstCompStmtAsSuTy ###################################
compile @, 4 lines: call tstCompStmtA2 "begin", "tstAsSuTy"
run without input
begin tstAsSuTy G1=G1ini1 .
_..GT tstAsSuTy F1=GTF1ini1 F2= F3= FR=
as2 tstAsSuTy G1=G1ini1 .
_..GT tstAsSuTy F1=GtF1ass2 F2=F2ass2 F3= FR=
$/tstCompStmtAsSuTy/
*/
call classNew 'n? tstAsSuTy u f G1 v, f GT tstAssAtt'
call envPutO 'tstAsSuTy', mNew('tstAsSuTy')
call envPut 'tstAsSuTy.G1', 'G1ini1'
call envPut 'tstAsSuTy.GT.F1', 'GTF1ini1'
call tstComp1 '@ tstCompStmtAsSuTy',
, 'call tstCompStmtA2 "begin", "tstAsSuTy"',
, '$=tstAsSuTy.GT =:¢F1= GtF1ass2',
, 'F2= F2ass2 $!',
, 'call tstCompStmtA2 "as2", "tstAsSuTy"'
/*
$=/tstCompStmtAssSt/
### start tst tstCompStmtAssSt ####################################
compile @, 13 lines: .
run without input
*** err: bad stem index 1>0 @ <oASt>.HS class <clSt??> in EnvPut(ts+
tAssSt.HS.1.F1, HS.1.ini0, )
begin tstAssSt H1=H1ini1 HS.0=1 .
_..1 tstAssSt. F1=HS.1.ini F2= F3= FR=
ass2 tstAssSt H1=H1ass2 HS.0=1 .
_..1 tstAssSt. F1= F2=hs+f2as2 F3=hs+f3as2 FR=
ass3 tstAssSt H1=H1ass3 HS.0=3 .
_..1 tstAssSt. F1= F2=hs+f2as3 F3= FR=
_..2 tstAssSt. F1= F2= F3= FR=
_..3 tstAssSt. F1= F2= F3=hs+f3as3 FR=
$/tstCompStmtAssSt/
*/
cl = classNew('n? tstAssSt u f H1 v, f HS s tstAssAtt')
cl = m.cl.2
m.tstCl = m.cl.class
call envPutO 'tstAssSt', mNew('tstAssSt')
call oClear envGetO('tstAssSt')'.HS.1', class4Name('tstAssAtt')
call envPut 'tstAssSt.H1', 'H1ini1'
call tstComp1 '@ tstCompStmtAssSt', '',
, "call mAdd t.trans, $.$tstAssSt '<oASt>'",
", m.tstCl '<clSt??>'",
";call envPut 'tstAssSt.HS.1.F1', 'HS.1.ini0'",
";call envPut 'tstAssSt.HS.0', 1",
";call envPut 'tstAssSt.HS.1.F1', 'HS.1.ini1'",
, 'call tstCompStmtSt "begin", "tstAssSt"',
, '$=tstAssSt =:¢H1= H1ass2',
, 'HS =<:¢F2=hs+f2as2',
, 'F3=hs+f3as2$! !' ,
, 'call tstCompStmtSt "ass2", "tstAssSt"',
, '$=tstAssSt =:¢H1= H1ass3',
, 'HS =<:¢F2=hs+f2as3',
, '; ; F3=hs+f3as3',
, ' ! !' ,
, 'call tstCompStmtSt "ass3", "tstAssSt"',
, ''
/*
$=/tstCompStmtAssSR/
### start tst tstCompStmtAssSR ####################################
compile @, 13 lines: .
run without input
*** err: bad stem index 1>0 @ <oASR>.HS class <clSR??> in EnvPut(ts+
tAssSR.HS.1.F1, HS.1.ini0, )
begin tstAssSR H1=H1ini1 HS.0=1 .
_..1 tstAssSR. F1=HS.1.ini F2= F3= FR=
ass2 tstAssSR H1=H1ass2 HS.0=1 .
_..1 tstAssSR. F1= F2=hs+f2as2 F3=hs+f3as2 FR=
ass3 tstAssSR H1=H1ass3 HS.0=3 .
_..1 tstAssSR. F1= F2=hs+f2as3 F3= FR=
_..2 tstAssSR. F1= F2= F3= FR=
_..3 tstAssSR. F1= F2= F3=hs+f3as3 FR=
$/tstCompStmtAssSR/
*/
cl = classNew('n? tstAssSR u f H1 v, f HS s r tstAssAtt')
cl = m.cl.2
m.tstCl = m.cl.class
call envPutO 'tstAssSR', mNew('tstAssSR')
call oClear envGetO('tstAssSR')'.HS.1', class4Name('tstAssAtt')
call envPut 'tstAssSR.H1', 'H1ini1'
call tstComp1 '@ tstCompStmtAssSR', '',
, "call mAdd t.trans, $.$tstAssSR '<oASR>'",
", m.tstCl '<clSR??>'",
";call envPut 'tstAssSR.HS.1.F1', 'HS.1.ini0'",
";call envPut 'tstAssSR.HS.0', 1",
";call envPutO 'tstAssSR.HS.1', ''",
";call envPut 'tstAssSR.HS.1.F1', 'HS.1.ini1'",
, 'call tstCompStmtSt "begin", "tstAssSR"',
, '$=tstAssSR =:¢H1= H1ass2',
, 'HS =<<:¢F2=hs+f2as2',
, 'F3=hs+f3as2$! !' ,
, ';call tstCompStmtSt "ass2", "tstAssSR"',
, '$=tstAssSR =:¢H1= H1ass3',
, 'HS =<:¢F2=hs+f2as3',
, '; ; F3=hs+f3as3',
, ' ! !' ,
, 'call tstCompStmtSt "ass3", "tstAssSR"',
, ''
/*
$=/tstCompStmtassTb/
### start tst tstCompStmtassTb ####################################
compile @, 19 lines: .
run without input
*** err: bad stem index 1>0 @ <oASt>.HS class <clSt??> in EnvPut(ts+
tAssSt.HS.1.F1, HS.1.ini0, )
begin tstAssSt H1=H1ini1 HS.0=1 .
_..1 tstAssSt. F1=HS.1.ini F2= F3= FR=
tstR: @tstWriteoV4 isA :<assCla H1>
tstR: .H1 = H1ass2
ass2 tstAssSt H1=H1ini1 HS.0=2 .
_..1 tstAssSt. F1= F2=hs+f2as2 F3=hs+f3as2 FR=
_..2 tstAssSt. F1= F2=h3+f2as2 F3=h3+f3as2 FR=
ass3 tstAssSt H1=H1ass3 HS.0=3 .
_..1 tstAssSt. F1= F2=f2as3 F3= FR=
_..2 tstAssSt. F1= F2= F3= FR=
_..3 tstAssSt. F1= F2= F3=f3as3 FR=
$/tstCompStmtassTb/
*/
cl = classNew('n? tstAssSt u f H1 v, f HS s tstAssAtt')
cl = m.cl.2
m.tstCl = m.cl.class
call envPutO 'tstAssSt', mNew('tstAssSt')
call oClear envGetO('tstAssSt')'.HS.1', class4Name('tstAssAtt')
call envPut 'tstAssSt.H1', 'H1ini1'
call tstComp1 '@ tstCompStmtassTb', '',
, "call mAdd t.trans, $.$tstAssSt '<oASt>'",
", m.tstCl '<clSt??>'",
";call envPut 'tstAssSt.HS.1.F1', 'HS.1.ini0'",
";call envPut 'tstAssSt.HS.0', 1",
";call envPut 'tstAssSt.HS.1.F1', 'HS.1.ini1'",
, 'call tstCompStmtSt "begin", "tstAssSt"',
, '$=tstAssSt =:¢ $@|¢ H1 ',
, ' H1ass2 ',
, "$@{call mAdd 'T.TRANS', className(objClass(envWithObj()))",
"'<assCla H1>'} $!",
, 'HS =<|¢ $*(...',
, '..$*) F2 F3 ',
, ' hs+f2as2 hs+f3as2 ' ,
, ' * kommentaerliiii ' ,
, ' ' ,
, ' h3+f2as2 h3+f3as22222$! !' ,
, 'call tstCompStmtSt "ass2", "tstAssSt"',
'$=tstAssSt =:¢H1= H1ass3',
, 'HS =<|¢F2 F3',
, ' f2as3' ,
, ' ',
, ' $""',
, ' f3as3 $! !' ,
, 'call tstCompStmtSt "ass3", "tstAssSt"'
/*
$=/tstCompStmtassInp/
### start tst tstCompStmtassInp ###################################
compile @, 11 lines: .
run without input
tstR: @tstWriteoV2 isA :<cla123>
tstR: .eins = l1v1
tstR: .zwei = l1v2
tstR: .drei = l1v3
tstR: @tstWriteoV3 isA :<cla123>
tstR: .eins = l2v1
tstR: .zwei = l2v2
tstR: .drei = l21v3
*** err: undefined variable oo in envGetO(oo)
oo before 0
oo nachher <oo>
tstR: @tstWriteoV5 isA :<cla123>
tstR: .eins = o1v1
tstR: .zwei = o1v2
tstR: .drei = o1v3
$/tstCompStmtassInp/
*/
call envRemove 'oo'
call tstComp1 '@ tstCompStmtassInp', '',
, "$@|¢eins zwei drei ",
, " l1v1 l1v2 l1v3",
, "$@{call mAdd 'T.TRANS', className(objClass(envWithObj()))",
"'<cla123>'}" ,
, " l2v1 l2v2 l21v3",
, "!",
, "$$ oo before $.$oo",
, "$; $>.$oo $@|¢eins zwei drei",
, " o1v1 o1v2 o1v3 $!",
, "$; call mAdd 'T.TRANS', $.$oo '<oo>'",
, "$; $$ oo nachher $.$oo $@$oo"
return
endProcedure tstCompStmtA
tstCompStmtAA: procedure expose m.
parse arg ggTxt, ggN
call out left(ggTxt,8) left(ggN, 9),
'F1='left(envGet(ggN'.F1'), 8),
'F2='left(envGet(ggN'.F2'), 8),
'F3='left(envGet(ggN'.F3'), 8),
'FR='envGetO(ggN'.FR')
return
endSubroutine
tstCompStmtA2: procedure expose m.
parse arg ggTxt, ggN
call out left(ggTxt,8) left(ggN, 9),
'G1='left(envGet(ggN'.G1'), 8)
call tstCompStmtAA '_..GT', ggN'.GT'
return
endSubroutine
tstCompStmtSt: procedure expose m.
parse arg ggTxt, ggN
call out left(ggTxt,8) left(ggN, 9),
'H1='left(envGet(ggN'.H1'), 8),
'HS.0='left(envGet(ggN'.HS.0'), 8)
do sx=1 to envGet(ggN'.HS.0')
call tstCompStmtAA '_..'sx, ggN'.HS.'sx
end
return
endSubroutine tstCompStmtSt
tstCompSyntax: procedure expose m.
call tstCompSynPrimary
call tstCompSynAss
call tstCompSynRun
return
endProcedure tstCompSyntax
tstCompSynPrimary: procedure expose m.
/*
$=/tstCompSynPri1/
### start tst tstCompSynPri1 ######################################
compile @, 1 lines: a $ =
*** err: scanErr pipe or $; expected: compile shell stopped before+
. end of input
. e 1: last token scanPosition $ =
. e 2: pos 3 in line 1: a $ =
$/tstCompSynPri1/ */
call tstComp1 '@ tstCompSynPri1 +', 'a $ ='
/*
$=/tstCompSynPri2/
### start tst tstCompSynPri2 ######################################
compile @, 1 lines: a $. {
*** err: scanErr objRef expected after $. expected
. e 1: last token scanPosition {
. e 2: pos 5 in line 1: a $. {
$/tstCompSynPri2/ */
call tstComp1 '@ tstCompSynPri2 +', 'a $. {'
/*
$=/tstCompSynPri3/
### start tst tstCompSynPri3 ######################################
compile @, 1 lines: b $- ¢ .
*** err: scanErr objRef expected after $- expected
. e 1: last token scanPosition ¢
. e 2: pos 5 in line 1: b $- ¢
$/tstCompSynPri3/ */
call tstComp1 '@ tstCompSynPri3 +', 'b $- ¢ '
/*
$=/tstCompSynPri4/
### start tst tstCompSynPri4 ######################################
compile @, 1 lines: a ${ $*( sdf$*) } =
*** err: scanErr var name expected
. e 1: last token scanPosition } =
. e 2: pos 17 in line 1: a ${ $*( sdf$*) } =
$/tstCompSynPri4/ */
call tstComp1 '@ tstCompSynPri4 +', 'a ${ $*( sdf$*) } ='
/*
$=/tstCompSynFile/
### start tst tstCompSynFile ######################################
compile @, 1 lines: $@.<$*( co1 $*) $$abc
*** err: scanErr block or expr expected for file expected
. e 1: last token scanPosition $$abc
. e 2: pos 17 in line 1: $@.<$*( co1 $*) $$abc
$/tstCompSynFile/ */
call tstComp1 '@ tstCompSynFile +', '$@.<$*( co1 $*) $$abc'
return
endProcedure tstCompSynPrimary
tstCompSynAss: procedure expose m.
/*
$=/tstCompSynAss1/
### start tst tstCompSynAss1 ######################################
compile @, 1 lines: $=
*** err: scanErr assignment expected after $=
. e 1: last token scanPosition .
. e 2: pos 3 in line 1: $=
$/tstCompSynAss1/ */
call tstComp1 '@ tstCompSynAss1 +', '$='
/*
$=/tstCompSynAss2/
### start tst tstCompSynAss2 ######################################
compile @, 2 lines: $= .
*** err: scanErr assignment expected after $=
. e 1: last token scanPosition .
. e 2: pos 6 in line 1: $=
$/tstCompSynAss2/ */
call tstComp1 '@ tstCompSynAss2 +', '$= ', 'eins'
/*
$=/tstCompSynAss3/
### start tst tstCompSynAss3 ######################################
compile @, 2 lines: $= $$
*** err: scanErr assignment expected after $=
. e 1: last token scanPosition $$
. e 2: pos 6 in line 1: $= $$
$/tstCompSynAss3/ */
call tstComp1 '@ tstCompSynAss3 +', '$= $$', 'eins'
/*
$=/tstCompSynAss4/
### start tst tstCompSynAss4 ######################################
compile @, 1 lines: $= eins
*** err: scanErr = expected after $= "eins"
. e 1: last token scanPosition .
. e 2: pos 10 in line 1: $= eins
$/tstCompSynAss4/ */
call tstComp1 '@ tstCompSynAss4 +', '$= eins'
/*
$=/tstCompSynAss5/
### start tst tstCompSynAss5 ######################################
compile @, 1 lines: $= abc eins $$ = x
*** err: scanErr = expected after $= "abc eins"
. e 1: last token scanPosition $$ = x
. e 2: pos 14 in line 1: $= abc eins $$ = x
$/tstCompSynAss5/ */
call tstComp1 '@ tstCompSynAss5 +', '$= abc eins $$ = x'
/*
$=/tstCompSynAss6/
### start tst tstCompSynAss6 ######################################
compile @, 1 lines: $= abc =
*** err: scanErr block or expression after $= "abc" = expected
. e 1: last token scanPosition .
. e 2: pos 10 in line 1: $= abc =
$/tstCompSynAss6/ */
call tstComp1 '@ tstCompSynAss6 +', '$= abc ='
/*
$=/tstCompSynAss7/
### start tst tstCompSynAss7 ######################################
compile @, 1 lines: $= abc =..
*** err: scanErr block or expression after $= "abc" = expected
. e 1: last token scanPosition .
. e 2: pos 11 in line 1: $= abc =..
$/tstCompSynAss7/ */
call tstComp1 '@ tstCompSynAss7 +', '$= abc =.'
return
endProcedure tstCompSynAss
tstCompSynRun: procedure expose m.
/*
$=/tstCompSynRun1/
### start tst tstCompSynRun1 ######################################
compile @, 1 lines: $@
*** err: scanErr block or expr expected after $@ expected
. e 1: last token scanPosition .
. e 2: pos 3 in line 1: $@
$/tstCompSynRun1/ */
call tstComp1 '@ tstCompSynRun1 +', '$@'
/*
$=/tstCompSynRun2/
### start tst tstCompSynRun2 ######################################
compile @, 1 lines: $@=
*** err: scanErr block or expr expected after $@ expected
. e 1: last token scanPosition .
. e 2: pos 4 in line 1: $@=
$/tstCompSynRun2/ */
call tstComp1 '@ tstCompSynRun2 +', '$@='
/*
$=/tstCompSynRun3/
### start tst tstCompSynRun3 ######################################
compile @, 1 lines: $@|
*** err: scanErr block or expr expected after $@ expected
. e 1: last token scanPosition .
. e 2: pos 4 in line 1: $@|
*** err: scanErr comp2code bad fr | to | for @|| .
. e 1: last token scanPosition .
. e 2: pos 4 in line 1: $@|
$/tstCompSynRun3/ */
call tstComp1 '@ tstCompSynRun3 +', '$@|'
/*
$=/tstCompSynFor4/
### start tst tstCompSynFor4 ######################################
compile @, 1 lines: $@for
*** err: scanErr variable name after $@for expected
. e 1: last token scanPosition .
. e 2: pos 6 in line 1: $@for
$/tstCompSynFor4/ */
call tstComp1 '@ tstCompSynFor4 +', '$@for'
/*
$=/tstCompSynFor5/
### start tst tstCompSynFor5 ######################################
compile @, 2 lines: $@for
*** err: scanErr variable name after $@for expected
. e 1: last token scanPosition .
. e 2: pos 6 in line 1: $@for
$/tstCompSynFor5/ */
call tstComp1 '@ tstCompSynFor5 +', '$@for', a
/*
$=/tstCompSynFor6/
### start tst tstCompSynFor6 ######################################
compile @, 2 lines: a
*** err: scanErr variable name after $@for expected
. e 1: last token scanPosition $$q
. e 2: pos 12 in line 2: b $@for $$q
$/tstCompSynFor6/ */
call tstComp1 '@ tstCompSynFor6 +', 'a', ' b $@for $$q'
/*
$=/tstCompSynFor7/
### start tst tstCompSynFor7 ######################################
compile @, 3 lines: a
*** err: scanErr statement after $@for "a" expected
. e 1: last token scanPosition .
. e 2: pos 11 in line 2: b $@for a
$/tstCompSynFor7/ */
call tstComp1 '@ tstCompSynFor7 +', 'a', ' b $@for a', ' $$q'
/*
$=/tstCompSynCt8/
### start tst tstCompSynCt8 #######################################
compile @, 3 lines: a
*** err: scanErr ct statement expected
. e 1: last token scanPosition .
. e 2: pos 8 in line 2: b $@ct
$/tstCompSynCt8/ */
call tstComp1 '@ tstCompSynCt8 +', 'a', ' b $@ct', ' $$q'
/*
$=/tstCompSynProc9/
### start tst tstCompSynProc9 #####################################
compile @, 2 lines: a
*** err: scanErr proc name expected
. e 1: last token scanPosition $$q
. e 2: pos 12 in line 2: b $@proc $$q
$/tstCompSynProc9/ */
call tstComp1 '@ tstCompSynProc9 +', 'a', ' b $@proc $$q'
/*
$=/tstCompSynProcA/
### start tst tstCompSynProcA #####################################
compile @, 2 lines: $@proc p1
*** err: scanErr proc statement expected
. e 1: last token scanPosition .
. e 2: pos 10 in line 1: $@proc p1
$/tstCompSynProcA/ */
call tstComp1 '@ tstCompSynProcA +', '$@proc p1', ' $$q'
/*
$=/tstCompSynCallB/
### start tst tstCompSynCallB #####################################
compile @, 1 lines: $@call (roc p1)
*** err: scanErr procCall, for, do, ct, proc or objRef expected aft+
er $@
. e 1: last token scanPosition (roc p1)
. e 2: pos 7 in line 1: $@call (roc p1)
$/tstCompSynCallB/ */
call tstComp1 '@ tstCompSynCallB +', '$@call (roc p1)'
/*
$=/tstCompSynCallC/
### start tst tstCompSynCallC #####################################
compile @, 1 lines: $@call( roc p1 )
*** err: scanErr closing ) expected after $@call(
. e 1: last token scanPosition roc p1 )
. e 2: pos 9 in line 1: $@call( roc p1 )
$/tstCompSynCallC/ */
call tstComp1 '@ tstCompSynCallC +', '$@call( roc p1 )'
/*
$=/tstCompSynCallD/
### start tst tstCompSynCallD #####################################
compile @, 2 lines: $@call( $** roc
*** err: scanErr closing ) expected after $@call(
. e 1: last token scanPosition .
. e 2: pos 16 in line 1: $@call( $** roc
$/tstCompSynCallD/ */
call tstComp1 '@ tstCompSynCallD +',
,'$@call( $** roc' , ' $*( p1 $*) )'
return
endProcedure tstCompSynRun
tstCompObj: procedure expose m.
call tstReset t
call oIni
cl = classNew('n? tstCompCla u v, f FEINS v, f FZWEI v')
do rx=1 to 10
o = oNew(cl)
m.tstComp.rx = o
m.o = 'o'rx
if rx // 2 = 0 then do
m.o.fEins = 'o'rx'.1'
m.o.fZwei = 'o'rx'.fZwei'rx
end
else do
m.o.fEins = 'o'rx'.fEins'
m.o.fZwei = 'o'rx'.2'
end
call mAdd 'T.TRANS', m.tstComp.rx '<o'rx'>'
end
/*
$=/tstCompObjRef/
### start tst tstCompObjRef #######################################
compile @, 13 lines: o1=m.tstComp.1
run without input
out .$"string" o1
string
out . o1
tstR: @<o1> isA :tstCompCla = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
out .{ o2 }
tstR: @<o2> isA :tstCompCla = o2
tstR: .FEINS = o2.1
tstR: .FZWEI = o2.fZwei2
out .¢ o3 $!
tstR: @<o3> isA :tstCompCla = o3
tstR: .FEINS = o3.fEins
tstR: .FZWEI = o3.2
out .¢ o4 $!
tstR: @<o4> isA :tstCompCla = o4
tstR: .FEINS = o4.1
tstR: .FZWEI = o4.fZwei4
out ./-/ o5 $/-/
tstR: @<o5> isA :tstCompCla = o5
tstR: .FEINS = o5.fEins
tstR: .FZWEI = o5.2
$/tstCompObjRef/ */
m.ttt=1
call tstComp1 '@ tstCompObjRef' ,
, 'o1=m.tstComp.1',
, 'o2 = m.tstComp.2' ,
, '$$ out $".$""string""" o1 $$.$"string"',
, '$$ out . o1 $$. o1',
, '$$ out .{ o2 } $$.{ o2 }',
, '$$ out .¢ o3 $"$!" $$.¢ ', ' m.tstComp.3 ', ' $!',
, '$$ out .¢ o4 $"$!" $$.¢ ', ' m.tstComp.4 ', ' $!',
, '$$ out ./-/ o5 $"$/-/" $$./-/ m.tstComp.5 ', ' $/-/'
/*
$=/tstCompObjRefPri/
### start tst tstCompObjRefPri ####################################
compile @, 9 lines: $$ out .$"$.{o1}" $$.$.{ m.tstComp.1 }
run without input
out .$.{o1}
tstR: @<o1> isA :tstCompCla = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
out .$.-{o2}
<o2>
out .$.={o3}
m.tstComp.3
out .$.@{out o4}
tstWriteO kindOf ORun oRun begin <<<
tstR: @<o4> isA :tstCompCla = o4
tstR: .FEINS = o4.1
tstR: .FZWEI = o4.fZwei4
tstWriteO kindOf ORun oRun end >>>
out .$.@¢$$abc $$efg$!
tstWriteO kindOf ORun oRun begin <<<
abc
efg
tstWriteO kindOf ORun oRun end >>>
out .$.@¢o5$!
tstWriteO kindOf ORun oRun begin <<<
tstR: @<o5> isA :tstCompCla = o5
tstR: .FEINS = o5.fEins
tstR: .FZWEI = o5.2
abc
tstWriteO kindOf ORun oRun end >>>
$/tstCompObjRefPri/ */
call tstComp1 '@ tstCompObjRefPri' ,
, '$$ out .$"$.{o1}" $$.$.{ m.tstComp.1 }',
, '$$ out .$"$.-{o2}" $$.$.-{ m.tstComp.2 }',
, '$$ out .$"$.={o3}" $$.$.={ m.tstComp.3 }',
, '$$ out .$"$.@{out o4}" $$.$.@{ call outO m.tstComp.4 }',
, '$$ out .$"$.@¢$$abc $$efg$!" $$.$.@¢ $$abc ', ' ', ' $$efg $!',
, '$$ out .$"$.@¢o5$!" $$.$.@¢ $$.m.tstComp.5', '$$abc $!'
/*
$=/tstCompObjRefFile/
### start tst tstCompObjRefFile ###################################
compile @, 7 lines: $$ out .$".<.¢o1!" $$.$.<.¢ m.tstComp.1 $!
run without input
out ..<.¢o1!
tstWriteO kindOf JRW jWriteNow begin <<<
tstR: @<o1> isA :tstCompCla = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
tstWriteO kindOf JRW jWriteNow end >>>
out .<$.-{o2}
tstWriteO kindOf JRW jWriteNow begin <<<
tstR: @<o2> isA :tstCompCla = o2
tstR: .FEINS = o2.1
tstR: .FZWEI = o2.fZwei2
tstWriteO kindOf JRW jWriteNow end >>>
out .$.<{o3}
tstWriteO kindOf JRW jWriteNow begin <<<
m.tstComp.3
tstWriteO kindOf JRW jWriteNow end >>>
out .$.<@{out o4}
tstWriteO kindOf JRW jWriteNow begin <<<
tstR: @<o4> isA :tstCompCla = o4
tstR: .FEINS = o4.1
tstR: .FZWEI = o4.fZwei4
tstWriteO kindOf JRW jWriteNow end >>>
out .$<@¢$$abc $$efg$!
tstWriteO kindOf JRW jWriteNow begin <<<
abc
efg
tstWriteO kindOf JRW jWriteNow end >>>
$/tstCompObjRefFile/ */
call tstComp1 '@ tstCompObjRefFile' ,
, '$$ out .$".<.¢o1!" $$.$.<.¢ m.tstComp.1 $!',
, '$$ out .$"<$.-{o2}" $$.$.<.{ m.tstComp.2 }',
, '$$ out .$"$.<{o3}" $$.$.<={ m.tstComp.3 }',
, '$$ out .$"$.<@{out o4}" $$.$.<@{ call outO m.tstComp.4 }',
, '$$ out .$"$<@¢$$abc $$efg$!" $$.$.<@¢ $$abc ', ' ', ' $$efg $!'
/*
$=/tstCompObjFor/
### start tst tstCompObjFor #######################################
compile @, 2 lines: $@do rx=1 to 3 $$. m.tstComp.rx
run without input
FEINS=o1.fEins FZWEI=o1.2
FEINS=o2.1 FZWEI=o2.fZwei2
FEINS=o3.fEins FZWEI=o3.2
$/tstCompObjFor/
*/
call tstComp1 '@ tstCompObjFor' ,
, '$@do rx=1 to 3 $$. m.tstComp.rx' ,
, '$| $@forWith with $$ FEINS=$FEINS FZWEI=$FZWEI'
/*
$=/tstCompObjRun/
### start tst tstCompObjRun #######################################
compile @, 4 lines: $$ out .$"$@¢o1!" $$.$.@¢ $$. m.tstComp.1 $!
run without input
out .$@¢o1!
tstWriteO kindOf ORun oRun begin <<<
tstR: @<o1> isA :tstCompCla = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
tstWriteO kindOf ORun oRun end >>>
out .$<@¢$$abc $$efg$!
tstWriteO kindOf JRW jWriteNow begin <<<
abc
efg
tstWriteO kindOf JRW jWriteNow end >>>
$/tstCompObjRun/ */
call tstComp1 '@ tstCompObjRun' ,
, '$$ out .$"$@¢o1!" $$.$.@¢ $$. m.tstComp.1 $!',
, '$$ out .$"$<@¢$$abc $$efg$!" $$.$.<@¢ $$abc ', ' ', ' $$efg $!'
m.t.trans.0 = 0
/*
$=/tstCompObj/
### start tst tstCompObj ##########################################
compile @, 6 lines: o1=m.tstComp.1
run without input
out . o1
tstR: @tstWriteoV1 isA :tstCompCla = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
out .{ o2 }
tstR: @tstWriteoV2 isA :tstCompCla = o2
tstR: .FEINS = o2.1
tstR: .FZWEI = o2.fZwei2
out .¢ o1, o2!
tstR: @tstWriteoV1 isA :tstCompCla = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
tstR: @tstWriteoV2 isA :tstCompCla = o2
tstR: .FEINS = o2.1
tstR: .FZWEI = o2.fZwei2
$/tstCompObj/ */
call tstComp1 '@ tstCompObj' ,
, 'o1=m.tstComp.1',
, 'o2 = m.tstComp.2' ,
, '$$ out . o1 $$. o1',
, '$$ out .{ o2 } $$.{ o2 }',
, '$$ out .¢ o1, o2!$; $@<.¢ m.tstComp.1 ', ' m.tstComp.2 $!'
return
m.t.trans.0 = 0
endProcedure tstCompObj
tstCompORun: procedure expose m.
/*
$=/tstCompORun/
### start tst tstCompORun #########################################
compile @, 6 lines: $@oRun()
run without input
oRun arg=1, v2=, v3=, v4=
oRun arg=1, v2=, v3=, v4=
oRun arg=2, v2=-{1 arg only} oder?, v3=, v4=
oRun arg=2, v2=!.{1 obj only} oder?, v3=, v4=
oRun arg=3, v2={2 args}, v3=und zwei?, v4=
oRun arg=4, v2={3 args}, v3=zwei, v4=und drei?
$/tstCompORun/ */
call compIni
call envPutO 'oRun', oRunner('parse arg , v2, v3, v4;',
'call tstOut t, "oRun arg="arg()", v2="v2", v3="v3", v4="v4' )
call tstComp1 '@ tstCompORun',
, '$@oRun()', '$@oRun-{}' ,
, ' $@oRun-{$"-{1 arg only}" ''oder?''}' ,
, ' $@oRun.{$".{1 obj only}" ''oder?''} $=v2=zwei' ,
, ' $@oRun-{$"{2 args}", "und" $v2"?"}' ,
, ' $@oRun-{$"{3 args}", $v2, "und drei?"}'
return
endProcedure tstCompORun
tstCompDataIO: procedure expose m.
/*
$=/tstCompDataHereData/
### start tst tstCompDataHereData #################################
compile =, 13 lines: herdata $@#/stop/ .
run without input
. herdata .
heredata 1 $x
heredata 2 $y
nach heredata
. herdata ¢ .
heredata 1 xValue
heredata 2 yValueY
nach heredata ¢
. herdata { .
HEREDATA 1 xValue
heredata 2 yValueY
nach heredata {
$/tstCompDataHereData/ */
call tstComp1 '= tstCompDataHereData',
, ' herdata $@#/stop/ ',
, 'heredata 1 $x',
, 'heredata 2 $y',
, '$/stop/ $$ nach heredata',
, ' herdata ¢ $@=/stop/ ',
, '$=x=xValue$=y=yValueY',
, 'heredata 1 $x',
, 'heredata 2 $y',
, '$/stop/ $$ nach heredata ¢',
, ' herdata { $@/st/',
, '; call out heredata 1 $x',
, '$$heredata 2 $y',
, '$/st/ $$ nach heredata {'
/*
$=/tstCompDataIO/
### start tst tstCompDataIO #######################################
compile =, 5 lines: input 1 $@.<$dsn $*+.
run without input
. input 1 .
readInp line 1 .
readInp line 2 .
. nach dsn input und nochmals mit & .
readInp line 1 .
readInp line 2 .
. und schluiss..
$/tstCompDataIO/ */
dsn = word(tstPdsMbr(tstFilename('lib37', 'r'), 'readInp'), 1)
dsnFB = strip(dsn tstFB('::F37', 0))
b = jBuf(tstFB('readInp line 1', 37),
,tstFB('readInp line 2', 37))
extFd = tstFB('&dsn('dsn') dd(xyz)', 0)
extFd = tstFB(dsn 'dd(xyz) ::f', 0)
if extFd = '' then
extFd = dsn
call jCat file(dsnFB), b
call envPut 'dsn', dsn
say 'dsn' dsn 'extFD' extFD'?'
call tstComp1 '= tstCompDataIO',
, ' input 1 $@.<$dsn $*+',
, tstFB('::f', 0),
, ' nach dsn input und nochmals mit & ' ,
, ' $@.<' extFD,
, ' und schluiss.'
return
endProcedure tstCompDataIO
tstObjVF: procedure expose m.
parse arg v, f
obj = oNew(classNew('n? TstClassVF u v, f FLD1 v'))
m.obj = if(f=='','val='v, v)
m.obj.fld1 = if(f=='','FLD1='v, f)
return obj
endProcedure tstObjVF
tstCompFile: procedure expose m.
/*
$=/tstCompFileBloSrc/
$=vv=value-of-vv
###file from empty # block
$@<#¢
$!
###file from 1 line # block
$@<#¢
the only $ix+1/0 line $vv
$!
###file from 2 line # block
$@<#¢
first line /0 $*+ no comment
second and last line $$ $wie
$!
===file from empty = block
$@<=¢ $*+ comment
$!
===file from 1 line = block
$@<=¢ the only line $!
===file from 2 line = block
$@<=¢ first line$** comment
second and last line $!
---file from empty - block
$@<-/s/
$/s/
---file from 1 line - block
$@<-/s/ the only "line" (1*1) $/s/
---file from 2 line = block
$@<-// first "line" (1+0)
second and "last line" (1+1) $//
...file from empty . block
$@<.¢
$!
...file from 1 line . block
$@<.¢ tstObjVF('v-Eins', '1-Eins') $!
...file from 2 line . block
$@<.¢ tstObjVF('v-Elf', '1-Elf')
tstObjVF('zwoelf') $!
...file from 3 line . block
$@<.¢ tstObjVF('einUndDreissig')
s2o('zweiUndDreissig' o2String($vv))
tstObjVF('dreiUndDreissig') $!
@@@file from empty @ block
$@<@¢
$!
$=noOutput=before
@@@file from nooutput @ block
$@<@¢ nop
$=noOutput = run in block $!
@@@nach noOutput=$noOutput
@@@file from 1 line @ block
$@<@¢ $$. tstObjVF('w-Eins', 'w1-Eins') $!
@@@file from 2 line @ block
$@<@¢ $$.tstObjVF('w-Elf', 'w1-Elf')
y='zwoelf' $$-y $!
@@@file from 3 line @ block
$@<@¢ $$.tstObjVF('w einUndDreissig') $$ +
zweiUndDreissig $$ 33 $vv$!
{{{ empty { block
$@<{ }
{{{ empty { block with comment
$@<{ $*+ abc
}
{{{ one line { block
$@<{ the only $"{...}" line $*+.
$vv }
{{{ one line -{ block
$@<-{ the only $"-{...}" "line" $vv }
{{{ empty #{ block
$@<#{ }
{{{ one line #{ block
$@<#{ the only $"-{...}" "line" $vv ${vv${x}} }
$/tstCompFileBloSrc/ */
/*
$=/tstCompFileBlo/
### start tst tstCompFileBlo ######################################
compile =, 70 lines: $=vv=value-of-vv
run without input
###file from empty # block
###file from 1 line # block
the only $ix+1/0 line $vv
###file from 2 line # block
first line /0 $*+ no comment
second and last line $$ $wie
===file from empty = block
===file from 1 line = block
. the only line .
===file from 2 line = block
. first line
second and last line .
---file from empty - block
---file from 1 line - block
THE ONLY line 1
---file from 2 line = block
FIRST line 1
SECOND AND last line 2
...file from empty . block
...file from 1 line . block
tstR: @tstWriteoV1 isA :TstClassVF = v-Eins
tstR: .FLD1 = 1-Eins
...file from 2 line . block
tstR: @tstWriteoV2 isA :TstClassVF = v-Elf
tstR: .FLD1 = 1-Elf
tstR: @tstWriteoV3 isA :TstClassVF = val=zwoelf
tstR: .FLD1 = FLD1=zwoelf
...file from 3 line . block
tstR: @tstWriteoV4 isA :TstClassVF = val=einUndDreissig
tstR: .FLD1 = FLD1=einUndDreissig
zweiUndDreissig value-of-vv
tstR: @tstWriteoV5 isA :TstClassVF = val=dreiUndDreissig
tstR: .FLD1 = FLD1=dreiUndDreissig
@@@file from empty @ block
@@@file from nooutput @ block
@@@nach noOutput=run in block
@@@file from 1 line @ block
tstR: @tstWriteoV6 isA :TstClassVF = w-Eins
tstR: .FLD1 = w1-Eins
@@@file from 2 line @ block
tstR: @tstWriteoV7 isA :TstClassVF = w-Elf
tstR: .FLD1 = w1-Elf
zwoelf
@@@file from 3 line @ block
tstR: @tstWriteoV8 isA :TstClassVF = val=w einUndDreissig
tstR: .FLD1 = FLD1=w einUndDreissig
zweiUndDreissig
33 value-of-vv
{{{ empty { block
{{{ empty { block with comment
{{{ one line { block
the only {...} line value-of-vv
{{{ one line -{ block
THE ONLY -{...} line value-of-vv
{{{ empty #{ block
. .
{{{ one line #{ block
. the only $"-{...}" "line" $vv ${vv${x}} .
$/tstCompFileBlo/ */
call tstComp2 'tstCompFileBlo', '='
m.t.trans.0 = 0
/*
$=/tstCompFileObjSrc/
$=vv=value-vv-1
$=fE=<¢ $!
$=f2=.$.<.¢s2o("f2 line 1" o2String($vv))
tstObjVF("f2 line2") $!
---empty file $"$@<$fE"
$@$fE
---file with 2 lines $"$@<$f2"
$@<.$f2
$=vv=value-vv-2
---file with 2 lines $"$@<$f2"
$@<.$f2
$= dsn =- word(tstPdsMbr(tstFilename('libvb', 'r'), 'fileObj'),1) +
tstFB('::V', 0)
$@¢
fi=jOpen(file($dsn),'>')
call jWrite fi, 'line one on' $"$dsn"
call jWrite fi, 'line two on' $"$dsn"
call jClose fi
$!
---file on disk out
$@.<$dsn
$/tstCompFileObjSrc/ */
/*
$=/tstCompFileObj/
### start tst tstCompFileObj ######################################
compile =, 20 lines: $=vv=value-vv-1
run without input
---empty file $@<$fE
---file with 2 lines $@<$f2
f2 line 1 value-vv-1
tstR: @tstWriteoV1 isA :TstClassVF = val=f2 line2
tstR: .FLD1 = FLD1=f2 line2
---file with 2 lines $@<$f2
f2 line 1 value-vv-1
tstR: @tstWriteoV1 isA :TstClassVF = val=f2 line2
tstR: .FLD1 = FLD1=f2 line2
---file on disk out
line one on $dsn
line two on $dsn
$/tstCompFileObj/ */
call tstComp2 'tstCompFileObj', '='
return
endProcedure tstCompFile
tstCompPipe: procedure expose m.
/*
$=/tstCompPipe1/
### start tst tstCompPipe1 ########################################
compile @, 1 lines: call pipePreSuf "(1 ", " 1)"
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
(1 eins zwei drei 1)
#jIn 2# zehn elf zwoelf?
(1 zehn elf zwoelf? 1)
#jIn 3# zwanzig 21 22 23 24 ... 29|
(1 zwanzig 21 22 23 24 ... 29| 1)
#jIn eof 4#
$/tstCompPipe1/ */
call tstComp1 '@ tstCompPipe1 3',
, ' call pipePreSuf "(1 ", " 1)"'
/*
$=/tstCompPipe2/
### start tst tstCompPipe2 ########################################
compile @, 2 lines: call pipePreSuf "(1 ", " 1)"
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
#jIn 2# zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
¢2 (1 eins zwei drei 1) 2!
¢2 (1 zehn elf zwoelf? 1) 2!
¢2 (1 zwanzig 21 22 23 24 ... 29| 1) 2!
$/tstCompPipe2/ */
call tstComp1 '@ tstCompPipe2 3',
, ' call pipePreSuf "(1 ", " 1)"' ,
, ' $| call pipePreSuf "¢2 ", " 2!"'
/*
$=/tstCompPipe3/
### start tst tstCompPipe3 ########################################
compile @, 3 lines: call pipePreSuf "(1 ", " 1)"
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
#jIn 2# zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
<3 ¢2 (1 eins zwei drei 1) 2! 3>
<3 ¢2 (1 zehn elf zwoelf? 1) 2! 3>
<3 ¢2 (1 zwanzig 21 22 23 24 ... 29| 1) 2! 3>
$/tstCompPipe3/ */
call tstComp1 '@ tstCompPipe3 3',
, ' call pipePreSuf "(1 ", " 1)"' ,
, ' $| call pipePreSuf "¢2 ", " 2!"',
, ' $| call pipePreSuf "<3 ", " 3>"'
/*
$=/tstCompPipe4/
### start tst tstCompPipe4 ########################################
compile @, 7 lines: call pipePreSuf "(1 ", " 1)"
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
#jIn 2# zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
<3 ¢222 ¢221 ¢21 ¢20 (1 eins zwei drei 1) 20! 21! 221! 222! 3>
<3 ¢222 ¢221 ¢21 ¢20 (1 zehn elf zwoelf? 1) 20! 21! 221! 222! 3>
<3 ¢222 ¢221 ¢21 ¢20 (1 zwanzig 21 22 23 24 ... 29| 1) 20! 21! 221!+
. 222! 3>
$/tstCompPipe4/ */
call tstComp1 '@ tstCompPipe4 3',
, ' call pipePreSuf "(1 ", " 1)"' ,
, ' $| $@¢ call pipePreSuf "¢20 ", " 20!"',
, ' $| call pipePreSuf "¢21 ", " 21!"',
, ' $| $@¢ call pipePreSuf "¢221 ", " 221!"',
, ' $| call pipePreSuf "¢222 ", " 222!"',
, '$! $! ',
, ' $| call pipePreSuf "<3 ", " 3>"'
return
endProcedure tstCompPipe
tstCompRedir: procedure expose m.
/*
$=/tstCompRedir/
### start tst tstCompRedir ########################################
compile @, 6 lines: $>.$eins $@for vv $$ <$vv> $; .
run without input
#jIn eof 1#
output eins .
output piped zwei .
run with 3 inputs
#jIn 1# eins zwei drei
#jIn 2# zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
output eins <eins zwei drei> <zehn elf zwoelf?> <zwanzig 21 22 23 2+
4 ... 29|>
output piped zwei ab<eins zwei drei>yz ab<zehn elf zwoelf?>yz ab<zw+
anzig 21 22 23 24 ... 29|>yz
$/tstCompRedir/ */
call pipeIni
call envRemove 'eins' /* alte Variable loswerden */
dsn = word(tstPdsMbr(tstFilename('libvb', 'r'), 'redir1'), 1)
call envPut 'dsn', dsn
call tstComp1 '@ tstCompRedir 3' ,
, ' $>.$eins $@for vv $$ <$vv> $; ',
, ' $$ output eins $-=¢$@$eins$!$; ',
, ' $@for ww $$b${ww}y ',
, ' $>$-{ $dsn } 'tstFB('::v', 0),
, '$| call pipePreSuf "a", "z" $<.$eins',
, ' $; $$ output piped zwei $-=¢$@<$dsn$! '
return
endProcedure tstCompRedir
tstCompComp: procedure expose m.
/*
$=/tstCompCompShell/
### start tst tstCompCompShell ####################################
compile @, 5 lines: $$compiling shell $; $= rrr =. $.compile@ $<#/+
aaa/
run without input
compiling shell
running einmal
RUN 1 COMPILED einmal
#jIn eof 1#
running zweimal
RUN 1 COMPILED zweimal
#jIn eof 2#
run with 3 inputs
compiling shell
running einmal
RUN 1 COMPILED einmal
#jIn 1# eins zwei drei
compRun eins zwei dreieinmal
#jIn 2# zehn elf zwoelf?
compRun zehn elf zwoelf?einmal
#jIn 3# zwanzig 21 22 23 24 ... 29|
compRun zwanzig 21 22 23 24 ... 29|einmal
#jIn eof 4#
running zweimal
RUN 1 COMPILED zweimal
#jIn eof 5#
$/tstCompCompShell/ */
call tstComp1 '@ tstCompCompShell 3',
, "$$compiling shell $; $= rrr =. $.compile@ $<#/aaa/",
, "call out run 1*1*1 compiled $cc; $@for v $$ compRun $v$cc",
, "$/aaa/ $;",
, "$=cc=einmal $$ running $cc $@$rrr",
, "$=cc=zweimal $$ running $cc $@$rrr"
/*
$=/tstCompCompData/
### start tst tstCompCompData #####################################
compile @, 5 lines: $$compiling data $; $= rrr =. $.compile= +
$<#/aaa/
run without input
compiling data
running einmal
call out run 1*1*1 compiled einmal
running zweimal
call out run 1*1*1 compiled zweimal
run with 3 inputs
compiling data
running einmal
call out run 1*1*1 compiled einmal
running zweimal
call out run 1*1*1 compiled zweimal
$/tstCompCompData/ */
call tstComp1 '@ tstCompCompData 3',
, "$$compiling data $; $= rrr =. $.compile= $<#/aaa/",
, "call out run 1*1*1 compiled $cc",
, "$/aaa/ $;",
, "$=cc=einmal $$ running $cc $@$rrr",
, "$=cc=zweimal $$ running $cc $@$rrr"
return
endProcedure tstCompComp
tstCompDir: procedure expose m.
/*
$=/tstCompDirSrc/
'in src v1='$v1
$#@ call out 'src @ out v1='$v1
$#. s2o('src . v1=')
$v1
$#- 'src - v1='$v1
$#= src = v1=$v1
$/tstCompDirSrc/ */
/*
$=/tstCompDir/
### start tst tstCompDir ##########################################
compile call out 'before v1='$v1 $=v1=eins $#. s2o('. v1='$-$v1) $#+
@ call out '@ v1='$v1 $#= = v1=$v1 $#- '- v1='$v1, 6 lines: 'in src+
. v1='$v1
run without input
before v1=v1Before
.. v1=eins
@ v1=eins
. = v1=eins .
- v1=eins
in src v1=eins
src @ out v1=eins
src . v1=
eins
src - v1=eins
. src = v1=eins
$/tstCompDir/ */
call envPut 'v1', 'v1Before'
call tstComp2 'tstCompDir', "call out 'before v1='$v1 $=v1=eins" ,
"$#. s2o('. v1='$-$v1) $#@ call out '@ v1='$v1" ,
"$#= = v1=$v1 $#- '- v1='$v1"
/*
$=/tstCompDirPiSrc/
zeile 1 v1=$v1
zweite Zeile vor $"$@$#-"
$@pi2()
$#pi2#-
$'zeile drei nach $@$#- v1='v1
vierte und letzte Zeile
$/tstCompDirPiSrc/ */
/*
$=/tstCompDirPi/
### start tst tstCompDirPi ########################################
compile call pipePreSuf '<','>' $=v1=eiPi $<.$pi $#pi#=, 6 lines: +
zeile 1 v1=$v1
run without input
<zeile 1 v1=eins>
<zweite Zeile vor $@$#->
<zeile drei nach $@$#- v1=V1>
<VIERTE UND LETZTE ZEILE>
$/tstCompDirPi/ */
call tstComp2 'tstCompDirPi',
, "call pipePreSuf '<','>' $=v1=eiPi $<.$pi $#pi#="
return
endProcedure tstCompDir
tstCompSql: procedure expose m.
/*
$=/tstCompSqlSrc/
$@=¢
select strip(creator) cr, strip(name) tb,
(row_number()over())*(row_number()over()) rr
from sysibm.sysTables
where creator='SYSIBM' and name like 'SYSTABL%'
order by 2 fetch first 4 rows only
$!
$| call sqlSel
$| call fmtFTab abc
$/tstCompSqlSrc/
$=/tstCompSql/
### start tst tstCompSql ##########################################
compile @, 9 lines: $@=¢
run without input
CR TB RR
SYSIBM SYSTABLEPART 1
SYSIBM SYSTABLEPART_HIST 4
SYSIBM SYSTABLES 9
SYSIBM SYSTABLESPACE 16
$/tstCompSql/
*/
call sqlOConnect
call tstComp2 'tstCompSql', '@'
return
endProcedure tstCompFile
tstTut0: procedure expose m.
/*
$=/tstTut01Src/
$#=
$*+>.fSub() Kommentar
$*+>~tmp.jcl(t) Kommentar
$*+@=¢ Kommentar
$=subsys=DBAF
$=db=DA540769
$=ts=A977A
$*+@<~wk.jcl(jc) Kommentar
??* -{sysvar(sysnode) date() time()} ts=$ts 10*len=$-{length($ts) * 10}
//P02 EXEC PGM=DSNUTILB,
// PARM='$subsys,A540769C.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=$subsys.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE $db.$ts* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
$@¢if right($ts, 2) == '7A' then $@=¢
FULL YES
$! else
$$ $'' FULL NO
$!
SHRLEVEL CHANGE
$*+! Kommentar
$#out 20120306 09:58:54
$/tstTut01Src/
$=/tstTut01/
### start tst tstTut01 ############################################
compile , 28 lines: $#=
run without input
??* -{sysvar(sysnode) date() time()} ts=A977A 10*len=50
//P02 EXEC PGM=DSNUTILB,
// PARM='DBAF,A540769C.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DBAF.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DA540769.A977A* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
FULL YES
SHRLEVEL CHANGE
$/tstTut01/
$=/tstTut02Src/
$#@
$**>.fSub()
$**@¢
$=subsys=DBAF
$=db=DA540769
$=jx=0
$@do tx = 976 to 977 $@=¢
$=ts=A$tx
$=jx=-$jx+1
//A540769$jx JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//C$ts EXEC PGM=DSNUTILB,
// PARM='$subsys,A540769$jx.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=$subsys.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE $db.$ts* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$!
$**!
$#out 20101229 13
$/tstTut02Src/
$=/tstTut02/
### start tst tstTut02 ############################################
compile , 28 lines: $#@
run without input
//A5407691 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA976 EXEC PGM=DSNUTILB,
// PARM='DBAF,A5407691.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DBAF.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DA540769.A976* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
//A5407692 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA977 EXEC PGM=DSNUTILB,
// PARM='DBAF,A5407692.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DBAF.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DA540769.A977* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$/tstTut02/
$=/tstTut03Src/
$#@
$=subsys=DBAF
$@|¢
db ts
DGDB9998 A976
DA540769 A977
!
$** $| call fmtFTab
$** $#end
$|
$=jx=0
$@forWith o $@=¢
$=jx=-$jx+1
//A540769$jx JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//C$ts EXEC PGM=DSNUTILB,
// PARM='$subsys,A540769$jx.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=$subsys.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE $db.$ts* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$!
$#out
$/tstTut03Src/
$=/tstTut03/
### start tst tstTut03 ############################################
compile , 31 lines: $#@
run without input
//A5407691 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA976 EXEC PGM=DSNUTILB,
// PARM='DBAF,A5407691.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DBAF.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DGDB9998.A976* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
//A5407692 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA977 EXEC PGM=DSNUTILB,
// PARM='DBAF,A5407692.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DBAF.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DA540769.A977* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$/tstTut03/
$=/tstTut04Src/
$#@
$=subsys=DBAF
$=db=DA540769
call sqlConnect $subsys
$@=¢ select dbName db , name ts
from sysibm.sysTablespace
where dbName = '$db' and name < 'A978'
order by name desc
fetch first 2 rows only
$!
$| call sqlSel
$** $| call fmtFTab
$** $#end
$|
$=jx=0
$@forWith o $@=¢
$=jx=-$jx+1
//A540769$jx JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//C$TS EXEC PGM=DSNUTILB,
// PARM='$subsys,A540769$jx.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=$subsys.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE $DB.$TS* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$!
call sqlDisConnect
$#out 20101229
$/tstTut04Src/
$=/tstTut04/
### start tst tstTut04 ############################################
compile , 36 lines: $#@
run without input
//A5407691 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA977A EXEC PGM=DSNUTILB,
// PARM='DBAF,A5407691.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DBAF.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DA540769.A977A* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
//A5407692 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA976A EXEC PGM=DSNUTILB,
// PARM='DBAF,A5407692.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DBAF.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DA540769.A976A* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$/tstTut04/
$=/tstTut05Src/
$#@
$=subsys = dbaf
$=lst=<:¢
db = DGDB9998
ts =<|¢
ts
A976
A977
!;
db = DA540769
<|/ts/
ts
A976
A975
/ts/
!
$** $$. $lst
$** $@ct $@¢$=tool =. $.compile@ $<~.wk.rexx(wshtut06)$!
$** $@$tool
$@do sx=1 to ${lst.0} $@¢
$=db = ${lst.$sx.db}
$** $$. ${lst.$sx}
$@do tx=1 to ${lst.$sx.ts.0} $@=¢
$*+ $$. ${lst.$sx.ts.$tx}
$=ts= ${lst.$sx.ts.$tx.ts}
$@¢ say $-=¢subsys $subsys db $db ts $ts $! $!
$@copy()
$!
$!
$@ct $@¢
cl = classNew('n? DbTsList u s' ,
classNew('n? DbTs u f db v, f ts s' ,
classNew('n? Ts u f ts v')))
$=lst=. mNew(cl)
$!
$@proc copy $@=¢
$@ct $=jx=0
$=jx=-$jx+1
//A540769$jx JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//C$ts EXEC PGM=DSNUTILB,
// PARM='$subsys,A540769$jx.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=$subsys.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE $db.$ts* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$!
$#out 201012
$/tstTut05Src/
$=/tstTut05/
### start tst tstTut05 ############################################
compile , 56 lines: $#@
run without input
//A5407691 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA976 EXEC PGM=DSNUTILB,
// PARM='dbaf,A5407691.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=dbaf.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DGDB9998.A976* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
//A5407692 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA977 EXEC PGM=DSNUTILB,
// PARM='dbaf,A5407692.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=dbaf.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DGDB9998.A977* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
//A5407693 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA976 EXEC PGM=DSNUTILB,
// PARM='dbaf,A5407693.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=dbaf.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DA540769.A976* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
//A5407694 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA975 EXEC PGM=DSNUTILB,
// PARM='dbaf,A5407694.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=dbaf.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DA540769.A975* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$/tstTut05/
tstTut06 ==> platz für copy aus tut05
$=/tstTut07Src/
$**$>.fEdit()
call sqlConnect dbtf
$@|¢ ts
VTCASHFLOW
VTCASHFLOWAMOUNT
VTINSTRFLATDATA
$!
$| $@=¢
select name, statstime, strip(dbName) || '.' || strip(tsName) dbts
from sysibm.sysTables
where creator = 'VDPS2' and name in
$=co=(
$@forWith t $@=¢
$co '$ts'
$=co=,
$!
)
$!
$| call sqlSel
$** $| call fmtFtab
$|
$=jx=0
$@forWith t $@=¢
$=jx=-$jx+1
//A540769$jx JOB (CP00,KE50),
// 'CATALOG',MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//STEP$jx EXEC PGM=DSNUTILB,TIME=1440,
// PARM=(DBTF,'A540769$jx.RUNSTA'),
// REGION=0M
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSOUT DD SYSOUT=*
//RNPRIN01 DD SYSOUT=*
//SYSIN DD *
LISTDEF LST#STA INCLUDE TABLESPACE $DBTS
OPTIONS EVENT (ITEMERROR, SKIP)
RUNSTATS TABLESPACE LIST LST#STA
SHRLEVEL CHANGE
INDEX(ALL KEYCARD)
REPORT YES UPDATE ALL
$!
call sqlDisconnect dbaf
$#out 20101231 11:56:23
$/tstTut07Src/
$=/tstTut07/
$=/tstTut07/
### start tst tstTut07 ############################################
compile , 46 lines: $**$>.fEdit()
run without input
//A5407691 JOB (CP00,KE50),
// 'CATALOG',MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//STEP1 EXEC PGM=DSNUTILB,TIME=1440,
// PARM=(DBTF,'A5407691.RUNSTA'),
// REGION=0M
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSOUT DD SYSOUT=*
//RNPRIN01 DD SYSOUT=*
//SYSIN DD *
LISTDEF LST#STA INCLUDE TABLESPACE VV27A1T.VDPS329
OPTIONS EVENT (ITEMERROR, SKIP)
..
RUNSTATS TABLESPACE LIST LST#STA
SHRLEVEL CHANGE
INDEX(ALL KEYCARD)
REPORT YES UPDATE ALL
//A5407692 JOB (CP00,KE50),
// 'CATALOG',MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//STEP2 EXEC PGM=DSNUTILB,TIME=1440,
// PARM=(DBTF,'A5407692.RUNSTA'),
// REGION=0M
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSOUT DD SYSOUT=*
//RNPRIN01 DD SYSOUT=*
//SYSIN DD *
LISTDEF LST#STA INCLUDE TABLESPACE VV28A1T.VDPS390
OPTIONS EVENT (ITEMERROR, SKIP)
..
RUNSTATS TABLESPACE LIST LST#STA
SHRLEVEL CHANGE
INDEX(ALL KEYCARD)
REPORT YES UPDATE ALL
//A5407693 JOB (CP00,KE50),
// 'CATALOG',MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//STEP3 EXEC PGM=DSNUTILB,TIME=1440,
// PARM=(DBTF,'A5407693.RUNSTA'),
// REGION=0M
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSOUT DD SYSOUT=*
//RNPRIN01 DD SYSOUT=*
//SYSIN DD *
LISTDEF LST#STA INCLUDE TABLESPACE VV21A1T.VDPS004
OPTIONS EVENT (ITEMERROR, SKIP)
..
RUNSTATS TABLESPACE LIST LST#STA
SHRLEVEL CHANGE
INDEX(ALL KEYCARD)
REPORT YES UPDATE ALL
$/tstTut07/
$=/tstTut08Src/
$/tstTut08Src/
$=/tstTut08/
$/tstTut08/
*/
call sqlOIni
call sqlDisconnect '*'
call tstComp2 'tstTut01'
call tstComp2 'tstTut02'
call tstComp2 'tstTut03'
call tstComp2 'tstTut04'
call tstComp2 'tstTut05'
call tstComp2 'tstTut07'
return
endProcedure tstTut0
/* copx tstComp end *************************************************/
/* copx tstBase begin **************************************************
test the basic classes
***********************************************************************/
tstBase: procedure expose m.
call tstTstSay
call oIni
call tstM
call tstMCat
call tstMap
call tstMapVia
call tstClass
call tstClass2
call tstO
call tstOGet
call jIni
call tstJSay
call tstJ
call tstJ2
call catIni
call tstCat
call pipeIni
CALL TstEnv
CALL TstEnvCat
call tstPipe
call tstEnvVars
call tstEnvWith
call tstTotal
call tstPipeLazy
call tstEnvClass
call tstFile
call tstFileList
call tstF
call tstFmt
call tstFmtUnits
call tstTotal
call scanIni
call tstScan
call ScanReadIni
call tstScanRead
call tstScanUtilInto
call tstScanWin
call tstScanSQL
call tstScanSqlStmt
call tstTotal
return
endProcedure tstBase
/*--- test the tst Module, check the output visually ----------------*/
tstTstSay: procedure expose m.
call tstIni
oldErr = m.tst.err
oldNames = m.tst.errNames
say '+++ tstTstSay start with' oldErr 'totErrs and',
m.tst.tests 'tests'
/*
$=/tstTstSayEins/
### start tst tstTstSayEins #######################################
test eins einzige testZeile
$/tstTstSayEins/
$=/tstTstSayZwei/
### start tst tstTstSayZwei #######################################
zwei 1. testZeile
zwei 2. und letzte testZeile
$/tstTstSayZwei/
$=/tstTstSayDrei/
### start tst tstTstSayDrei #######################################
drei 1. testZeile vor empty Zeile
..
drei 3. testZeile vor 10 space
. .
drei 5. testZeile ziemlich lang 66 +
. 77 5 10 15++++++++++++++++++++
.+++++++++++++++++++++++++++++++++++++++++++.
$/tstTstSayDrei/
*/
call tst x, 'tstTstSayEins'
call tstOut x, "test eins einzige testZeile"
call tstEnd x, 'err 0'
call tst x, 'tstTstSayZwei'
call tstOut x, "zwei 1. testZeile"
call tstOut x, "zwei 2. und letzte testZeile"
call tstEnd x, 'err 0'
call tst x, 'tstTstSayZwei'
call tstOut x, "zwei 1. testZeile " /* ein space zuviel */
call tstOut x, "zwei 2. und letzte testZeile"
call tstOut x, "zwei 3. zuviel"
call tstEnd x, 'err 3'
call tst y, 'tstTstSayDrei'
call tstOut y, 'drei 1. testZeile vor empty Zeile'
call tstOut y, ''
call tstOut y, 'drei 3. testZeile vor 10 space'
call tstOut y, left('', 10)
call tstOut y, 'drei 5. testZeile ziemlich lang',
left(66, 66) left('77 5 10 15', 77, '+')
call tstEnd y, 'err 0'
if m.y.err <> 0 then
call err '+++ tstTstSay errs' m.x.err 'expected' 0
if m.tst.err <> oldErr + 3 then
call err '+++ tstTstSay totErrs' m.tst.err 'expected' 3
say '+++ tstTstSay end Ok with' m.tst.err 'totErrs and' ,
m.tst.tests 'tests'
m.tst.err = oldErr
m.tst.errNames = oldNames
return
endProcedure tstTstSay
tstM: procedure expose m.
/*
$=/tstMa/
### start tst tstMa ###############################################
mNew() 1=newM1 2=newM2
mNew(tst...) 2=nZwei new 3=nDrei old free fEins nEins new 4=nVier n+
ew
iter nDrei old free fEins nEins new
iter nZwei new
iter nVier new
$/tstMa/
*/
call tst t, 'tstMa'
m1 = mNew()
m2 = mNew()
m.m1 = 'newM1'
m.m2 = 'newM2'
call tstOut t, 'mNew() 1='m.m1 '2='m.m2
call mNewArea 'tst'm1, ,
, "if symbol('m.m') \== 'VAR' then m.m = arg(2) 'new';" ,
"else m.m = arg(2) 'old' m.m",
, "m.m = 'free' arg(2) m.m"
t1 = mNew('tst'm1, 'nEins')
t2 = mNew('tst'm1, 'nZwei')
call mFree t1, 'fEins'
t3 = mNew('tst'm1, 'nDrei')
t4 = mNew('tst'm1, 'nVier')
call tstOut t, 'mNew(tst...) 2='m.t2 '3='m.t3 '4='m.t4
i = mIterBegin('tst'm1)
do while assNN('i', mIter(i))
call tstOut t, 'iter' m.i
end
call tstEnd t
/*
$=/tstM/
### start tst tstM ################################################
symbol m.b LIT
symbol m.a LIT
mAdd a A.2
mAdd a A.3
m.a: 3: 1=eins 2=zwei 3=drei 4=M.A.4
m.c: 5: 1=c vorAddSt a 2=eins 3=zwei 4=drei 5=c nacAddSt a 6=M.C.6
$/tstM/ */
drop m.b m.a m.a.0 m.a.1 m.a.2
call tst t, 'tstM'
call tstOut t, 'symbol m.b' symbol('m.b')
m.b = 1
call tstOut t, 'symbol m.a' symbol('m.a')
call tstOut t, 'mAdd a' mAdd(mCut(a, 0), 'eins', 'zwei')
call tstOut t, 'mAdd a' mAdd(a, 'drei')
call tstOut t, 'm.a:' m.a.0': 1='m.a.1 '2='m.a.2 '3='m.a.3 '4='m.a.4
call mAdd mCut(c, 0), 'c vorAddSt a'
call mAddSt c, a
call mAdd c, 'c nacAddSt a'
call tstOut t, 'm.c:' m.c.0': 1='m.c.1 '2='m.c.2 '3='m.c.3,
'4='m.c.4 '5='m.c.5 '6='m.c.6
call tstEnd t
return
endProcedure tstM
tstMCat: procedure expose m.
/*
$=/tstMCat/
### start tst tstMCat #############################################
mCat(0, %+Q) =;
mCat(0, %+Q1) =;
mCat(0, %s11%+Q2222) =;
mCat(0, 1%s2%+Q3) =;
mCat(0, 1%s2@%s333%+Q4) =;
mCat(0, 1%s2@%s3@%s4%+Q5) =;
mCat(1, %+Q) =eins;
mCat(1, %+Q1) =eins;
mCat(1, %s11%+Q2222) =eins11;
mCat(1, 1%s2%+Q3) =1eins2;
mCat(1, 1%s2@%s333%+Q4) =1eins2eins333;
mCat(1, 1%s2@%s3@%s4%+Q5) =1eins2eins3eins4;
mCat(2, %+Q) =einszwei;
mCat(2, %+Q1) =eins1zwei;
mCat(2, %s11%+Q2222) =eins112222zwei11;
mCat(2, 1%s2%+Q3) =1eins231zwei2;
mCat(2, 1%s2@%s333%+Q4) =1eins2eins33341zwei2zwei333;
mCat(2, 1%s2@%s3@%s4%+Q5) =1eins2eins3eins451zwei2zwei3zwei4;
mCat(3, %+Q) =einszweidrei;
mCat(3, %+Q1) =eins1zwei1drei;
mCat(3, %s11%+Q2222) =eins112222zwei112222drei11;
mCat(3, 1%s2%+Q3) =1eins231zwei231drei2;
mCat(3, 1%s2@%s333%+Q4) =1eins2eins33341zwei2zwei33341drei2dr+
ei333;
mCat(3, 1%s2@%s3@%s4%+Q5) =1eins2eins3eins451zwei2zwei3zwei451d+
rei2drei3drei4;
$/tstMCat/ */
call mIni
call tst t, "tstMCat"
m.qq.1 = "eins"
m.qq.2 = "zwei"
m.qq.3 = "drei"
do qx = 0 to 3
m.qq.0 = qx
call tstMCat1 qx, '%+Q'
call tstMCat1 qx, '%+Q1'
call tstMCat1 qx, '%s11%+Q2222'
call tstMCat1 qx, '1%s2%+Q3'
call tstMCat1 qx, '1%s2@%s333%+Q4'
call tstMCat1 qx, '1%s2@%s3@%s4%+Q5'
end
call tstEnd t
return
endProcedure tstMCat
tstMCat1: procedure expose m.
parse arg m.qq.0, fmt
call out left("mCat("m.qq.0"," fmt")", 30)"="mCat(qq, fmt)";"
return
endProcedure tstMCat1
tstMap: procedure expose m.
/*
$=/tstMap/
### start tst tstMap ##############################################
mapNew m keys m-keys 0
map m zwei --> 2
map m Zwei is not defined
map stem m-keys 4
map m eins --> 1
map m zwei --> 2
map m drei --> 3
map m vier --> 4
*** err: duplicate key eins in map m
map m zwei is not defined
q 2 zw dr
map stem Q 2
map Q zw --> 2Q
map Q dr --> 3Q
map stem m 3
map m eins --> 1
map m zwei --> 2PUT
map m vier --> 4PUT
*** err: duplicate key zwei in map m
tstMapLong eins keys 3
tstMapLong zweiMal keys 48
tstMapLong dreiMal keys 93
tstMapLong vier keys 138
tstMapLong <fuenf> keys 188
tstMap clear keys 0
inline1 3
inline1 1 == inline1 eins==
inline1 2 ====
inline1 3 == inline1 drei==
inline2 1 1 == inline2 eins==
inline3 ?
$/tstMap/ */
/*
$=/tstMapInline1/
inline1 eins
inline1 drei
$/tstMapInline1/ */
/*
$=/tstMapInline2/
inline2 eins
$/tstMapInline2/ */
call tst t, 'tstMap'
m = mapNew('K')
ky = mapKeys(m)
call mAdd t'.TRANS', m 'm', ky 'm-keys'
call tstOut t, 'mapNew' m 'keys' ky m.ky.0
call mapAdd m, 'eins', 1
call mapAdd m, 'zwei', 2
call mapAdd m, 'drei', 3
call mapAdd m, 'vier', 4
call tstMapShow m, 'zwei'
call tstMapShow m, 'Zwei'
call tstMapShowSt m, mapKeys(m)
call mapAdd m, 'eins', 1
call mapReset m, '='
call tstMapShow m, 'zwei'
call mapAdd m, 'eins', 1
call mapAdd m, 'zwei', 2
call mapPut m, 'zwei', 2Put
call mapPut m, 'vier', 4Put
call mapReset q, '='
call mapAdd q, 'zw', 2q
call mapAdd q, 'dr', 3q
call tstOut t, 'q' m.q.0 m.q.1 m.q.2
call tstMapShowSt q, mapKeys(q)
call tstMapShowSt m, mapKeys(m)
call mapAdd m, 'zwei', 2addDup
call tstMapLong m, 'eins' ,201, 2000, -2, 2
call tstMapLong m, 'zweiMal' ,201, 2000, -2, 2
call tstMapLong m, 'dreiMal' ,201, 2000, 2,-2
call tstMapLong m, 'vier ' ,2010, 201, -2, 2
call tstMapLong m, '<fuenf>' ,2010, 201, 2,-2
call mapClear m
keys = mapKeys(m)
call tstOut t, 'tstMap clear keys' m.keys.0
i = mapInline('tstMapInline1')
call tstOut t, 'inline1' m.i.0
do x=1 to m.i.0
call tstOut t, 'inline1' x '=='m.i.x'=='
end
i = mapInline('tstMapInline2')
call tstOut t, 'inline2' m.i.0 '1 =='m.i.1'=='
call tstOut t, 'inline3' mapInline('tstMapInline3', 'r')'?'
call tstEnd t
return
endProcedure tstMap
tstMapLong: procedure expose m.
parse arg m, w, f1, t1, f2, t2
if f1 < t1 then
b1 = 201
else
b1 = -201
if f2 < t2 then
b2 = 1
else
b2 = -1
lo = copies(w, 2100 % length(w))
keys = mapKeys(m)
keyCn = m.keys.0
call tstOut t, 'tstMapLong' w 'keys' keyCn
do x = f1 by b1 to t1
do y = x+f2 by b2 to x+t2
k = left(lo, y)
if mapHasKey(m, k) then
call err 'mapLong hasKey before' w y
call mapAdd m, k, w y
if \ mapHasKey(m, k) then
call err 'mapLong \ hasKey after' w y
if mapGet(m, k) \== w y then
call err 'mapLong \ get <> ' w y
keys = mapKeys(m)
if keyCn + 1 \= m.keys.0 then
call err 'mapLong keys .0 <> ' w y
keyCn = m.keys.0
if k \== m.keys.keyCn then
call err 'mapLong keys . ' keyCn '<>' w y
end
end
return
endProcedure tstMapLong
tstMapVia: procedure expose m.
/*
$=/tstMapVia/
### start tst tstMapVia ###########################################
map M K --> A
mapVia(m, K) A
*** err: missing m.A at 3 in mapVia(M, K|)
mapVia(m, K|) M.A
mapVia(m, K|) valAt m.a
mapVia(m, K|) valAt m.a
*** err: missing m.A.aB at 5 in mapVia(M, K|aB)
mapVia(m, K|aB) M.A.aB
mapVia(m, K|aB) valAt m.A.aB
*** err: missing m.valAt m.a at 4 in mapVia(M, K||)
mapVia(m, K||) M.valAt m.a
mapVia(m, K||) valAt m.valAt m.a
mapVia(m, K||F) valAt m.valAt m.a.F
$/tstMapVia/ */
call tst t, 'tstMapVia'
u = 'A.aB'
v = 'valAt m.a'
drop m.a m.u m.v m.v.f
call mapReset m, 'K'
call mapAdd m, k, a
call tstMapShow m, k
call tstOut t, 'mapVia(m, K) ' mapVia(m, 'K')
call tstOut t, 'mapVia(m, K|) ' mapVia(m, 'K|')
m.a = v
call tstOut t, 'mapVia(m, K|) ' mapVia(m, 'K|')
call tstOut t, 'mapVia(m, K|) ' mapVia(m, 'K|')
call tstOut t, 'mapVia(m, K|aB) ' mapVia(m, 'K|aB')
m.u = 'valAt m.'u
call tstOut t, 'mapVia(m, K|aB) ' mapVia(m, 'K|aB')
call tstOut t, 'mapVia(m, K||) ' mapVia(m, 'K||')
v = m.a
m.v = 'valAt m.'v
m.v.f = 'valAt m.'v'.F'
call tstOut t, 'mapVia(m, K||) ' mapVia(m, 'K||')
call tstOut t, 'mapVia(m, K||F) ' mapVia(m, 'K||F')
call tstEnd t
return
endProcedure tstMapVia
tstMapShow: procedure expose m.
parse arg a, key
if mapHasKey(a, key) then
call tstOut t, 'map' a key '-->' mapGet(a, key)
else
call tstOut t, 'map' a key 'is not defined'
return
endProcedure tstMapShow
tstMapShowSt: procedure expose m.
parse arg a, st
call tstOut t, 'map stem' st m.st.0
do wx=1 to m.st.0
call tstMapShow a, m.st.wx
end
return
endProcedure tstMapShow
tstClass2: procedure expose m.
/*
$=/tstClass2o2/
### start tst tstClass2 ###########################################
@CLASS.5 isA :class = u
. choice u union
. .NAME = class
. stem 7
. .1 refTo @CLASS.1 :class = u
. choice v union
. choice c union
. .NAME = u
. .CLASS refTo @CLASS.15 :class = s
. choice s .CLASS refTo @CLASS.12 done :class @CLASS.12
. .2 refTo @CLASS.6 :class = c
. choice c union
. .NAME = v
. .CLASS refTo @CLASS.7 :class = u
. choice u stem 0
. .3 refTo @CLASS.8 :class = c
. choice c union
. .NAME = w
. .CLASS refTo @CLASS.7 done :class @CLASS.7
. .4 refTo @CLASS.9 :class = c
. choice c union
. .NAME = o
. .CLASS refTo @CLASS.7 done :class @CLASS.7
. .5 refTo @CLASS.10 :class = c
. choice c union
. .NAME = s
. .CLASS refTo @CLASS.11 :class = f
. choice f union
. .NAME = CLASS
. .CLASS refTo @CLASS.12 :class = r
. choice r .CLASS refTo @CLASS.5 done :class @CLASS.5
. .6 refTo @CLASS.13 :class = c
. choice c union
. .NAME = r
. .CLASS refTo @CLASS.11 done :class @CLASS.11
. .7 refTo @CLASS.14 :class = c
. choice c union
. .NAME = u
. .CLASS refTo @CLASS.15 :class = s
. choice s .CLASS refTo @CLASS.12 done :class @CLASS.12
. .8 refTo @CLASS.16 :class = c
. choice c union
. .NAME = n
. .CLASS refTo @CLASS.17 :class = u
. choice u stem 2
. .1 refTo @CLASS.18 :class = f
. choice f union
. .NAME = NAME
. .CLASS refTo @CLASS.1 done :class @CLASS.1
. .2 refTo @CLASS.15 done :class @CLASS.15
. .9 refTo @CLASS.19 :class = c
. choice c union
. .NAME = f
. .CLASS refTo @CLASS.20 :class = u
. choice u stem 2
. .1 refTo @CLASS.18 done :class @CLASS.18
. .2 refTo @CLASS.11 done :class @CLASS.11
. .10 refTo @CLASS.21 :class = c
. choice c union
. .NAME = c
. .CLASS refTo @CLASS.20 done :class @CLASS.20
. .11 refTo @CLASS.22 :class = c
. choice c union
. .NAME = m
. .CLASS refTo @CLASS.23 :class = u
. choice u stem 2
. .1 refTo @CLASS.18 done :class @CLASS.18
. .2 refTo @CLASS.24 :class = f
. choice f union
. .NAME = MET
. .CLASS refTo @CLASS.1 done :class @CLASS.1
$/tstClass2o2/
$=/tstClass2/
### start tst tstClass2 ###########################################
@CLASS.4 isA :class = u
. choice u union
. .NAME = class
. stem 7
. .1 refTo @CLASS.1 :class = u
. choice u union
. .NAME = v
. stem 2
. .1 refTo @CLASS.20 :class = m
. choice m union
. .NAME = o2String
. .MET = return m.m
. .2 refTo @CLASS.86 :class = m
. choice m union
. .NAME = o2File
. .MET = return file(m.m)
. .2 refTo @CLASS.5 :class = c
. choice c union
. .NAME = u
. .CLASS refTo @CLASS.6 :class = u
. choice u union
. .NAME = .
. stem 2
. .1 refTo @CLASS.7 :class = f
. choice f union
. .NAME = NAME
. .CLASS refTo @CLASS.1 done :class @CLASS.1
. .2 refTo @CLASS.8 :class = s
. choice s .CLASS refTo @CLASS.9 :class = r
. choice r .CLASS refTo @CLASS.4 done :class @CLASS.4
. .3 refTo @CLASS.10 :class = c
. choice c union
. .NAME = f
. .CLASS refTo @CLASS.11 :class = u
. choice u union
. .NAME = .
. stem 2
. .1 refTo @CLASS.7 done :class @CLASS.7
. .2 refTo @CLASS.12 :class = f
. choice f union
. .NAME = CLASS
. .CLASS refTo @CLASS.9 done :class @CLASS.9
. .4 refTo @CLASS.13 :class = c
. choice c union
. .NAME = s
. .CLASS refTo @CLASS.12 done :class @CLASS.12
. .5 refTo @CLASS.14 :class = c
. choice c union
. .NAME = c
. .CLASS refTo @CLASS.11 done :class @CLASS.11
. .6 refTo @CLASS.15 :class = c
. choice c union
. .NAME = m
. .CLASS refTo @CLASS.16 :class = u
. choice u union
. .NAME = .
. stem 2
. .1 refTo @CLASS.7 done :class @CLASS.7
. .2 refTo @CLASS.17 :class = f
. choice f union
. .NAME = MET
. .CLASS refTo @CLASS.1 done :class @CLASS.1
. .7 refTo @CLASS.18 :class = c
. choice c union
. .NAME = r
. .CLASS refTo @CLASS.12 done :class @CLASS.12
$/tstClass2/ */
call oIni
call tst t, 'tstClass2'
call classOut , m.class.class
call tstEnd t
return
endProcedure tstClass2
tstClass: procedure expose m.
/*
$=/tstClass/
### start tst tstClass ############################################
Q u =className= tstClassTf12
Q.eins.zwei v ==> M.Q.eins.zwei
*** err: bad type v: classNew(v tstClassTf12)
*** err: bad type v: classBasicNew(v, tstClassTf12, )
R u =className= uststClassTf12
R u =className= uststClassTf12in
R u =className= tstClassTf12
R.eins.zwei v ==> M.R.eins.zwei
R s =stem.0= 2
R.1 r ==> M.R.1 :CLASS.3
R.1 u =className= tstClassTf12
R.1.eins.zwei v ==> M.R.1.eins.zwei
R.2 r ==> M.R.2 :CLASS.3
R.2 u =className= tstClassTf12
R.2.eins.zwei v ==> M.R.2.eins.zwei
S u =className= TstClass7
S s =stem.0= 2
S.1 u =className= TstClass7s
S.1.eins v ==> M.S.1.eins
S.1 m =met-metA--> say "metA"
S.1 m =met-metB--> say "metB"
S.2 u =className= TstClass7s
S.2.zwei v ==> M.S.2.zwei
S.2 m =met-metA--> say "metA"
S.2 m =met-metB--> say "metB"
class of mutate qq tstClassTf12
$/tstClass/ */
f = 'eins.zwei'
e = 'eins'
z = 'zwei'
drop m.q.f m.r.f m.r.0 m.r.1 m.r.1.f m.r.2 m.r.2.f
drop m.s.0 m.s.1 m.s.1.e m.s.2 m.s.2.z
call classIni
call tst t, 'tstClass'
t1 = classNew('n? tstClassTf12 u f eins f zwei v')
call tstClassOut t, t1, q
z = m.class.0
if class4name('tstClassB', '') == '' then do
t2 = classNew('n tstClassB u n tstClassC u tstClassTf12,',
's u v tstClassTf12')
end
else do /* the second time we would get a duplicate error */
call tstOut t, '*** err: bad type v: classNew(v tstClassTf12)'
call tstOut t, '*** err: bad type v:' ,
'classBasicNew(v, tstClassTf12, )'
end
t2 = classNew('n? uststClassTf12 u' ,
'n? uststClassTf12in u tstClassTf12',
, classNew('s u r, tstClassTf12'))
m.r.0 = 2
call tstClassOut t, t2, r
t3 = classNew('n? TstClass7 u s',
classNew('n? TstClass7s u c 1 f eins v, c 2 f zwei v',
,'m', 'metA say "metA"', 'metB say "metB"'))
m.s.0 = 2
m.s.1 = 1
m.s.2 = 2
call tstClassOut t, t3, s
call oMutate qq, 'tstClassTf12'
tt = objClass(qq)
call tstOut t, 'class of mutate qq' m.tt.name
call tstEnd t
return
endProcedure tstClass
tstClassOut: procedure expose m.
parse arg o, t, a
if wordPos(t, m.class.classV m.class.classW m.class.classO) > 0 then
return tstOut(o, a m.t.name '==>' m.a)
if m.t == 'r' then
return tstOut(o, a m.t '==>' m.a ':'m.t.class)
if m.t == 'u' & m.t.name \== '' then
call tstOut o, a m.t '=className=' m.t.name
if m.t == 'f' then
return tstClassOut(o, m.t.class, a'.'m.t.name)
if m.t = 'u' then do
do ux=1 to m.t.0
call tstClassOut o, m.t.ux, a
end
return 0
end
if m.t = 's' then do
call tstOut o, a m.t '=stem.0=' m.a.0
do ux=1 to m.a.0
call tstClassOut o, m.t.class, a'.'ux
end
return 0
end
if m.t = 'c' then do
if m.t.name = m.a then
call tstClassOut o, m.t.class, a
return 0
end
if m.t = 'm' then
return tstOut(o, a m.t '=met-'m.t.name'-->' m.t.met)
call err 'bad class type' m.t
endProcedure tstClassOut
tstO: procedure expose m.
/*
$=/tstO/
### start tst tstO ################################################
class method calls of TstOEins
. met Eins.eins M
FLDS of <obj e of TstOEins> .FEINS, .FZWEI
methodcalls of object e of TstOEins
. met Eins.eins <obj e of TstOEins>
. met Eins.zwei <obj e2 of TstOEins>
*** err: no method nein in class TstOEins of object <obj e+
. of TstOEins>
*** err: no class found for object noObj
class method calls of TstOEins
. met Elf.zwei M
FLDS of <obj f of TstOElf> .FEINS, .FZWEI, .FELF
methodcalls of object f of TstOElf
. met Eins.eins <obj f of TstOElf>
. met Elf.zwei <obj f of TstOElf>
. met Elf.drei <obj f of TstOElf>
methodcalls of object f cast To TstOEins
. met Eins.eins <obj f of TstOElf>
. met Eins.zwei <obj f of TstOElf>
FLDS of <cast(f, TstOEins)> .FEINS, .FZWEI
oCopy c1 of class TstOEins, c2
C1 u =className= TstOEins
C1.FEINS v ==> M.C1.FEINS
C1.FZWEI v ==> M.C1.FZWEI
C1 m =met-eins--> call tstOut t, " met Eins.eins" m
C1 m =met-zwei--> call tstOut t, " met Eins.zwei" m
C2 u =className= TstOEins
C2.FEINS v ==> M.C1.FEINS
C2.FZWEI v ==> M.C1.FZWEI
C2 m =met-eins--> call tstOut t, " met Eins.eins" m
C2 m =met-zwei--> call tstOut t, " met Eins.zwei" m
oCopy c3 of class TstOElf, c4
C4 u =className= TstOElf
C4 u =className= TstOEins
C4.FEINS v ==> M.C3.FEINS
C4.FZWEI v ==> M.C3.FZWEI
C4 m =met-eins--> call tstOut t, " met Eins.eins" m
C4 m =met-zwei--> call tstOut t, " met Eins.zwei" m
C4.FELF r ==> M.C3.FELF :CLASS.3
C4 m =met-zwei--> call tstOut t, " met Elf.zwei" m
C4 m =met-drei--> call tstOut t, " met Elf.drei" m
tEinsDop <class TstOEins>
oRun 7*3 21
oRun 12*12 144
$/tstO/ */
call tst t, 'tstO'
tEins = classNew('n? TstOEins u f FEINS v,f FZWEI v', 'm',
, 'eins call tstOut t, " met Eins.eins" m',
, 'zwei call tstOut t, " met Eins.zwei" m')
call mAdd t.trans, tEins '<class TstOEins>'
call tstOut t, 'class method calls of TstOEins'
interpret classMet('TstOEins', 'eins')
e = oNew('TstOEins')
e2 = oNew('TstOEins')
call mAdd t.trans, e '<obj e of TstOEins>'
call mAdd t.trans, e2 '<obj e2 of TstOEins>'
call tstOut t, 'FLDS of' e mCat(oFlds(e), '%+Q, ')
call tstOut t, 'methodcalls of object e of TstOEins'
call tstOmet e, 'eins'
call tstOmet e2, 'zwei'
call tstOmet e, 'nein'
call tstOmet 'noObj', 'nein'
tElf = classNew('n? TstOElf u TstOEins, f FELF r', 'm',
, 'zwei call tstOut t, " met Elf.zwei" m',
, 'drei call tstOut t, " met Elf.drei" m')
call tstOut t, 'class method calls of TstOEins'
interpret classMet('TstOElf', 'zwei')
f = oNew('TstOElf')
call mAdd t.trans, f '<obj f of TstOElf>'
call tstOut t, 'FLDS of' f mCat(oFlds(f), '%+Q, ')
call tstOut t, 'methodcalls of object f of TstOElf'
call tstOmet f, 'eins'
call tstOmet f, 'zwei'
call tstOmet f, 'drei'
call tstOut t, 'methodcalls of object f cast To TstOEins'
call tstOmet oCast(f, 'TstOEins'), 'eins'
call tstOmet oCast(f, 'TstOEins'), 'zwei'
call tstOut t, 'FLDS of <cast(f, TstOEins)>',
mCat(oFlds(oCast(f, 'TstOEins')), '%+Q, ')
call oMutate c1, 'TstOEins'
call tstOut t, 'oCopy c1 of class TstOEins, c2'
call tstClassOut t, tEins, c1
call oCopy c1, c2
call tstClassOut t, tEins, c2
call tstOut t, 'oCopy c3 of class TstOElf, c4'
call oMutate c3, 'TstOElf'
call oCopy c3, c4
call tstClassOut t, tElf, c4
/* tEinsDop = classNew('n TstOEins u f FEINS v,f FZWEI v', 'm',
, 'eins call tstOut t, " met Eins.eins" m',
, 'zwei call tstOut t, " met Eins.zwei" m')
*/ tEinsDop = tEins
call tstOut t, 'tEinsDop' tEinsDop
e3 = oNew('TstOEins')
if e3 <<= e | e3 <<= e2 then
call err 'doppelt reinitialised objects'
rr = oRunner('return 7 * 3')
call tstOut t, 'oRun 7*3' oRun(rr)
r12 = oRunner('return 12 * 12')
call tstOut t, 'oRun 12*12' oRun(r12)
call tstEnd t
return
endProcedure tstO
tstOmet: procedure expose m.
parse arg m, met
interpret objMet(m, met)
return
endProcedure tstOmet
tstOGet: procedure expose m.
/*
$=/tstOGet/
### start tst tstOGet #############################################
class.NAME= class
class.NAME= class : w
class| = u
*** err: bad stem index 91>7 @ CLASS.4 class class in oGet(CLASS.4,+
. 91)
class.91 = 0
class.1 = CLASS.1 |= u
class.2 = CLASS.5 |= c
$/tstOGet/ */
call oIni
call tst t, 'tstOGet'
cc = m.class.class
call tstOut t, 'class.NAME=' oGet(cc, 'NAME')
o = oGetO(cc, 'NAME')
call tstOut t, 'class.NAME=' o2String(o) ':' className(objClass(o))
call tstOut t, 'class| =' oGet(cc, '|')
call tstOut t, 'class.91 =' className(oGet(cc, 91))
call tstOut t, 'class.1 =' oGetO(cc, '1') '|=' oGet(cc, '1||')
call tstOut t, 'class.2 =' className(oGetO(cc, '2')) ,
'|=' oGet(cc, '2||')
call tstEnd t
/*
$=/tstOGet2/
### start tst tstOGet2 ############################################
tstOGet1 get1 w
tstOGet1.f1 get1.f1 v
tstOGet1.f2 get1.f2 w
tstOGet1.F3| get1.f3 v
tstOGet1.f3.fEins get1.f3.fEins v
tstOGet1.f3.fZwei get1.f3.fZwei w
tstOGet1.f3%fDrei !get1.f3.fDrei w
tstOGet1.f3.fDrei get1.f3.fDrei w
tstOGet1.f3%1 get1.f3.fDrei.1 w
tstOGet1.f3.2 TSTOGET1
tstOGet1.f3.2|f1 get1.f1 v
tstOGet1.f3.2|f3.2|f2 get1.f2 w
*** err: bad stem index 4>3 @ TSTOGET1.F3 class TstOGet0 in oGet(TS+
TOGET1, F3.4)
tstOGet1.f3.4 0
tstOGet1.f3.3 get1.f3.fDrei.3 w
*** err: bad stem index 3>3A @ TSTOGET1.F3 class TstOGet0 in oGet(T+
STOGET1, F3.3)
tstOGet1.f3.2 0
$/tstOGet2/
*/
c0 = classNew('n? TstOGet0 u f FEINS v,f FZWEI w,f FDREI r,v,' ,
's r TstOGet0')
cl = classNew('n? TstOGet u r, f F1 v, f F2 r, f F3 TstOGet0')
call oMutate tstOGet1, cl
m.tstOGet1 = s2o('get1 w')
m.tstOGet1.f1 = 'get1.f1 v'
m.tstOGet1.f2 = s2o('get1.f2 w')
m.tstOGet1.f3 = 'get1.f3 v'
m.tstOGet1.f3.fEins = 'get1.f3.fEins v'
m.tstOGet1.f3.fZwei = s2o('get1.f3.fZwei w')
m.tstOGet1.f3.fDrei = s2o('get1.f3.fDrei w')
m.tstOGet1.f3.0 = 3
m.tstOGet1.f3.1 = s2o('get1.f3.fDrei.1 w')
m.tstOGet1.f3.2 = tstOGet1
m.tstOGet1.f3.3 = s2o('get1.f3.fDrei.3 w')
call tst t, 'tstOGet2'
call tstOut t, 'tstOGet1 ' oGet(tstOGet1, )
call tstOut t, 'tstOGet1.f1 ' oGet(tstOGet1, f1)
call tstOut t, 'tstOGet1.f2 ' oGet(tstOGet1, f2)
call tstOut t, 'tstOGet1.F3| ' oGet(tstOGet1, 'F3|')
call tstOut t, 'tstOGet1.f3.fEins ' oGet(tstOGet1, f3.fEins)
call tstOut t, 'tstOGet1.f3.fZwei ' oGet(tstOGet1, f3.fZwei)
call tstOut t, 'tstOGet1.f3%fDrei ' oGetO(tstOGet1, 'F3%FDREI')
call tstOut t, 'tstOGet1.f3.fDrei ' oGet(tstOGet1, f3.fDrei)
call tstOut t, 'tstOGet1.f3%1 ' oGet(tstOGet1, 'F3%1')
call tstOut t, 'tstOGet1.f3.2 ' oGetO(tstOGet1, 'F3.2')
call tstOut t, 'tstOGet1.f3.2|f1 ' oGet(tstOGet1, 'F3.2|F1')
call tstOut t, 'tstOGet1.f3.2|f3.2|f2' ,
oGet(tstOGet1, 'F3.2|F3.2|F2')
call tstOut t, 'tstOGet1.f3.4 ' oGet(tstOGet1, 'F3.4')
call tstOut t, 'tstOGet1.f3.3 ' oGet(tstOGet1, 'F3.3')
m.tstOGet1.f3.0 = 3a
call tstOut t, 'tstOGet1.f3.2 ' oGet(tstOGet1, 'F3.3')
call tstEnd t
/*
$=/tstOPut3/
### start tst tstOPut3 ############################################
tstOGet1.f1 get1.f1 v
tstOGet1.f1 aPut1 f1.put1
tstOGet1.f2 aPut2 f2.put2
tstOGet1.f3.fEins p3 f3.fEins,p3
tstOGet1.f3%0 3A
tstOGet1.f3%0 =4 4
tstOGet1.f3.4.feins val f3.4|feins
$/tstOPut3/
*/
call tst t, 'tstOPut3'
call tstOut t, 'tstOGet1.f1 ' oGet(tstOGet1, f1)
call oPut tstOget1, f1, 'f1.put1'
call tstOut t, 'tstOGet1.f1 aPut1' oGet(tstOGet1, f1)
call oPut tstOget1, f2, 'f2.put2'
call tstOut t, 'tstOGet1.f2 aPut2' oGet(tstOGet1, f2)
call oPut tstOget1, f3.fEins, 'f3.fEins,p3'
call tstOut t, 'tstOGet1.f3.fEins p3' oGet(tstOGet1, f3.fEins)
call tstOut t, 'tstOGet1.f3%0 ' oGet(tstOGet1, 'F3%0')
call oPut tstOget1, f3.0, 4
call tstOut t, 'tstOGet1.f3%0 =4' oGet(tstOGet1, 'F3%0')
call oPutO tstOget1, 'F3.4', ''
call oPut tstOget1, 'F3.4|FEINS', 'val f3.4|feins'
call tstOut t, 'tstOGet1.f3.4.feins' ,
oGet(tstOGet1, 'F3.4|FEINS')
call tstEnd t
return
endProcedure tstOGet
tstJSay: procedure expose m.
/*
$=/tstJSay/
### start tst tstJSay #############################################
*** err: bad option openArg in jOpen(<obj j of JRW>, openArg)
*** err: jWrite(<obj j of JRW>, writeArg) but not opened w
*** err: can only write JSay.jOpen(<obj s of JSay>, <)
*** err: jWrite(<obj s of JSay>, write s vor open) but not opened+
. w
*** err: can only read JRWEof.jOpen(<obj e of JRWEof>, >)
*** err: jRead(<obj e of JRWEof>, XX) but not opened r
read e vor open 0 m.xx valueBefore
read e nach open 0 m.xx M.XX
out eins
#jIn 1# tst in line 1 eins ,
out zwei in 1 vv=readAdrVV
#jIn 2# tst in line 2 zwei ; .
out drei in 1 vv=readAdrVV Schluss
$/tstJSay/ */
call jIni
call tst t, 'tstJSay'
jrw = oNew('JRW')
call mAdd t'.TRANS', jrw '<obj j of JRW>'
call jOpen jrw, 'openArg'
call jWrite jrw, 'writeArg'
s = oNew('JSay')
call mAdd t'.TRANS', s '<obj s of JSay>'
call jOpen s, m.j.cRead
s = oNew('JSay')
call mAdd t'.TRANS', s '<obj s of JSay>'
call jWrite s, 'write s vor open'
call jOpen s, '>'
call jWrite s, 'write s nach open'
e = oNew('JRWEof')
call mAdd t'.TRANS', e '<obj e of JRWEof>'
call jOpen e, '>'
e = oNew('JRWEof')
call mAdd t'.TRANS', e '<obj e of JRWEof>'
m.xx = 'valueBefore'
call tstOut t, 'read e vor open' jRead(e, xx) 'm.xx' m.xx
call jOpen e, m.j.cRead
call tstOut t, 'read e nach open' jRead(e, xx) 'm.xx' m.xx
call out 'out eins'
vv = 'readAdrVV'
m.vv = 'readAdrVVValueBefore'
call out 'out zwei in' in(vv) 'vv='vv
m.vv = 'readAdrVVValueBefore'
call out 'out drei in' in(vv) 'vv='vv 'Schluss'
call tstEnd t
return
endProcedure tstJSay
tstJ: procedure expose m.
/*
$=/tstJ/
### start tst tstJ ################################################
out eins
#jIn 1# tst in line 1 eins ,
1 in() tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
2 in() tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
3 in() tst in line 3 drei .schluss..
#jIn eof 4#
in() 3 reads vv VV
line buf line one
line buf line two
line buf line three
line buf line four
*** err: jWrite(<buf b>, buf line five while reading) but not opene+
d w
$/tstJ/ */
call jIni
call tst t, "tstJ"
b = jOpen(jBuf(), '>')
call mAdd t'.TRANS', b '<buf b>'
call out 'out eins'
do lx=1 by 1 while in(var)
call out lx 'in()' m.var
end
call out 'in()' (lx-1) 'reads vv' vv
call jOpen b, '>'
call jWrite b, 'buf line one'
call jClose b
call mAdd m.b.stem, 'buf line two', 'buf line three'
call jWrite b, 'buf line four'
call jClose b
call jOpen b, m.j.cRead
do while (jRead(b, line))
call out 'line' m.line
end
call jWrite b, 'buf line five while reading'
call jClose b
call tstEnd t
return
endProcedure tstJ
tstJ2: procedure expose m.
/*
$=/tstJ2/
### start tst tstJ2 ###############################################
class1 <Tst?1 class> <Tst?1 name>
class2 <Tst?1 class> <Tst?1 name>
class3 <Tst?1 class> <Tst?1 name>
b read EINS feld eins, ZWEI feld zwei, DREI feld drei
b read EINS feld eins, ZWEI feld zwei 2, DREI feld drei
c read EINS feld eins, ZWEI feld zwei, DREI drei cat 1
tstR: @tstWriteoV3 isA :<Tst?1 name>
tstR: .EINS = feld eins
tstR: .ZWEI = feld zwei
tstR: .DREI = drei cat 1
c read EINS feld eins, ZWEI feld zwei 2, DREI drei cat 2
tstR: @tstWriteoV4 isA :<Tst?1 name>
tstR: .EINS = feld eins
tstR: .ZWEI = feld zwei 2
tstR: .DREI = drei cat 2
$/tstJ2/ */
call tst t, "tstJ2"
ty = classNew('n* Tst u f EINS v, f ZWEI v, f DREI v')
call mAdd t'.TRANS', ty '<Tst?1 class>'
call mAdd t'.TRANS', m.ty.name '<Tst?1 name>'
call tstOut t, 'class1' ty m.ty.name
ty = classNew('n* Tst u f EINS v, f ZWEI v, f DREI v')
call tstOut t, 'class2' ty m.ty.name
ty = classNew('n* Tst u f EINS v, f ZWEI v, f DREI v')
call tstOut t, 'class3' ty m.ty.name
call oMutate qq, m.ty.name
m.qq.eins = 'feld eins'
m.qq.zwei = 'feld zwei'
m.qq.drei = 'feld drei'
b = jBuf()
call jOpen b, '>'
call jWriteO b, oCopy(qq)
m.qq.zwei = 'feld zwei 2'
call jWriteO b, qq
call jOpen jClose(b), m.j.cRead
c = jOpen(jBuf(), '>')
do xx=1 while assNN('res', jReadO(b))
call out 'b read EINS' m.res.eins', ZWEI' m.res.zwei,
|| ', DREI' m.res.drei
m.res.drei = 'drei cat' xx
call jWriteO c, res
end
call jOpen jClose(c), m.j.cRead
do while assNN('ccc', jReadO(c))
call out 'c read EINS' m.ccc.eins', ZWEI' m.ccc.zwei,
|| ', DREI' m.ccc.drei
call outO ccc
end
call tstEnd t
return
endProcedure tstJ2
tstCat: procedure expose m.
/*
$=/tstCat/
### start tst tstCat ##############################################
catRead 1 line 1
catRead 2 line 2
catRead 3 line 3
appRead 1 line 1
appRead 2 line 2
appRead 3 line 3
appRead 4 append 4
appRead 5 append 5
$/tstCat/ */
call catIni
call tst t, "tstCat"
i = cat(jBuf('line 1', 'line 2'), jBuf('line 3'))
call jOpen i, m.j.cRead
do lx=1 by 1 while jRead(i, v)
call tstOut t, 'catRead' lx m.v
end
call jOpen jClose(i), m.j.cApp
call jWrite i, 'append 4'
call jWrite i, 'append 5'
call jOpen jClose(i), m.j.cRead
do lx=1 by 1 while jRead(i, v)
call tstOut t, 'appRead' lx m.v
end
call tstEnd t
return
endProcedure tstCat
tstEnv: procedure expose m.
call pipeIni
/*
$=/tstEnv/
### start tst tstEnv ##############################################
before pipeBeLa
after pipeEnd
*** err: jWrite(<jBuf c>, write nach pop) but not opened w
#jIn 1# tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
before writeNow 2 c --> std
before writeNow 1 b --> c
b line eins
b zwei |
nach writeNow 1 b --> c
add nach pop
after push c only
tst in line 1 eins ,
tst in line 2 zwei ; .
tst in line 3 drei .schluss..
nach writeNow 2 c --> std
*** err: jWrite(<jBuf c>, ) but not opened w
$/tstEnv/ */
call tst t, "tstEnv"
c = jBuf()
call mAdd t'.TRANS', c '<jBuf c>'
call out 'before pipeBeLa'
b = jBuf("b line eins", "b zwei |")
call pipeBeLa m.j.cRead b, '>' c
call out 'before writeNow 1 b --> c'
call pipeWriteNow
call out 'nach writeNow 1 b --> c'
call pipeEnd
call out 'after pipeEnd'
call jWrite c, 'write nach pop'
call mAdd c'.BUF', 'add nach pop'
call pipeBeLa '>>' c
call out 'after push c only'
call pipeWriteNow
call pipeEnd
call pipeBeLa m.j.cRead c
call out 'before writeNow 2 c --> std'
call pipeWriteNow
call out 'nach writeNow 2 c --> std'
call pipeEnd
call jWrite c
call tstEnd t
return
endProcedure tstEnv
tstEnvCat: procedure expose m.
call pipeIni
/*
$=/tstEnvCat/
### start tst tstEnvCat ###########################################
c1 contents
c1 line eins |
before writeNow 1 b* --> c*
b1 line eins|
b2 line eins
b2 zwei |
c2 line eins |
after writeNow 1 b* --> c*
c2 contents
c2 line eins |
$/tstEnvCat/ */
call tst t, "tstEnvCat"
b0= jBuf()
b0= jBuf()
b1= jBuf("b1 line eins|")
b2 = jBuf("b2 line eins", "b2 zwei |")
c1 = jBuf("c1 line eins |")
c2 = jBuf("c2 line eins |")
call pipeBeLa m.j.cRead b0, m.j.cRead b1, m.j.cRead b2,
, m.j.cRead c2,'>>' c1
call out 'before writeNow 1 b* --> c*'
call pipeWriteNow
call out 'after writeNow 1 b* --> c*'
call pipeEnd
call out 'c1 contents'
call pipeBeLa m.j.cRead c1
call pipeWriteNow
call pipeEnd
call pipeBeLa m.j.cRead c2
call out 'c2 contents'
call pipeWriteNow
call pipeEnd
call tstEnd t
return
endProcedure tstEnvCat
tstPipe: procedure expose m.
call pipeIni
/*
$=/tstPipe/
### start tst tstPipe #############################################
.+0 vor pipeBegin
#jIn 1# tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
.+7 nach pipeLast
¢7 +6 nach pipe 7!
¢7 +2 nach pipe 7!
¢7 +4 nach nested pipeLast 7!
¢7 (4 +3 nach nested pipeBegin 4) 7!
¢7 (4 (3 +1 nach pipeBegin 3) 4) 7!
¢7 (4 (3 tst in line 1 eins , 3) 4) 7!
¢7 (4 (3 tst in line 2 zwei ; 3) 4) 7!
¢7 (4 (3 tst in line 3 drei .schluss. 3) 4) 7!
¢7 (4 (3 +1 nach writeNow vor pipe 3) 4) 7!
¢7 (4 +3 nach preSuf vor nested pipeLast 4) 7!
¢7 +4 nach preSuf vor nested pipeEnd 7!
¢7 +5 nach nested pipeEnd vor pipe 7!
¢7 +6 nach writeNow vor pipeLast 7!
.+7 nach writeNow vor pipeEnd
.+8 nach pipeEnd
$/tstPipe/ */
say 'x0' m.pipe.0
call tst t, 'tstPipe'
call out '+0 vor pipeBegin'
say 'x1' m.pipe.0
call pipeBegin
call out '+1 nach pipeBegin'
call pipeWriteNow
call out '+1 nach writeNow vor pipe'
call pipe
call out '+2 nach pipe'
call pipeBegin
call out '+3 nach nested pipeBegin'
call pipePreSuf '(3 ', ' 3)'
call out '+3 nach preSuf vor nested pipeLast'
call pipeLast
call out '+4 nach nested pipeLast'
call pipePreSuf '(4 ', ' 4)'
call out '+4 nach preSuf vor nested pipeEnd'
call pipeEnd
call out '+5 nach nested pipeEnd vor pipe'
call pipe
call out '+6 nach pipe'
call pipeWriteNow
say 'out +6 nach writeNow vor pipeLast'
call out '+6 nach writeNow vor pipeLast'
call pipeLast
call out '+7 nach pipeLast'
call pipePreSuf '¢7 ', ' 7!'
call out '+7 nach writeNow vor pipeEnd'
call pipeEnd
call out '+8 nach pipeEnd'
say 'xx' m.pipe.0
call tstEnd t
return
endProcedure tstPipe
tstEnvVars: procedure expose m.
call pipeIni
/*
$=/tstEnvVars/
### start tst tstEnvVars ##########################################
put v1 value eins
v1 hasKey 1 get value eins
v2 hasKey 0
one to theBur
two to theBuf
$/tstEnvVars/ */
call tst t, "tstEnvVars"
call envRemove 'v2'
m.tst.adr1 = 'value eins'
put1 = envPutO('v1', oMutate(tst'.'adr1, m.class.classV))
call tstOut t, 'put v1' m.put1
call tstOut t, 'v1 hasKey' envHasKey('v1') 'get' envGet('v1')
call tstOut t, 'v2 hasKey' envHasKey('v2')
if 0 then
call tstOut t, 'v2 get' envGet('v2')
call pipeBeLa '>' envGetO('theBuf', '-b')
call out 'one to theBur'
call out 'two to theBuf'
call pipeEnd
call pipeBeLa m.j.cRead envGetO('theBuf')
call pipeWriteNow
call pipeEnd
call tstEnd t
return
endProcedure tstEnvVars
tstEnvWith: procedure expose m.
/*
$=/tstEW2/
### start tst tstEW2 ##############################################
tstK1| get1 w
tstK1%f1 get1.f1 v
tstK1.f2 get1.f2 w
tstK1%F3 get1.f3 v
ttstK1.F3.FEINS get1.f3.fEins v
tstK1%F3%FZWEI get1.f3.fZwei w
tstK1.F3.FDREI !get1.f3.fDrei w
tstK1%F3%FDREI| get1.f3.fDrei w
tstK1.F3.1 get1.f3.1 w
tstK1%F3%2 TSTEW1
tstK1.F3.2|F1 get1.f1 v
tstK1%F3%2|F3.2|F2 get1.f2 w
*** err: undefined variable F1 in envGet(F1)
F1 0
F1 get1.f1 v
f2 get1.f2 w
F3 get1.f3 v
F3.FEINS get1.f3.fEins v
F3.FZWEI get1.f3.fZwei w
F3%FDREI !get1.f3.fDrei w
F3%FDREI| get1.f3.fDrei w
F3%1 get1.f3.1 w
pu1 F1 get1.f1 v
pu2 F1 get2.f1 v
po-2 F1 get1.f1 v
*** err: undefined variable F1 in envGet(F1)
po-1 F1 0
$/tstEW2/ */
call pipeIni
c0 = classNew('n? TstEW0 u f FEINS v,f FZWEI w, f FDREI r,v,s r')
cl = classNew('n? TstEW u r TstEW0, f F1 v, f F2 r, f F3 TstEW0')
call oMutate tstEW1, cl
m.tstEW1 = s2o('get1 w')
m.tstEW1.f1 = 'get1.f1 v'
m.tstEW1.f2 = s2o('get1.f2 w')
m.tstEW1.f3 = 'get1.f3 v'
m.tstEW1.f3.fEins = 'get1.f3.fEins v'
m.tstEW1.f3.fZwei = s2o('get1.f3.fZwei w')
m.tstEW1.f3.fDrei = s2o('get1.f3.fDrei w')
m.tstEW1.f3.0 = 3
m.tstEW1.f3.1 = s2o('get1.f3.1 w')
m.tstEW1.f3.2 = tstEW1
m.tstEW1.f3.3 = s2o('get1.f3.3 w')
call oMutate tstEW2, cl
m.tstEW2 = s2o('get2 w')
m.tstEW2.f1 = 'get2.f1 v'
m.tstEW2.f2 = s2o('get2.f2 w')
call envPutO 'tstK1', tstEW1
call tst t, 'tstEW2'
call tstOut t, 'tstK1| ' envGet('tstK1|')
call tstOut t, 'tstK1%f1 ' envGet('tstK1%F1')
call tstOut t, 'tstK1.f2 ' envGet('tstK1.F2')
call tstOut t, 'tstK1%F3 ' envGet('tstK1%F3|')
call tstOut t, 'ttstK1.F3.FEINS ' envGet('tstK1.F3.FEINS')
call tstOut t, 'tstK1%F3%FZWEI ' envGet('tstK1%F3%FZWEI')
call tstOut t, 'tstK1.F3.FDREI ' envGetO('tstK1.F3.FDREI')
call tstOut t, 'tstK1%F3%FDREI| ' envGet('tstK1%F3%FDREI')
call tstOut t, 'tstK1.F3.1 ' envGet('tstK1.F3.1')
call tstOut t, 'tstK1%F3%2 ' envGetO('tstK1%F3%2')
call tstOut t, 'tstK1.F3.2|F1 ' envGet('tstK1.F3.2|F1')
call tstOut t, 'tstK1%F3%2|F3.2|F2' ,
envGet('tstK1%F3%2|F3%2|F2')
call tstOut t, 'F1 ' envGet('F1')
call envPushWith tstEW1
call tstOut t, 'F1 ' envGet('F1')
call tstOut t, 'f2 ' envGet('F2')
call tstOut t, 'F3 ' envGet('F3|')
call tstOut t, 'F3.FEINS ' envGet('F3.FEINS')
call tstOut t, 'F3.FZWEI ' envGet('F3.FZWEI')
call tstOut t, 'F3%FDREI ' envGetO('F3%FDREI')
call tstOut t, 'F3%FDREI| ' envGet('F3%FDREI|')
call tstOut t, 'F3%1 ' envGet('F3%1')
call tstOut t, 'pu1 F1 ' envGet('F1')
call envPushWith tstEW2
call tstOut t, 'pu2 F1 ' envGet('F1')
call envPopWith
call tstOut t, 'po-2 F1 ' envGet('F1')
call envPopWith
call tstOut t, 'po-1 F1 ' envGet('F1')
call tstEnd t
/*
$=/tstEW3/
### start tst tstEW3 ##############################################
. s c3.F1 = v(c3.f1)
*** err: no reference @ <c3>.F1 class CLASS.1 in envGet(c3.F1.FEINS+
)
. s c3.F1.FEINS = 0
. s c3.F3.FEINS = .
. s c3.F3.FEINS = val(c3.F3.FEINS)
*** err: no field FEINS @ <c3> class TstEW in envGet(c3.FEINS)
. s c3.FEINS = 0
*** err: null @ <c3> class TstEW in envGet(c3|FEINS)
. s c3|FEINS = 0
aft Put s c3|FEINS = val(c3|FEINS)
Push c3 s F3.FEINS = val(c3.F3.FEINS)
*** err: no field FEINS aftPuP= pushPut(F3 @ <c3>.F3 class TstEW0 i+
n envGet(F3.FEINS aftPuP= pushPut(F3.FEINS))
. s F3.FEINS aftPuP= 0
push c4 s F1 = v(c4.f1)
put f2 s F2 = put(f2)
*** err: no field F222 in class TstEW in EnvPut(F222, f222 stopped,+
. 1)
put .. s F3.FEINS = put(f3.fEins)
popW c4 s F1 = v(c3.f1)
*** err: undefined variable F1 in envGet(F1)
popW c3 s F1 = 0
. s F222 = f222 pop stop
$/tstEW3/
*/
call tst t, 'tstEW3'
c3 = mNew('TstEW')
call mAdd t.trans, c3 '<c3>'
m.c3.f1 = 'v(c3.f1)'
call envPutO 'c3', c3
call tstEnvSG , 'c3.F1'
call tstEnvSG , 'c3.F1.FEINS'
call tstEnvSG , 'c3.F3.FEINS'
call envPut 'c3.F3.FEINS', 'val(c3.F3.FEINS)'
call tstEnvSG , 'c3.F3.FEINS'
call tstEnvSG , 'c3.FEINS'
call tstEnvSG , 'c3|FEINS'
call envPut 'c3|FEINS', 'val(c3|FEINS)'
call tstEnvSG 'aft Put', 'c3|FEINS'
call envPushWith c3
call tstEnvSG 'Push c3', 'F3.FEINS'
call envPut 'F3.FEINS', 'pushPut(F3.FEINS)'
call tstEnvSG , 'F3.FEINS aftPuP=' envGet('F3.FEINS')
c4 = mNew('TstEW')
call mAdd t.trans, c4 '<c4>'
m.c4.f1 = 'v(c4.f1)'
call envPut f222, 'f222 no stop'
call envPushWith c4
call tstEnvSG 'push c4', f1
call envPut f2, 'put(f2)'
call tstEnvSG 'put f2', f2
call envPut f222, 'f222 stopped', 1
call envPut f3.fEins, 'put(f3.fEins)'
call tstEnvSG 'put .. ', f3.fEins
call envPopWith
call tstEnvSG 'popW c4', f1
call envPopWith
call envPut f222, 'f222 pop stop'
call tstEnvSG 'popW c3', f1
call tstEnvSG , f222
call tstEnd t
/*
$=/tstEW4/
### start tst tstEW4 ##############################################
tstO4 S.0 0 R.0 0 class TstEW4
*** err: no field FZWEI in class in EnvPut(FZWEI, v 1.fZwei, 1)
1 fEins s FEINS = v 1.fEins
1 fZwei s FZWEI = .
2 fEins s FEINS = .
2 fZwei s FZWEI = v 2.fZwei
v 1.fEins .# 1 vor
v 1.fEins .# 2 nach withNext e
*** err: undefined variable FEINS in envGet(FEINS)
? fEins s FEINS = 0
1 fEins s FEINS = v 1|fEins
1 fZwei s FZWEI = .
2 fEins s FEINS = .
2 fZwei s FZWEI = v 2.fZwei
v 1|fEins .# 2
$/tstEW4/
*/
c4 = classNew('n? TstEW4 u f S s TstEW0, f R s r TstEW0')
o4 = mReset('tstO4', 'TstEW4')
call tst t, 'tstEW4'
call tstout t, o4 'S.0' m.o4.s.0 'R.0' m.o4.r.0 ,
'class' className(objClass(o4))
call envPushWith o4'.S', m.c4.f2c.s, 'asM'
call envPut fZwei, 'v 1.fZwei', 1
call envWithNext 'b'
call envPut feins, 'v 1.fEins', 1
call tstEnvSG '1 fEins ', fEins
call tstEnvSG '1 fZwei ', fZwei
m.o4.s.2.feins = 'vorher'
m.o4.s.2.fZwei = s2o('vorher')
call envWithNext
call envPut fZwei, 'v 2.fZwei', 1
call tstEnvSG '2 fEins ', fEins
call tstEnvSG '2 fZwei ', fZwei
call tstOut t, m.o4.s.1.fEins '.#' m.o4.s.0 'vor'
call envWithNext 'e'
call tstOut t, m.o4.s.1.fEins '.#' m.o4.s.0 'nach withNext e'
call envPopWith
call tstEnvSG '? fEins ', fEins
call envPushWith o4'.R', m.c4.f2c.r, 'asM'
call envWithNext 'b'
call envPut fEins, 'v 1|fEins', 1
call tstEnvSG '1 fEins ', fEins
call tstEnvSG '1 fZwei ', fZwei
call envWithNext
call envPut fZwei, 'v 2.fZwei', 1
call tstEnvSG '2 fEins ', fEins
call tstEnvSG '2 fZwei ', fZwei
call envWithNext 'e'
call envPopWith
o41r = m.o4.r.1
call tstOut t, m.o41r.fEins '.#' m.o4.r.0
call tstEnd t
return
endProcedure tstEnvWith
tstEnvSG: procedure expose m. t
parse arg txt, nm
call tstOut t, left(txt,10)'s' left(nm, 15)'=' envGet(nm)
return
tstPipeLazy: procedure expose m.
call pipeIni
/*
$=/tstPipeLazy/
### start tst tstPipeLazy #########################################
a1 vor pipeBegin loop lazy 0 writeNow *** <class TstPipeLazyBuf>
bufOpen <
bufClose
#jIn 2# tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
a5 vor 2 writeNow in inIx 4
a2 vor writeNow jBuf
jBuf line 1
jBuf line 2
a3 vor writeNow in inIx 1
tst in line 2 zwei ; .
tst in line 3 drei .schluss..
a4 vor barLast inIx 4
a6 vor barEnd inIx 4
a7 nach barEnd lazy 0 writeNow ***
b1 vor barBegin lazy 0 writeNow *** <class TstPipeLazyRdr>
RdrOpen <
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
rdrClose
b4 vor writeNow
b2 vor writeNow rdr inIx 2
jRead lazyRdr
tst in line 3 drei .schluss..
jRead lazyRdr
b3 vor barLast inIx 4
b5 vor barEnd inIx 4
b6 nach barEnd lazy 0 writeNow ***
a1 vor pipeBegin loop lazy 1 writeAll *** +
.<class TstPipeLazyBuf>
a5 vor 2 writeAll in inIx 0
a2 vor writeAll jBuf
bufOpen <
jBuf line 1
jBuf line 2
bufClose
a3 vor writeAll in inIx 0
#jIn 1# tst in line 1 eins ,
tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
tst in line 3 drei .schluss..
#jIn eof 4#
a4 vor barLast inIx 0
a6 vor barEnd inIx 4
a7 nach barEnd lazy 1 writeAll ***
b1 vor barBegin lazy 1 writeAll *** <class TstPipeLazyRdr>
b4 vor writeAll
b2 vor writeAll rdr inIx 1
RdrOpen <
jRead lazyRdr
#jIn 2# tst in line 2 zwei ; .
tst in line 2 zwei ; .
jRead lazyRdr
#jIn 3# tst in line 3 drei .schluss..
tst in line 3 drei .schluss..
jRead lazyRdr
#jIn eof 4#
rdrClose
b3 vor barLast inIx 1
b5 vor barEnd inIx 4
b6 nach barEnd lazy 1 writeAll ***
$/tstPipeLazy/ */
call tst t, "tstPipeLazy"
do lz=0 to 1
if lz then
w = 'writeAll'
else
w = 'writeNow'
m.t.inIx = 1-lz
ty = class4Name('TstPipeLazyBuf', '')
if ty == '' then
ty = classNew('n TstPipeLazyBuf u JBuf', 'm',
, 'jOpen call tstOut "T", "bufOpen" opt;',
'call jOpen oCast(m, "JBuf"), opt',
, 'jClose call tstOut "T", "bufClose";',
'call jClose oCast(m, "JBuf"), opt')
if \ lz then
call mAdd t'.TRANS', ty '<class TstPipeLazyBuf>'
call out 'a1 vor pipeBegin loop lazy' lz w '***' ty
call pipeBegin
call out 'a2 vor' w 'jBuf'
b = oMutate(jBuf('jBuf line 1','jBuf line 2'),
,'TstPipeLazyBuf')
interpret 'call pipe'w 'b'
call out 'a3 vor' w 'in inIx' m.t.inIx
interpret 'call pipe'w
call out 'a4 vor barLast inIx' m.t.inIx
call pipeLast
call out 'a5 vor 2' w 'in inIx' m.t.inIx
interpret 'call pipe'w
call out 'a6 vor barEnd inIx' m.t.inIx
call pipeEnd
call out 'a7 nach barEnd lazy' lz w '***'
ty = class4Name('TstPipeLazyRdr', '')
if ty == '' then
ty = classNew('n TstPipeLazyRdr u JRW', 'm',
, 'jOpen call tstOut "T", "RdrOpen" opt;m.m.jReading=1',
, 'jRead call out "jRead lazyRdr";' ,
'return jRead(m.m.rdr, var);',
, 'jClose call tstOut "T", "rdrClose";')
if \ lz then
call mAdd t'.TRANS', ty '<class TstPipeLazyRdr>'
r = oNew('TstPipeLazyRdr')
m.r.rdr = m.j.in
if lz then
call mAdd t'.TRANS', r '<lazyRdr>'
m.t.inIx = 2-lz
call out 'b1 vor barBegin lazy' lz w '***' ty
call pipeBegin
call out 'b2 vor' w 'rdr inIx' m.t.inIx
interpret 'call pipe'w 'r'
call out 'b3 vor barLast inIx' m.t.inIx
call pipeLast
call out 'b4 vor' w
interpret 'call pipe'w
call out 'b5 vor barEnd inIx' m.t.inIx
call pipeEnd
call out 'b6 nach barEnd lazy' lz w '***'
end
call tstEnd t
return
endProcedure tstPipeLazy
tstEnvClass: procedure expose m.
call pipeIni
/*
$=/tstEnvClass/
### start tst tstEnvClass #########################################
a0 vor pipeBegin loop lazy 0 writeNow *** TY
#jIn 2# tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
a5 vor writeNow
a1 vor jBuf()
a2 vor writeNow b
tstR: @<o20 of TstEnvClass10> isA :TstEnvClass10
tstR: .f11 = .
tstR: .F12 = value F12 of o1 <o20 of TstEnvClass10>
tstR: .f13 = .
WriteO o2
tstR: @<oc0 of TstEnvClass20> isA :TstEnvClass20 = valueO2Lazy0
tstR: .f24 = .
tstR: .F25 = value F25 of o20 <o20 of TstEnvClass20>
a3 vor writeNow
tst in line 2 zwei ; .
tst in line 3 drei .schluss..
a4 vor barLast inIx 4
a6 vor barEnd
a7 nach barEnd lazy 0 writeNow ***
a0 vor pipeBegin loop lazy 1 writeAll *** TY
a5 vor writeAll
a1 vor jBuf()
a2 vor writeAll b
tstR: @<o21 of TstEnvClass10> isA :TstEnvClass10
tstR: .f11 = .
tstR: .F12 = value F12 of o1 <o21 of TstEnvClass10>
tstR: .f13 = .
WriteO o2
tstR: @<oc1 of TstEnvClass20> isA :TstEnvClass20 = valueO2Lazy1
tstR: .f24 = .
tstR: .F25 = value F25 of o21 <o21 of TstEnvClass20>
a3 vor writeAll
#jIn 1# tst in line 1 eins ,
tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
tst in line 3 drei .schluss..
#jIn eof 4#
a4 vor barLast inIx 0
a6 vor barEnd
a7 nach barEnd lazy 1 writeAll ***
$/tstEnvClass/ */
call tst t, "tstEnvClass"
t10 = classNew('n? TstEnvClass10 u f f11 v, f F12 v, f f13 v')
t20 = classNew('n? TstEnvClass20 u v, f f24 v, f F25 v')
do lz=0 to 1
if lz then
w = 'writeAll'
else
w = 'writeNow'
m.t.inIx = 1-lz
call out 'a0 vor pipeBegin loop lazy' lz w '***' ty
call pipeBegin
call out 'a1 vor jBuf()'
b = jOpen(jBuf(), m.j.cWri)
o1 = oNew('TstEnvClass10')
m.o1.F12 = 'value F12 of o1' o1
call mAdd t'.TRANS', o1 '<o2'lz 'of TstEnvClass10>'
call jWriteO b, o1
call jWrite b, 'WriteO o2'
o2 = oNew('TstEnvClass20')
m.o2 = 'valueO2Lazy'lz
m.o2.F25 = 'value F25 of o2'lz o2
oc = oCopyNew(oCopyNew(o2))
call mAdd t'.TRANS', o2 '<o2'lz 'of TstEnvClass20>'
call mAdd t'.TRANS', oc '<oc'lz 'of TstEnvClass20>'
call jWriteO b, oc
call out 'a2 vor' w 'b'
interpret 'call pipe'w jClose(b)
call out 'a3 vor' w
interpret 'call pipe'w
call out 'a4 vor barLast inIx' m.t.inIx
call pipeLast
call out 'a5 vor' w
interpret 'call pipe'w
call out 'a6 vor barEnd'
call pipeEnd
call out 'a7 nach barEnd lazy' lz w '***'
end
call tstEnd t
m.t.trans.0 = 0
return
endProcedure tstEnvClass
tstFile: procedure expose m.
call catIni
/*
$=/tstFile/
### start tst tstFile #############################################
write read 0 last 10 vor anfang
write read 1 last 80 links1 1 und rechts | ..
write read 2 last 80 liinks2 2 und rechts | ..
write read 5 last 80 links5 5 rechts5
write read 99 last 80 links99 99 rechts
write read 100 last 80 links100 100 rechts
write read 101 last 80 links101 101 rechts
write read 999 last 80 links999 999 rechts
write read 1000 last 80 links1000 1000 rechts
write read 1001 last 80 links1001 1001 rechts
write read 2109 last 80 links2109 2109 rechts
out > eins 1 +
. .
out > eins 2 schluss. +
. .
buf eins
buf zwei
buf drei
out > zwei mit einer einzigen Zeile +
. .
. links1 1 und rechts | . +
. .
$/tstFile/ */
call tst t, "tstFile"
pds = tstFilename('lib', 'r')
call tstFileWr pds, 0, ' links0', ' und rechts | . '
call tstFileWr pds, 1, ' links1', ' und rechts | . '
call tstFileWr pds, 2, 'liinks2', ' und rechts | . '
call tstFileWr pds, 5, 'links5', 'rechts5'
call tstFileWr pds, 99, 'links99', 'rechts'
call tstFileWr pds, 100, 'links100', 'rechts'
call tstFileWr pds, 101, 'links101', 'rechts'
call tstFileWr pds, 999, 'links999', 'rechts'
call tstFileWr pds, 1000, 'links1000', 'rechts'
call tstFileWr pds, 1001, 'links1001', 'rechts'
call tstFileWr pds, 2109, 'links2109', 'rechts'
pd2 = tstFilename('li2', 'r')
call pipeIni
call pipeBeLa '>' s2o(tstPdsMbr(pd2, 'eins'))
call out tstFB('out > eins 1') /* simulate fixBlock on linux */
call out tstFB('out > eins 2 schluss.')
call pipeEnd
call pipeBeLa '>' s2o(tstPdsMbr(pd2, 'zwei'))
call out tstFB('out > zwei mit einer einzigen Zeile')
call pipeEnd
b = jBuf("buf eins", "buf zwei", "buf drei")
call pipeBeLa m.j.cRead s2o(tstPdsMbr(pd2, 'eins')), m.j.cRead b,
,m.j.cRead jBuf(),
,m.j.cRead s2o(tstPdsMbr(pd2, 'zwei')),
,m.j.cRead s2o(tstPdsMbr(pds, 'wr0')),
,m.j.cRead s2o(tstPdsMbr(pds, 'wr1'))
call pipeWriteNow
call pipeEnd
call tstEnd t
return
endProcedure tstFile
/*--- simulate fixBlock 80 on linux ---------------------------------*/
tstFB: procedure expose m.
parse arg line, recL
if errOS() \== 'LINUX' then
return line
else if recL == '' then
return left(line, 80)
else
return left(line, recL)
endProcedure tstFB
tstPdsMbr: procedure expose m.
parse arg pds, mbr
os = errOS()
if os = 'TSO' then
return pds'('mbr') ::F'
if os = 'LINUX' then
return pds'.'mbr
call err 'tstPdsMbr implement os' os
endProcedure tstPdsMbr
tstFileWR: procedure expose m.
parse arg dsn, num, le, ri
io = file(tstPdsMbr(dsn, 'wr'num))
call jOpen io, m.j.cWri
do x = 1 to num /* simulate fixBlock 80 on LINUX*/
call jWrite io, tstFB(le x ri)
end
call jClose io
if num > 100 then
call jReset io, tstPdsMbr(dsn, 'wr'num)
call jOpen io, m.j.cRead
m.vv = 'vor anfang'
do x = 1 to num
if \ jRead(io, vv) then
call err x 'not jRead'
else if m.vv <> le x ri then
call err x 'read mismatch' m.vv
end
if jRead(io, vv) then
call err x 'jRead but should be eof 1'
if jRead(io, vv) then
call err x'+1 jjRead but should be eof 2'
call jClose io
call tstOut t, 'write read' num 'last' length(m.vv) strip(m.vv,'t')
return
endProcedure tstFileRW
tstFileList: procedure expose m.
call catIni
/*
$=/tstFileList/
### start tst tstFileList #########################################
empty dir
filled dir
<<pref 2 List>>eins
<<pref 2 List>>zwei
<<pref 2 List>>drei
<<pref 2 List>>vier
filled dir recursive
<<pref 2 List>>eins
<<pref 2 List>>zwei
<<pref 2 List>>drei
<<pref 2 List>>vier
<<pref 1 vier>>eins
<<pref 1 vier>>zwei
<<pref 1 vier>>drei
$/tstFileList/ */
/*
$=/tstFileListTSO/
### start tst tstFileListTSO ######################################
empty dir
filled dir
<<pref 2 LIST>>DREI
<<pref 2 LIST>>EINS
<<pref 2 LIST>>ZWEI
filled dir recursive
<<pref 2 LIST>>DREI
<<pref 2 LIST>>EINS
<<pref 1 VIER>>DREI
<<pref 1 VIER>>EINS
<<pref 1 VIER>>ZWEI
<<pref 2 LIST>>ZWEI
$/tstFileListTSO/ */
if errOS() = 'TSO' then
call tst t, "tstFileListTSO"
else
call tst t, "tstFileList"
fi = file(tstFileName('FileList', 'r'))
call fileMkDir fi
fl = fileList(fi)
call tstOut t, 'empty dir'
call jWriteNow t, fl
call tstFileListMake t, fi, 2
call tstOut t, 'filled dir'
call jWriteNow t, fl
call tstOut t, 'filled dir recursive'
call jWriteNow t, fileList(fi, 'r')
call tstEnd t
return
endProcedure tstFileList
tstFileListMake: procedure expose m.
parse arg t, fi, lev
if \ fileIsDir(fi) then
call fileMkDir fi
call mAdd t'.TRANS', filePath(fi) || m.file.sep ,
'<<pref' lev right(filePath(fi),4)'>>'
call jCat fileChild(fi, 'eins','::F'),jBuf('zeile eins','eins' lev)
call jCat fileChild(fi, 'zwei','::F'),jBuf('zeile zwei','zwei' lev)
call jCat fileChild(fi, 'drei','::F'),jBuf('zeile drei','drei' lev)
if lev > 1 then
call tstFileListMake t, fileChild(fi, 'vier'), lev-1
return
endProcedure tstFileListMake
tstF: procedure expose m.
/*
$=/tstF/
### start tst tstF ################################################
f(1\s23%s345%s67\%8, eins, zwei ) =1 23eins345 zwei 67%8;
f(1\S23%s345%S67\%8, eins, zwei ) =1\S23eins345zwei67%8;
f(1\s23%s345%s67\%8, eins, zwei ) =1 23eins345 zwei 67%8;
f(1\s23%s345%S67\%8, eins, zwei ) =1 23eins345zwei67%8;
f(1%S2%s3@2%S4@%s5, eins, zwei ) =1eins2 zwei 3zwei4eins5;
f(1%-2C2%3C3@2%3.2C4, eins, zwei ) =1ei2 zw3zwe4;
f(1@F1%s2@f2%s3@F3%s4, eins, zwei ) =1fEins2fZwei3fDrei4;
$/tstF/ */
call tst t, 'tstF'
call tstF1 '1\s23%s345%s67\%8'
call tstF1 '1\S23%s345%S67\%8'
call tstF1 '1\s23%s345%s67\%8'
call tstF1 '1\s23%s345%S67\%8'
call tstF1 '1%S2%s3@2%S4@%s5'
call tstF1 '1%-2C2%3C3@2%3.2C4'
call tstF1 '1@F1%s2@f2%s3@F3%s4'
call tstEnd t
return
endProcedure tstF
tstF1: procedure expose m.
parse arg fmt
e='eins'
z=' zwei '
f2 = 'f2'
m.e.f1 = 'fEins'
m.e.f2 = 'fZwei'
m.e.f3 = 'fDrei'
call out "f("fmt"," e"," z") ="f(fmt, e, z)";"
return
endProcedure tstF1
tstFmt: procedure expose m.
call pipeIni
/*
$=/tstFmt/
### start tst tstFmt ##############################################
= a2i b3b d4 fl5 ex6
-11 -11 b3 d4-11+d4++++ -111.1000000 -1.11000E-12
-1 -10 b d4-10+d4+++ null1 null3
- -9 b3b-9 d4-9+d4+++ -11.0000000 -1.11900E-10
-8+ -8 b3b- d4-8+d4++ -18.0000000 -1.18000E010
-7 -7 b3b d4-7+d4+ -7.0000000 -1.70000E-07
- -6 b3 d4-6+d4 -0.1111160 -6.00000E006
-5+ -5 b d4-5+d null2 null2
-4 -4 b3b-4 d4-4+ -11114.0000000 -1.11140E008
- -3 b3b- d4-3 -0.1130000 -1.13000E-04
-2+ -2 b3b d4- -0.1200000 -1.20000E001
-1 -1 b3 d4 -0.1000000 -1.00000E-02
0 0 b d null1 null1
1+ 1 b3 d4 0.1000000 1.00000E-02
2++ 2 b3b d42 0.1200000 1.20000E001
3 3 b3b3 d43+ 0.1130000 1.13000E-04
4+ 4 b3b4+ d44+d 11114.0000000 1.11140E008
5++ 5 b d45+d4 null2 null2
6 6 b3 d46+d4+ 0.1111160 1.11116E005
7+ 7 b3b d47+d4++ 0.1111117 7.00000E-08
8++ 8 b3b8 d48+d4+++ 8.0000000 1.80000E009
9 9 b3b9+ d49+d4++++ 0.9000000 1.19000E-08
10 10 b d410+d4++++ null1 null3
11+ 11 b3 d411+d4+++++ 0.1110000 1.00000E-12
1 12 b3b d412+d4++++++ 11112.0000000 2.00000E012
13 13 b3b1 d 1111.3000000 1.13000E-12
14+ 14 b3b14 d4 111111.0000000 1.40000E013
1 15 b d41 null2 null1
16 16 b3 d416 6.0000000 1.16000E003
17+ 17 b3b d417+ 0.7000000 1.11170E-03
1 18 b3b1 d418+d 11.0000000 1.11800E003
19 19 b3b19 d419+d4 0.1190000 9.00000E-05
20+ 20 b d420+d4+ null1 null2
2 21 b3 d421+d4++ 11.1210000 1.11000E-05
22 22 b3b d422+d4+++ 11111.2000000 2.00000E007
23+ 23 b3b2 d423+d4++++ 0.1111123 1.11230E-09
c3L a2i drei d4 fl5 ex6
-11 -1.10E01 b3 d4-11+d -111.1000000 -1.11000E-12
-1 -1.00E01 b d4-10+d null1 null3
- -9.00E00 b3b-9 d4-9+d4 -11.0000000 -1.11900E-10
-8+ -8.00E00 b3b- d4-8+d4 -18.0000000 -1.18000E010
-7 -7.00E00 b3b d4-7+d4 -7.0000000 -1.70000E-07
- -6.00E00 b3 d4-6+d4 -0.1111160 -6.00000E006
-5+ -5.00E00 b d4-5+d null2 null2
-4 -4.00E00 b3b-4 d4-4+ -11114.0000000 -1.11140E008
- -3.00E00 b3b- d4-3 -0.1130000 -1.13000E-04
-2+ -2.00E00 b3b d4- -0.1200000 -1.20000E001
-1 -1.00E00 b3 d4 -0.1000000 -1.00000E-02
0 0.00E00 b d null1 null1
1+ 1.00E00 b3 d4 0.1000000 1.00000E-02
2++ 2.00E00 b3b d42 0.1200000 1.20000E001
3 3.00E00 b3b3 d43+ 0.1130000 1.13000E-04
4+ 4.00E00 b3b4+ d44+d 11114.0000000 1.11140E008
5++ 5.00E00 b d45+d4 null2 null2
6 6.00E00 b3 d46+d4+ 0.1111160 1.11116E005
7+ 7.00E00 b3b d47+d4+ 0.1111117 7.00000E-08
8++ 8.00E00 b3b8 d48+d4+ 8.0000000 1.80000E009
9 9.00E00 b3b9+ d49+d4+ 0.9000000 1.19000E-08
10 1.00E01 b d410+d4 null1 null3
11+ 1.10E01 b3 d411+d4 0.1110000 1.00000E-12
1 1.20E01 b3b d412+d4 11112.0000000 2.00000E012
13 1.30E01 b3b1 d 1111.3000000 1.13000E-12
14+ 1.40E01 b3b14 d4 111111.0000000 1.40000E013
1 1.50E01 b d41 null2 null1
16 1.60E01 b3 d416 6.0000000 1.16000E003
17+ 1.70E01 b3b d417+ 0.7000000 1.11170E-03
1 1.80E01 b3b1 d418+d 11.0000000 1.11800E003
19 1.90E01 b3b19 d419+d4 0.1190000 9.00000E-05
20+ 2.00E01 b d420+d4 null1 null2
2 2.10E01 b3 d421+d4 11.1210000 1.11000E-05
22 2.20E01 b3b d422+d4 11111.2000000 2.00000E007
23+ 2.30E01 b3b2 d423+d4 0.1111123 1.11230E-09
$/tstFmt/ */
call tst t, "tstFmt"
b = jBuf()
st = b'.BUF'
call pipeBeLa m.j.cWri b
call tstDataClassOut '. c3 a2i i b3b c5 d4 c13 fl5 f8n2 ex6 e9n3',
, -11, + 23
call pipeEnd
call fmtFTab abc, b
call fmtFAddFlds fmtFReset(abc), oFlds(m.st.1)
m.abc.1.tit = 'c3L'
m.abc.2.fmt = 'e'
m.abc.3.tit = 'drei'
m.abc.4.fmt = 'l7'
call fmtFWriteSt abc, b'.BUF'
call tstEnd t
return
endProcedure tstFmt
tstfmtUnits: procedure
/*
$=/tstFmtUnits/
### start tst tstFmtUnits #########################################
. .3 ==> 0s30 ++> 0s30 -+> -0s30 --> -0s30
. .8 ==> 0s80 ++> 0s80 -+> -0s80 --> -0s80
. 1 ==> 1s00 ++> 1s00 -+> -1s00 --> -1s00
. 1.2 ==> 1s20 ++> 1s20 -+> -1s20 --> -1s20
. 59 ==> 59s00 ++> 59s00 -+> -59s0 --> -59s00
. 59.07 ==> 59s07 ++> 59s07 -+> -59s0 --> -59s07
. 59.997 ==> 1m00 ++> 1m00 -+> -1m00 --> -1m00
. 60 ==> 1m00 ++> 1m00 -+> -1m00 --> -1m00
. 60.1 ==> 1m00 ++> 1m00 -+> -1m00 --> -1m00
. 611 ==> 10m11 ++> 10m11 -+> -10m1 --> -10m11
. 3599.4 ==> 59m59 ++> 59m59 -+> -59m5 --> -59m59
. 3599.5 ==> 1h00 ++> 1h00 -+> -1h00 --> -1h00
. 3661 ==> 1h01 ++> 1h01 -+> -1h01 --> -1h01
. 83400 ==> 23h10 ++> 23h10 -+> -23h1 --> -23h10
. 84700 ==> 23h32 ++> 23h32 -+> -23h3 --> -23h32
. 86400 ==> 1d00 ++> 1d00 -+> -1d00 --> -1d00
. 89900 ==> 1d01 ++> 1d01 -+> -1d01 --> -1d01
. 8467200 ==> 98d00 ++> 98d00 -+> -98d0 --> -98d00
. 8595936.00 ==> 99d12 ++> 99d12 -+> -99d1 --> -99d12
. 8638704.00 ==> 100d ++> 100d -+> -100d --> -100d
. 8640000 ==> 100d ++> 100d -+> -100d --> -100d
. 863913600 ==> 9999d ++> 9999d -+> ----d --> -9999d
. 863965440 ==> ++++d ++> 10000d -+> ----d --> -----d
. 8.6400E+9 ==> ++++d ++> +++++d -+> ----d --> -----d
. .3 ==> 0.300 ++> 0.300 -+> -0.300 --> -0.300
. .8 ==> 0.800 ++> 0.800 -+> -0.800 --> -0.800
. 1 ==> 1.000 ++> 1.000 -+> -1.000 --> -1.000
. 1.2 ==> 1.200 ++> 1.200 -+> -1.200 --> -1.200
. 59 ==> 59.000 ++> 59.000 -+> -59.000 --> -59.000
. 59.07 ==> 59.070 ++> 59.070 -+> -59.070 --> -59.070
. 59.997 ==> 59.997 ++> 59.997 -+> -59.997 --> -59.997
. 60 ==> 60.000 ++> 60.000 -+> -60.000 --> -60.000
. 60.1 ==> 60.100 ++> 60.100 -+> -60.100 --> -60.100
. 611 ==> 611.000 ++> 611.000 -+> -611.00 --> -611.000
. 3599.4 ==> 3k599 ++> 3k599 -+> -3k599 --> -3k599
. 3599.5 ==> 3k600 ++> 3k600 -+> -3k600 --> -3k600
. 3661 ==> 3k661 ++> 3k661 -+> -3k661 --> -3k661
. 83400 ==> 83k400 ++> 83k400 -+> -83k400 --> -83k400
. 999999.44 ==> 999k999 ++> 999k999 -+> -999k99 --> -999k999
. 999999.5 ==> 1M000 ++> 1M000 -+> -1M000 --> -1M000
. 567.6543E6 ==> 567M654 ++> 567M654 -+> -567M65 --> -567M654
. .9999991E9 ==> 999M999 ++> 999M999 -+> -999M99 --> -999M999
. .9999996E9 ==> 1G000 ++> 1G000 -+> -1G000 --> -1G000
. .9999991E12 ==> 999G999 ++> 999G999 -+> -999G99 --> -999G999
. .9999996E12 ==> 1T000 ++> 1T000 -+> -1T000 --> -1T000
. 567.6543E12 ==> 567T654 ++> 567T654 -+> -567T65 --> -567T654
. .9999991E15 ==> 999T999 ++> 999T999 -+> -999T99 --> -999T999
. .9999996E15 ==> 1P000 ++> 1P000 -+> -1P000 --> -1P000
. .9999991E18 ==> 999P999 ++> 999P999 -+> -999P99 --> -999P999
. .9999996E18 ==> 1E000 ++> 1E000 -+> -1E000 --> -1E000
. 567.6543E18 ==> 567E654 ++> 567E654 -+> -567E65 --> -567E654
. .9999991E21 ==> 999E999 ++> 999E999 -+> -999E99 --> -999E999
. .9999996E21 ==> 1000E ++> 1000E -+> -1000E --> -1000E
. .9999992E24 ==> 999999E ++> 999999E -+> ------E --> -999999E
. .9999995E24 ==> ++++++E ++> 1000000E -+> ------E --> -------E
. 10.6543E24 ==> ++++++E ++> +++++++E -+> ------E --> -------E
$/tstFmtUnits/ */
call jIni
call tst t, "tstFmtUnits"
d = 86400
lst = .3 .8 1 1.2 59 59.07 59.997 60 60.1 611 ,
3599.4 3599.5 3661 d-3000 d-1700 d d+3500 ,
d * 98 d * 99.49 d * 99.985 d*100 d * 9999 d * 9999.6 ,
d * 1e5
do wx=1 to words(lst)
call tstOut t, right(word(lst, wx), 14) ,
'==>' fmtTime( word(lst, wx) ) ,
'++>' fmtTime( word(lst, wx), 1),
'-+>' fmtTime('-'word(lst, wx), ),
'-->' fmtTime('-'word(lst, wx), 1)
end
lst = subword(lst, 1, 14) 999999.44 999999.5,
567.6543e6 .9999991e9 .9999996e9 .9999991e12 .9999996e12 ,
567.6543e12 .9999991e15 .9999996e15 .9999991e18 .9999996e18 ,
567.6543e18 .9999991e21 .9999996e21 .9999992e24 .9999995e24 ,
10.6543e24
do wx=1 to words(lst)
call tstOut t, right(word(lst, wx), 14) ,
'==>' fmtDec( word(lst, wx) ) ,
'++>' fmtDec( word(lst, wx), 1),
'-+>' fmtDec('-'word(lst, wx), ),
'-->' fmtDec('-'word(lst, wx), 1)
end
call tstEnd t
return
endProcedure tstfmtUnits
tstScan: procedure expose m.
/*
$=/tstScan.1/
### start tst tstScan.1 ###########################################
scan src a034,Und hr123sdfER"st1" 'str2''mit''apo''s' .
scan n tok 4: a034 key val .
scan , tok 1: , key val .
scan n tok 3: Und key val .
scan v tok 1: key val .
scan n tok 10: hr123sdfER key val .
scan q tok 5: "st1" key val st1
scan v tok 1: key val st1
scan a tok 19: 'str2''mit''apo''s' key val str2'mit'apo's
scan v tok 1: key val str2'mit'apo's
$/tstScan.1/ */
call tst t, 'tstScan.1'
call tstScan1 ,'l"litEins"l"litZwei"ndv" "aq1' ,
,"a034,Und hr123sdfER""st1"" 'str2''mit''apo''s' "
call tstEnd t
/*
$=/tstScan.2/
### start tst tstScan.2 ###########################################
scan src a034,Und hr123sdfER"st1" 'str2''mit''apo''s' .
scan n tok 4: a034 key val .
scan , tok 1: , key val .
scan n tok 3: Und key val .
scan b tok 0: key val .
scan n tok 10: hr123sdfER key val .
scan " tok 5: "st1" key val st1
scan b tok 0: key val st1
scan ' tok 19: 'str2''mit''apo''s' key val str2'mit'apo's
scan b tok 0: key val str2'mit'apo's
$/tstScan.2/ */
call tst t, 'tstScan.2'
call tstScan1 , 'ndsb1' ,
,"a034,Und hr123sdfER""st1"" 'str2''mit''apo''s' "
call tstEnd t
/*
$=/tstScan.3/
### start tst tstScan.3 ###########################################
scan src a034,'wie 789abc
scan n tok 4: a034 key val .
scan , tok 1: , key val .
*** err: scanErr ending Apostroph(') missing
. e 1: last token scanPosition 'wie 789abc
. e 2: pos 6 in string a034,'wie 789abc
scan ' tok 1: ' key val .
scan n tok 3: wie key val .
scan s tok 0: key val .
*** err: scanErr illegal number end after 789
. e 1: last token 789 scanPosition abc
. e 2: pos 14 in string a034,'wie 789abc
scan d tok 3: 789 key val .
scan n tok 3: abc key val .
$/tstScan.3/ */
call tst t, 'tstScan.3'
call tstScan1 , 'nds1' ,
,"a034,'wie 789abc"
call tstEnd t
/*
$=/tstScan.4/
### start tst tstScan.4 ###########################################
scan src litEinsefr 23 sdfER'str1'litZwei "str2""mit quo"s .
scan l tok 7: litEins key val .
scan n tok 3: efr key val .
scan b tok 0: key val .
scan d tok 2: 23 key val .
scan b tok 0: key val .
scan n tok 5: sdfER key val .
scan a tok 6: 'str1' key val str1
scan l tok 7: litZwei key val str1
scan b tok 0: key val str1
scan q tok 15: "str2""mit quo" key val str2"mit quo
scan n tok 1: s key val str2"mit quo
scan b tok 0: key val str2"mit quo
$/tstScan.4/ */
call tst t, 'tstScan.4'
call tstScan1 , 'l"litEins"l"litZwei"ndbaq1' ,
,"litEinsefr 23 sdfER'str1'litZwei ""str2""""mit quo""s "
call tstEnd t
/*
$=/tstScan.5/
### start tst tstScan.5 ###########################################
scan src aha;+-=f ab=cdEf eF='strIng' .
scan b tok 0: key val .
scan k tok 4: no= key aha val def
scan ; tok 1: ; key aha val def
scan + tok 1: + key aha val def
scan - tok 1: - key aha val def
scan = tok 1: = key aha val def
scan k tok 4: no= key f val def
scan k tok 4: cdEf key ab val cdEf
scan b tok 4: cdEf key ab val cdEf
scan k tok 8: 'strIng' key eF val strIng
scan b tok 8: 'strIng' key eF val strIng
$/tstScan.5/ */
call tst t, 'tstScan.5'
call tstScan1 , 'bk1'," aha;+-=f ab=cdEf eF='strIng' "
call tstEnd t
return
endProcedure tstScan
tstScanRead: procedure expose m.
/*
$=/tstScanRead/
### start tst tstScanRead #########################################
name erste
space
name Zeile
space
nextLine
nextLine
space
name dritte
space
name Zeile
space
name schluss
space
$/tstScanRead/ */
call scanReadIni
call tst t, 'tstScanRead'
b = jBuf('erste Zeile ',,' dritte Zeile schluss ')
s = jOpen(scanRead(b), m.j.cRead)
do while \scanAtEnd(s)
if scanName(s) then call tstOut t, 'name' m.s.tok
else if scanVerify(s, ' ') then call tstOut t, 'space'
else if scanReadNL(s) then call tstOut t, 'nextLine'
else if \scanAtEnd(s) then call scanErr s, 'cannot scan'
end
call jClose s
call tstEnd t
/*
$=/tstScanReadMitSpaceLn/
### start tst tstScanReadMitSpaceLn ###############################
name erste
spaceLn
name Zeile
spaceLn
name dritte
spaceLn
name Zeile
spaceLn
name schluss
spaceLn
$/tstScanReadMitSpaceLn/ */
call tst t, 'tstScanReadMitSpaceLn'
s = jOpen(scanRead(b), '>')
do forever
if scanName(s) then call out 'name' m.s.tok
else if scanSpaceNL(s) then call out 'spaceLn'
else if \scanAtEnd(s) then call scanErr s, 'cannot scan'
else leave
end
call jClose s
call tstEnd t
/*
$=/tstScanJRead/
### start tst tstScanJRead ########################################
1 jRead n tok erste val .
2 jRead s tok val .
3 jRead n tok Zeile val .
4 jRead s tok val .
5 jRead n tok dritte val .
6 jRead s tok val .
7 jRead n tok Zeile val .
8 jRead s tok val .
9 jRead n tok schluss val .
10 jRead s tok val .
11 jRead 0 tok 1 val 1
12 jRead s tok val 1
13 jRead + tok + val 1
14 jRead s tok val 1
15 jRead 0 tok 2. val 2..
16 jRead s tok val 2..
17 jRead + tok + val 2..
18 jRead . tok . val 2..
19 jRead s tok val 2..
20 jRead 0 tok +.3 val +.3
21 jRead 0 tok -45e-3 val -45E-3
22 jRead s tok val -45E-3
23 jRead " tok "a""b" val a"b
24 jRead s tok val a"b
25 jRead ' tok 'c''d' val c'd
className 1: Scan 18: Scan
$/tstScanJRead/ */
call tst t, 'tstScanJRead'
call jWrite jOpen(b,'>>'), '1 + 2. +. +.3-45e-3 "a""b"' "'c''d'"
s = jOpen(scanRead(jClose(b)), '>')
do x=1 while jRead(s, v.x)
call out x 'jRead' m.v.x.type 'tok' m.v.x.tok 'val' m.v.x.val
end
call jClose s
call out 'className 1:' className(objClass(v.1)),
'18:' className(objClass(v.18))
call tstEnd t
return
endProcedure tstScanRead
tstScanUtilInto: procedure expose m.
/*
$=/tstScanUtilIntoL/
TEMPLATE P3
DSN('DBAF.DA540769.A802A.P00003.BV5I3NRN.REC')
DISP(OLD,KEEP,KEEP)
TEMPLATE P4
DSN('DBAF.DA540769.A802A.P00004.BV5I3NTK.REC')
DISP(OLD,KEEP,KEEP)
LOAD DATA LOG NO RESUME NO REPLACE COPYDDN(TCOPYD)
STATISTICS INDEX(ALL) REPORT NO UPDATE ALL
EBCDIC CCSID(00500,00000,00000)
SORTKEYS
-- ENFORCE NO
SORTDEVT DISK
SORTNUM 160
WORKDDN(TSYUTD,TSOUTD)
INTO TABLE OA1P.TWB981 PART 1 INDDN TREC134
WORKDDN(TSYUTS,TSOUTS)
INTO TABLE "A540769"
."TWK802A1"
PART 00001 INDDN P0
WHEN(00001:00002) = X'0041'
( "DE1"
POSITION( 00003:00010) DECIMAL
, "CH2"
POSITION( 00011:00015) CHAR(00005)
, "TS3"
POSITION( 00016:00041) TIMESTAMP EXTERNAL
, "TI4"
POSITION( 00042:00049) TIME EXTERNAL
, "DA5"
POSITION( 00050:00059) DATE EXTERNAL
, "IN6"
POSITION( 00060:00063) INTEGER
, "RE7"
POSITION( 00064:00067) FLOAT(21)
)
INTO TABLE "A540769"."TWK802A1"
PART 00002 INDDN P0
WHEN(00001:00002) = X'0041'
( "DE1"
POSITION( 00003:00010) DECIMAL
, "CH2"
POSITION( 00011:00015) CHAR(00005)
)
dobido
$/tstScanUtilIntoL/
$=/tstScanUtilInto/
### start tst tstScanUtilInto #####################################
-- 1 scanUtilInto
. ( "DE1"
. POSITION( 00003:00010) DECIMAL
. , "CH2"
. POSITION( 00011:00015) CHAR(00005)
. , "TS3"
. POSITION( 00016:00041) TIMESTAMP EXTERNAL
. , "TI4"
. POSITION( 00042:00049) TIME EXTERNAL
. , "DA5"
. POSITION( 00050:00059) DATE EXTERNAL
. , "IN6"
. POSITION( 00060:00063) INTEGER
. , "RE7"
. POSITION( 00064:00067) FLOAT(21)
. ) .
. -- table OA1P.TWB981 part 00001
-- 2 scanUtilInto
. ( "DE1"
. POSITION( 00003:00010) DECIMAL
. , "CH2"
. POSITION( 00011:00015) CHAR(00005)
. ) .
. -- table A540769.TWK802A1 part 00002
-- 3 scanUtilInto
$/tstScanUtilInto/ */
call scanReadIni
b = jBuf()
call mAddst b'.BUF', mapInline('tstScanUtilIntoL')
call tst t, 'tstScanUtilInto'
s = jOpen(scanUtilReset(ScanRead(b)), '<')
do ix=1
call out '--' ix 'scanUtilInto'
if \ scanUtilInto(s) then
leave
call out ' -- table' m.s.tb 'part' m.s.part
end
call tstEnd t
return
endProcedure tstSCanUtilInto
tstScanWin: procedure expose m.
/*
$=/tstScanWin/
### start tst tstScanWin ##########################################
info 0: last token scanPosition erste Zeile dr+
itteZe\npos 1 in line 1: erste Zeile
name erste
spaceNL
name Zeile
spaceNL
name dritteZeeeile
info 5: last token dritteZeeeile scanPosition zeile4 +
. fuenfueberSechs\npos 1 in line 4: zeile4
spaceNL
name zeile4
spaceNL
name fuenfueberSechsUnddSiebenUNDundUndUAcht
spaceNL
info 10: last token scanPosition undZehnueberElfundNochWeiterZwoel+
fundim1\npos 9 in line 10: undZehn
name undZehnueberElfundNochWeiterZwoelfundim13
spaceNL
name Punkt
infoE 14: last token Punkt scanPosition \natEnd after line 13: im13+
. Punkt
$/tstScanWin/ */
call scanWinIni
call tst t, 'tstScanWin'
b = jBuf('?erste Zeile?',,'? dritteZeeeile?', '? zeile4 ',
,'? fuenf?', '?ueberSechsUnddS?', '?iebenUNDundUndU?',
,'?Acht ?', '? ?', '? undZehn?',
,'?ueberElfundNoch?', '?WeiterZwoelfund?', '?im13 Punkt?')
s = jOpen(scanWin(b, , , 2, 15), m.j.cRead)
call tstOut t, 'info 0:' scanInfo(s)
do sx=1 while \scanAtEnd(s)
if scanName(s) then call tstOut t, 'name' m.s.tok
else if scanSpaceNL(s) then call tstOut t, 'spaceNL'
else if \scanAtEnd(s) then call scanErr s, 'cannot scan'
if sx // 5 = 0 then
call tstOut t, 'info' sx':' scanInfo(s)
end
call tstOut t, 'infoE' sx':' scanInfo(s)
call tstEnd t
/*
$=/tstScanWinRead/
### start tst tstScanWinRead ######################################
info 0: last token scanPosition erste Zeile z3 +
com Ze\npos 1 in line 1: erste Zeile
name erste
spaceNL
name Zeile
spaceNL
name z3
info 5: last token z3 scanPosition com Zeeeile z4 come4 f+
uenf\npos 4 in line 3: z3 com Zeeeile
spaceNL
name z4
spaceNL
name fuenf
spaceNL
info 10: last token scanPosition com Sechs com sieben comAc+
ht com\npos 15 in line 5: fuenf c
name com
spaceNL
$/tstScanWinRead/ */
call tst t, 'tstScanWinRead'
call mAdd t.cmp,
, "name Sechs",
, "spaceNL",
, "name com",
, "info 15: last token com scanPosition sieben comAcht c",
|| "om com com\npos 2 in line 7: m sieben com" ,
, "spaceNL",
, "name sieben",
, "spaceNL",
, "name Acht",
, "spaceNL",
, "info 20: last token scanPosition ueberElfundNochWeit com ",
|| "elfundim13\npos 1 in line 11: ueberElfundNoch",
, "name ueberElfundNochWeit",
, "spaceNL",
, "name im13",
, "spaceNL",
, "name Punkt",
, "info 25: last token Punkt scanPosition \natEnd after line ",
|| "13: im13 Punkt",
, "infoE 26: last token Punkt scanPosition \natEnd after line",
|| " 13: im13 Punkt"
b = jBuf('?erste Zeile?',,'? z3 com Zeeeile?', '? z4 come4 ',
,'? fuenf c?', '?om Sechs co?', '?m sieben com?',
,'?Acht com com ?', '? com ?', '? com undZehn?',
,'?ueberElfundNoch?', '?Weit com elfund?', '?im13 Punkt?')
s = scanWin(b, , , 2, 15)
call scanOpts s, , , 'com'
call tstOut t, 'info 0:' scanInfo(jOpen(s, m.j.cRead))
do sx=1 while \scanAtEnd(s)
if scanName(s) then call tstOut t, 'name' m.s.tok
else if scanSpaceNL(s) then call tstOut t, 'spaceNL'
else if \scanAtEnd(s) then call scanErr s, 'cannot scan'
if sx // 5 = 0 then
call tstOut t, 'info' sx':' scanInfo(s)
end
call tstOut t, 'infoE' sx':' scanInfo(s)
call tstEnd t
return
endProcedure tstScanWin
tstScanSqlStmt: procedure expose m.
/*
$=/tstScanSqlStmt/
### start tst tstScanSqlStmt ######################################
--info 0: last token scanPosition select -- $ä c1 /+
* c1 $ö\npos 1 in line 1: select -- $ä c1
cmd1 select current time stamp from s.1
cmd2 .
cmd3 .
--info 3: last token ; scanPosition update ";--""'$ä";; delet+
e '$ä''"'\npos 2 in line 7: ;update ";--""'$ä";; del
cmd4 update ";--""'$ä"
cmd5 .
cmd6 delete '$ä''"' .
--info end: last token scanPosition \natEnd after line 9: $äc8 $ö
$/tstScanSqlStmt/ */
call scanWinIni
call tst t, 'tstScanSqlStmt'
b = jBuf('select -- /* c1', ' /* c1 */ current /* c2 " '' ',
,'c3', ' c4 */ time', 'stamp-- c5', 'from s.1; /* c6 */ ;' ,
,';update ";--""''/*";; del123',
, 'ete ''/*''''"'' -- c7', '/*c8 */ ')
s = jOpen(scanOpts(scanWin(b, , , 1, 30), , , '--'), m.j.cRead)
call tstOut t, '--info 0:' scanInfo(s)
do sx=1 while scanSqlStmt(s)
call tstOut t, 'cmd'sx m.s.val
if sx=3 then call tstOut t, '--info 3:' scanInfo(s)
end
call tstOut t, '--info end:' scanInfo(s)
call tstEnd t
return
endProcedure tstScanSqlStmt
tstScanSql: procedure expose m.
call scanWinIni
/*
$=/tstScanSqlId/
### start tst tstScanSqlId ########################################
sqlId ABC
spaceNL
sqlId AB__345EF
spaceNL
$/tstScanSqlId/ */
call tst t, 'tstScanSqlId'
b = jBuf('abc -- kommentar', right('ab_', 72), '_345ef-- kom')
s = jOpen(scanSql(b), m.j.cRead)
do sx=1 while \scanAtEnd(s)
if scanSqlID(s) then call tstOut t, 'sqlId' m.s.val
else if scanSpaceNL(s) then call tstOut t, 'spaceNL'
else call scanErr s, 'cannot scan'
end
call tstEnd t
/*
$=/tstScanSqlDelimited/
### start tst tstScanSqlDelimited #################################
sqlDeId ABC
spaceNL
sqlDeId AB_3F
spaceNL
sqlDeId abc
spaceNL
sqlDeId ab_Ef
spaceNL
$/tstScanSqlDelimited/ */
call tst t, 'tstScanSqlDelimited'
b = jBuf('abc -- kommentar',,' -- ',,right('ab_', 72),'3F-- kom',
, '"abc" -- ko', ' -- ',,right('"ab_', 72),'Ef"-- kom')
s = jOpen(scanSql(b), m.j.cRead)
do sx=1 while \scanAtEnd(s)
if scanSqlDeID(s) then call tstOut t, 'sqlDeId' m.s.val
else if scanSpaceNL(s) then call tstOut t, 'spaceNL'
else call scanErr s, 'cannot scan'
end
call tstEnd t
/*
$=/tstScanSqlQualified/
### start tst tstScanSqlQualified #################################
sqlQuId ABC 1 ABC
sqlQuId AB_3F 1 AB_3F
sqlQuId abc 1 abc
sqlQuId ab_Ef 1 ab_Ef
sqlQuId EINS.Zwei.DREI 3 EINS
sqlQuId vi er.fu enf 2 vi er
$/tstScanSqlQualified/ */
call tst t, 'tstScanSqlQualified'
b = jBuf('abc -- kommentar',,' -- ',,right('ab_', 72),'3F-- kom',
, '"abc" -- ko', ' -- ',right('"ab_', 72),'Ef"-- kom',
, 'eins."Zwei', '" -- com', ' . -- com', ' -- com',
, 'drei -- ko', '"vi er"."fu enf " -- co')
s = jOpen(scanSql(b), m.j.cRead)
do sx=1 while \scanAtEnd(s)
if scanSqlQuID(s) then
call tstOut t, 'sqlQuId' m.s.val m.s.val.0 m.s.val.1
else if scanSpaceNL(s) then call tstOut t, 'spaceNL'
else call scanErr s, 'cannot scan'
end
call tstEnd t
/*
$=/tstScanSqlNum/
### start tst tstScanSqlNum #######################################
sqlNum 1
spaceNL
sqlNum 2..
spaceNL
sqlNum .3
spaceNL
sqlNum 4.5
spaceNL
sqlNum +6
spaceNL
sqlNum +7.03
spaceNL
sqlNum -8
spaceNL
sqlNum -.9
spaceNL
sqlNum 1E2
spaceNL
sqlNum -2.E-2
spaceNL
sqlNum +.3E+3
spaceNL
$/tstScanSqlNum/ */
call tst t, 'tstScanSqlNum'
b = jBuf('1 2. .3 4.5 +6 + --kom', , ' -- com ', , ' 7.03 -8 - .9',
'1e2 - 2.e-2 + .3e+3')
s = jOpen(scanSql(b), m.j.cRead)
do sx=1 while \scanAtEnd(s)
if scanSqlNum(s) then
call tstOut t, 'sqlNum' m.s.val
else if scanSpaceNL(s) then call tstOut t, 'spaceNL'
else call scanErr s, 'cannot scan'
end
call tstEnd t
/*
$=/tstScanSqlNumUnit/
### start tst tstScanSqlNumUnit ###################################
sqlNumUnit 1 KB
spaceNL
sqlNumUnit .3 MB
sqlNumUnit .5
sqlNumUnit +6.E-5 B
spaceNL
sqlNumUnit -7
char *
spaceNL
sqlNumUnit -.8
char T
char B
spaceNL
*** err: scanErr scanSqlNumUnit after +9. bad unit TB
. e 1: last token Tb scanPosition .
. e 2: pos 41 in line 1: 1 kb .3mB.5 + 6.e-5B -7* -.8 TB + 9.T+
b
sqlNumUnit +9..
spaceNL
$/tstScanSqlNumUnit/ */
call tst t, 'tstScanSqlNumUnit'
b = jBuf('1 kb .3mB.5 + 6.e-5B -7* -.8 TB + 9.Tb')
s = jOpen(scanSql(b), m.j.cRead)
do sx=1 while \scanAtEnd(s)
if scanSqlNumUnit(s, 0, 'B KB MB') then
call tstOut t, 'sqlNumUnit' m.s.val
else if scanSpaceNL(s) then call tstOut t, 'spaceNL'
else if scanChar(s ,1) then call tstOut t, 'char' m.s.tok
else call scanErr s, 'cannot scan'
end
call tstEnd t
return
endProcedure tstScanSql
/*--- one single test scan with lines to scan in stem ln -------------*/
tstScan1:
parse arg sc, classs, ln
if sc == '' then do
call tstOut t, 'scan src' ln
call scanSrc scanReset(s), ln
end
else do
call tstOut t, 'scan scanner' sc
s = sc
end
do forever
x = tstScanType(s, classs)
if x == '' then
leave
call tstOut t, 'scan' x 'tok' length(m.s.tok)':' m.s.tok ,
'key' m.s.key 'val' m.s.val
end
return
endProcedure tstScan1
tstScanType: procedure expose m.
parse arg s, opt
cx = 1
a2 = ''
res = 0
do while cx <= length(opt)
f = substr(opt, cx, 1)
cx = cx + 1
if pos(substr(opt, cx, 1), "'""") > 0 then do
m.tstScanType.src = opt
m.tstScanType.pos = cx
call scanString tstScanType
a2 = m.tstScanType.val
cx = m.tstScanType.pos
end
if f == 'a' then
res = scanString(s, "'")
else if f == 'b' then
res = scanSpaceNl(s)
else if f == 'c' then
res = scanChar(s, a2)
else if f == 'd' then
res = scanNat(s, a2)
else if f == 'k' then
res = scanKeyValue(s, 'def')
else if f == 'l' then
res = scanLit(s, a2)
else if f == 'q' then
res = scanString(s, '"')
else if f == 'v' then
res = scanVerify(s, a2)
else if f == 'w' then
res = scanWord(s)
else if f == 'y' then
res = scanVerify(s, a2, 'm')
if res then
return f
end
return scanType(s)
endProcedure tstScanType
/* copx tstBase end *************************************************/
/* copx tst begin ****************************************************
test infrastructure
***********************************************************************/
/*--- migrate all compares to new ones:
tstCI input compare
tstCO ouput migrated compares
tstCIO input and output -------------------------------------*/
tstCI: procedure expose m.
parse arg m, nm
m.m.CIO = 0
signal tstCIwork
tstCIO: procedure expose m.
parse arg m, nm
m.m.CIO = 1
tstCIwork:
m.m.name = nm
m.m.cmp.1 = left('### start tst' nm '', 67, '#')
do ix=2 to arg()-1
m.m.cmp.ix = arg(ix+1)
end
m.m.cmp.0 = ix-1
if m.m.CIO then
call tstCO m
return
tstCO: procedure expose m.
parse arg m
call tst2dpSay m.m.name, m'.CMP', 68
return
/*--- initialise m as tester with name nm
use inline input nm as compare lines -----------------------*/
tstReset: procedure expose m.
parse arg m, nm
call tstIni
m.m.name = nm
m.m.inIx = 0
m.m.out.0 = 0
m.m.err = 0
m.m.errHand = 0
m.tst.act = m
if \ datatype(m.m.trans.0, 'n') then
m.m.trans.0 = 0
m.m.trans.old = m.m.trans.0
return
endProcedure tstReset
tst: procedure expose m.
parse arg m, nm, cmpSt
call tstReset m, nm
m.tst.tests = m.tst.tests+1
if cmpSt == '' then do
cmpSt = mCut(t'.CMP', 0)
call tst4dp cmpSt, mapInline(nm)
end
m.m.cmp = cmpSt
m.m.moreOutOk = 0
call mAdd mCut(m'.IN', 0), 'tst in line 1 eins ,' ,
, 'tst in line 2 zwei ; ' ,
, 'tst in line 3 drei .schluss.'
call tstOut m, left('### start tst' nm '', 67, '#')
call errReset 'h', 'return tstErrHandler(ggTxt)'
m.m.errCleanup = m.err.cleanup
if m.tst.ini.j \== 1 then do
call err implement outDest 'i', 'call tstOut' quote(m)', msg'
end
else do
call oMutate m, 'Tst'
m.m.jReading = 1
m.m.jWriting = 1
m.m.jUsers = 0
if m.tst.ini.e \== 1 then do
m.m.oldJin = m.j.in
m.m.oldOut = m.j.out
m.j.in = m
m.j.out = m
end
else do
if m.pipe.0 <> 1 then
call tstErr m, 'm.pipe.0' m.pipe.0 '<> 1'
call pipeBeLa m.j.cRead m, '>' m
end
end
return m
endProcedure tst
tstEnd: procedure expose m.
parse arg m, opt opt2
cmp = m.m.cmp
m.m.jReading = 0
m.m.jWriting = 0
if m.tst.ini.j == 1 then do
m.m.jReading = 0
m.m.jWriting = 0
if m.tst.ini.e \== 1 then do
m.j.in = m.m.oldJin
m.j.out = m.m.oldOut
end
else do
if m.j.in \== m | m.j.out \== m then
call tstErr m, m.j.in '\==' m '|' m.j.out '\==' m
call pipeEnd
if m.pipe.0 <> 1 then
call tstErr m, 'm.pipe.0' m.pipe.0 '<> 1'
end
end
if m.m.err = 0 then
if m.m.errCleanup \= m.err.cleanup then
call tstErr m, 'err.Cleanup' m.err.cleanup '<> old',
m.m.errCleanup
if m.m.out.0 \= m.cmp.0 & \ (m.m.moreOutOk,
& m.m.out.0 > m.cmp.0) then do
call tstErr m, 'old' m.cmp.0 'lines \= new' m.m.out.0
do nx = m.m.out.0 + 1 to min(m.m.out.0+10, m.cmp.0)
say 'old - ' m.cmp.nx
end
end
call errReset 'h'
m.tst.act = ''
soll = 0
if opt = 'err' then do
soll = opt2
if m.m.err \= soll then
call err soll 'errors expected, but got' m.m.err
end
if m.m.err \= soll then do
say 'new lines:' (m.m.out.0 - 1)
call tst2dpSay m.m.name, m'.OUT', 68
end
say left('###' m.m.name 'end with' m.m.err 'errors ', 67, '#')
if 1 & m.m.err \= soll then
call err 'dying because of' m.m.err 'errors'
m.m.trans.0 = m.m.trans.old
return
endProcedure tstEnd
tst2dp: procedure expose m.
parse arg st, dp, ml
dx = m.dp.0
do sx=1 to m.st.0
li = m.st.sx
cx = 1
do until cx > length(li)
c = substr(li, cx, 1)
ou = left('.', strip(c) == '' | pos(c, '.+') > 0)
ex = min(length(li),cx+ml-length(ou)-2)
ou = ou || substr(li, cx, ex+1-cx)
dx = dx + 1
c = right(ou, 1)
if ex < length(li) then
m.dp.dx = ou || '+'
else if strip(c) == '' | pos(c, '.+') > 0 then
m.dp.dx = ou || '.'
else
m.dp.dx = ou
cx = ex +1
end
end
m.dp.0 = dx
return
endProcedure tst2dp
tst2dpSay: procedure expose m.
parse arg name, st, ml
say '$=/'name'/'
call tst2dp st, mCut('TST.TMP', 0), 68
do nx=1 to m.tst.tmp.0
say ' ' m.tst.tmp.nx
end
say '$/'name'/'
return tst2dpSay
tst4dp: procedure expose m.
parse arg st, dp
sx = m.st.0
inData = 0
data = ''
do dx=1 to m.dp.0
li = strip(m.dp.dx)
if pos(left(li, 1), '.+') > 0 then
li = substr(li, 2)
if right(li, 1) == '+' then do
inData = 1
data = data || left(li, length(li)-1)
iterate
end
if right(li, 1) == '.' then
li = left(li, length(li)-1)
sx = sx + 1
m.st.sx = repAll(repAll(data || li, '$ä', '/*'), '$ö', '*/')
inData = 0
data = ''
end
m.st.0 = sx
if inData then
call err 'end inData'
return
endProcedure tst4dp
/*--- write to test: say lines and compare them ----------------------*/
tstWrite: procedure expose m.
parse arg m, arg
call tstOut m, 'out:' arg
return
endProcedure tstWrite
tstOut: procedure expose m.
parse arg m, arg
do tx=m.m.trans.0 by -1 to 1
arg = repAll(arg, word(m.m.trans.tx, 1),
, subword(m.m.trans.tx, 2))
end
call mAdd m'.OUT', arg
nx = m.m.out.0
cmp = m.m.cmp
c = m.cmp.nx
if nx > m.cmp.0 then do
if nx = m.cmp.0+1 & \ m.m.moreOutOK then
call tstErr m, 'more new Lines' nx
end
else if c \== arg then do
do cx=1 to min(length(c), length(arg)) ,
while substr(c, cx, 1) == substr(arg, cx, 1)
end
msg = 'old line' nx '<> new overnext, firstDiff' cx',',
'len old' length(c)', new' length(arg)
if cx > 10 then
msg = overlay('|', msg, cx-10)
call tstErr m, msg
say c
end
say arg
return 0
endProcedure tstOut
tstWriteO: procedure expose m.
parse arg m, var
if abbrev(var, m.class.escW) then do
call tstOut t, o2String(var)
end
else if m.class.o2c.var == m.class.classV then do
call tstOut t, m.var
end
else if oKindOf(var, 'JRW') then do
call tstOut t, 'tstWriteO kindOf JRW jWriteNow begin <<<'
call jWriteNow m, var
call tstOut t, 'tstWriteO kindOf JRW jWriteNow end >>>'
end
else if oKindOf(var, 'ORun') then do
call tstOut t, 'tstWriteO kindOf ORun oRun begin <<<'
call oRun var
call tstOut t, 'tstWriteO kindOf ORun oRun end >>>'
end
else do
do tx=m.m.trans.0 by -1 to 1 ,
while word(m.m.trans.tx, 1) \== var
end
if tx < 1 then
call mAdd M'.TRANS', var 'tstWriteoV' || (m.m.trans.0+1)
call classOut , var, 'tstR: '
end
return
endProcedure tstWriteO
tstReadO: procedure expose m.
parse arg m, arg
ix = m.m.inIx + 1
m.m.inIx = ix
if ix <= m.m.in.0 then do
call tstOut m, '#jIn' ix'#' m.m.in.ix
return s2o(m.m.in.ix)
end
call tstOut m, '#jIn eof' ix'#'
return ''
endProcedure tstReadO
tstFilename: procedure
parse arg suf, opt
os = errOS()
if os == 'TSO' then do
dsn = dsn2jcl('~tmp.tst.'suf)
if opt = 'r' then do
if sysDsn("'"dsn"'") \== 'DATASET NOT FOUND' then
call adrTso "delete '"dsn"'"
call csiOpen 'TST.CSI', dsn'.**'
do while csiNext('TST.CSI', 'TST.FINA')
say 'deleting csiNext' m.tst.fina
call adrTso "delete '"m.tst.fina"'"
end
end
return dsn
end
else if os == 'LINUX' then do
if abbrev(suf, '/') then
fn = suf
else
fn = .Stream%%new('~/tmp/tst/'suf)%%qualify /* full path */
cx = lastPos('/', fn)
if cx > 0 then do
dir = left(fn, cx-1)
if \sysIsFileDirectory(dir) then
call adrSh "mkdir -p" dir
if \sysIsFileDirectory(dir) then
call err 'tstFileName could not create dir' dir
end
if opt \= 'r' then
nop
else if sysIsFile(fn) then
call sysFileDelete fn
else if sysIsFileDirectory(fn) then
call adrSh 'rm -r' fn
return fn
end
else
call err 'tstFilename does not implement os' os
endProcedure tstFilename
/*--- say total errors and fail if not zero --------------------------*/
tstTotal: procedure expose m.
say '######'
say '######'
say '######' m.tst.tests 'tests with' ,
m.tst.err 'errors in' m.tst.errNames
say '######'
say '######'
if m.tst.err \== 0 then
call err m.tst.err 'errors total'
return
endProcedure tstTotal
/*--- test err: message, count it and continue -----------------------*/
tstErr: procedure expose m.
parse arg m, msg
say '### error' msg
m.m.err = m.m.err + 1
m.tst.err = m.tst.err + 1
nm = m.m.name
if wordPos(nm, m.tst.errNames) < 1 then
m.tst.errNames = m.tst.errNames nm
return 0
endProcedure tstErr
/*--- tstErrHandler: intercept errors --------------------------------*/
tstErrHandler: procedure expose m.
parse arg ggTxt
m = m.tst.act
if m == '' then
call err ggTxt
m.m.errHand = m.m.errHand + 1
oldOut = outDst(jOpen(oNew('JStem', mCut(tstErrHandler, 0)), '>'))
call errSay ggTxt
call outDst oldOut
call tstOut m.tst.act, '*** err:' m.tstErrHandler.1
do x=2 to m.tstErrHandler.0
call tstOut m, ' e' (x-1)':' m.tstErrHandler.x
end
return 0
endSubroutine tstErrHandler
tstTrc: procedure expose m.
parse arg msg
m.tst.trc = m.tst.trc + 1
say 'tstTrc' m.tst.trc msg
return m.tst.trc
endProcedure tstTrc
/*--- tstIni: global initialization ----------------------------------*/
tstIni: procedure expose m.
if m.tst.ini \== 1 then do
m.tst.ini = 1
call mapIni
m.tst.err = 0
m.tst.trc = 0
m.tst.errNames = ''
m.tst.tests = 0
m.tst.act = ''
end
if m.tst.ini.j \== 1 & m.j.ini == 1 then do
m.tst.ini.j = 1
call classNew 'n Tst u JRWO', 'm',
, "jReadO return tstReadO(m)",
, "jWrite call tstOut m, line",
, "jWriteO call tstWriteO m, var"
end
if m.tst.ini.e \== 1 & m.pipe.ini == 1 then do
m.tst.ini.e = 1
end
return
endProcedure tstIni
/* copx tst end **************************************************/
/* copx tstData begin *************************************************/
tstData: procedure expose m.
parse arg ty 2 le 'n' nu, l, r, num
abs = abs(num)
if nu \== '' then do
if abs // 5 = 0 then
return 'null' || (abs % 5 // nu + 1)
end
if ty = 'c' then do
if le = '' then
le = 8
le = abs // le + 1
if r = '' then
r = '+'
return left(l || num || r, le, right(r, 1))
end
if pos(ty, 'ief') < 1 then
call err 'bad type' ty
nn = abs
if abbrev(num, '-') | abbrev(num, '+') then
parse var num si 2 nn
else
si = ''
if ty == 'e' then
ex = 'e' || left('-', abs // 2) || (abs // 15)
else
ex = ''
if le \== '' then
nn = right(nn, abs // max(1, le - length(si||ex)) + 1, 1)
if ty \== 'i' & (abs // 4) \= 0 & length(nn) > 1 then
nn = overlay('.', nn, length(nn) - abs // length(nn))
return si || nn || ex
endProcedure tstData
tstDataClassFo: procedure expose m.
parse arg flds
ty = ''
do fx=1 by 2 to words(flds)
if word(flds, fx) = '.' then
ty = ty', v'
else
ty = ty', f' word(flds, fx) 'v'
end
t = classNew('n* tstData u' substr(ty, 2))
fo = oNew(m.t.name)
fs = oFlds(fo)
do fx=1 to m.fs.0
f = fo || m.fs.fx
m.f = word(flds, 2*fx)
end
return fo
endProcedure tstDataClassFo
tstDataClassOut: procedure expose m.
parse arg flds, f, t
fo = tstDataClassFo(flds)
fs = oFlds(fo)
do x=f to t
o = oCopyNew(fo)
do fx=1 to m.fs.0
na = substr(m.fs.fx, 2)
f = o || m.fs.fx
m.f = tstData(m.f, na, '+'na'+', x)
end
call outO o
end
return
endProcedure tstDataClassOut
/* copx tstData end ***************************************************/
/* copy tstAll end **************************************************/
/* copy time begin -----------------------------------------------------
11.05.23 wk: numeric digits transparent: in jeder Procedure drin
time2jul, tst externalisiert
----------------------------------------------------------------------*/
/*--- read timeZoneOffset and leapSeconds registers
and set variables for uniq ----------------------------------*/
timeReadCvt: procedure expose m.
parse arg debug
numeric digits 15
/* offsets documented in z/OS Data Areas Vol.1 */
cvtOH = '00000010' /* cvt control block Address */
cvtext2O = x2d('00000560') /* offset to extension 2 */
cvtldtoO = x2d('00000038') /* offset to timezone */
cvtlsoO = x2d('00000050') /* offset to leapSeconds */
/* CVT CB address + extention2 */
cvtExt2A = C2D(STORAGE(cvtOH,4)) + cvtext2O
/* cvtLdto timeZone address +offset */
m.timeZone = c2d(STORAGE(d2x(cvtext2A+cvtldtoO, 8), 8))
m.timeStckUnit = 1e-6 / 256 / 16
/* cvtLso LeapSecs address +offset */
m.timeLeap = C2D(STORAGE(d2x(cvtext2A+cvtlsoO, 8), 8))
m.timeUQDigits = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ012345678'
/* find lrsn of day 0 */
m.timeUQZero = timeGmt2Lrsn('2004-12-31-00.00.22.000000')
/* 0 out last 6 bits */
m.timeUQZero = b2x(overlay('000000', x2b(m.timeUQZero), 43))
if debug == 1 then do
say 'stckUnit =' m.timeStckUnit
say 'timeLeap =' d2x(m.timeLeap,16) '=' m.timeLeap ,
'=' format(m.timeLeap * m.timeStckUnit, 9,3) 'secs'
say 'timeZone =' d2x(m.timeZone,16) '=' m.timeZone,
'=' format(m.timeZone * m.timeStckUnit, 6,3) 'secs'
say "cvtext2_adr =" d2x(cvtExt2A, 8)
say 'timeUQZero =' m.timeUQZero
say 'timeUQDigis =' ,
length(m.timeUQDigits) 'digits' m.timeUQDigits
end
m.timeReadCvt = 1
return
endSubroutine timeReadCvt
timestampParse:
parse arg yyyy'-'mo'-'dd'-'hh'.'mm'.'ss'.'ffffff
return
/*--- GMT timestamp yyyy-mm.... -> stck value char(8)
BLSUXTID is described in z/OS V1R7.0 MVS IPCS Customization
BLSUXTID format : mo/dd/yyyy hh:mm:ss.ffffff ---------------*/
timeGmt2Stck: procedure expose m.
parse arg tst
call timestampParse tst
tDate = mo'/'dd'/'yyyy' 'hh':'mm':'ss'.'ffffff
ACC=left('', 8, '00'x)
ADDRESS LINKPGM "BLSUXTID TDATE ACC"
RETURN acc
endProcedure timeGmt2Stck
/*--- GMT timestamp yyyy-mm.... -> stck value in hex(16) ------------*/
timeGmt2LRSN: procedure expose m.
return c2x(left(timeGmt2Stck(arg(1)), 6))
endProcedure timeGmt2LRSN
/*--- LZT (Locale Zurich Tst -> stck value in hex(16) ---------------*/
timeLZT2LRSN: procedure expose m.
parse arg tst
numeric digits 23
if m.timeReadCvt \== 1 then
call timeReadCvt
return left(d2x(c2d(timeGmt2Stck(tst)) ,
- m.timeZone + m.timeLeap, 16), 12)
endProcedure timeLZT2LRSN
/*--- conversion from Stck Clock Value to GMT Timestamp
BLSUXTOD is described in z/OS V1R7.0 MVS IPCS Customization
input -> + leapseconds -> output ----------------------------*/
timeStck2Gmt: PROCEDURE expose m.
parse arg stck
stck = left(stck, 8, '00'x)
TDATE = COPIES('0' , 26)
ADDRESS LINKPGM "BLSUXTOD stck TDATE"
/* return format : mo/dd/yyyy hh:mm:ss.ffffff */
/* Timestamp format: yyyy-mm-dd-hh.mm.ss.ffffff */
parse var TDATE mo '/' dd '/' yyyy hh ':' mm ':' ss '.' ffffff
RETURN yyyy'-'mo'-'dd'-'hh'.'mm'.'ss'.'ffffff
endProcedure timeStck2Gmt
/*--- conversion from Lrsn Clock Value to GMT Timestamp -------------*/
timeLrsn2Gmt:
return timeStck2Gmt(x2c(arg(1)))
endProcedure timeLrsn2Gmt
/*--- conversion from Lrsn Clock Value to LZT Local Zurich Time -----*/
timeLrsn2LZT: procedure expose m.
parse arg lrsn
numeric digits 23
if m.timeReadCvt \== 1 then
call timeReadCvt
return timeStck2Gmt(d2c(x2d(left(lrsn, 16, 0)) ,
+ m.timeZone-m.timeLeap))
endProcedure timeLrsn2LZT
/*--- timestamp to julian --------------------------------------------*/
time2jul: procedure expose m.
parse arg yyyy '-' mm '-' dd '-'
/* date function cannot convert to julian, only from julian
==> guess a julian <= the correct and
try the next values
*/
j = trunc((mm-1) * 29.5) + dd
yy = right(yyyy, 2)
do j=j by 1
j = right(j, 3, 0)
d = date('s', yy || j, 'j')
if substr(d, 3) = yy || mm || dd then
return yy || j
end
return
endProcedure time2jul
/* copy time end -----------------------------------------------------*/
/* copy fmt begin **************************************************/
/*--- format the first arg by the format in the second ---------------*/
fmt: procedure
parse arg v, f 2 l
if abbrev('-', f) then
return v
else if f == 'l' then
return left(v, l)
else if f == 'r' then
return right(v, l)
else if f == 'f' then do
parse value l'.0.0.' with b '.' a '.' e '.'
return format(v, b, a, e, 0)
end
else if f == 'e' then do
parse var l b '.' a '.' e '.'
if b == '' then b = 2
if a == '' then a = 2
if e == '' then e = 2
res = format(v, b, a, e, 0)
y = length(res)-e-1
if substr(res, y) = '' then
return left(res, y-1)left('E', e+1, 0)
else if substr(res, y+1, 1) == '+' then
return left(res, y)substr(res, y+2)
else if substr(res, y+2, 1) == '0' then
return left(res, y+1)substr(res, y+3)
else
call err 'formatoverflow' f || l 'for' v '-->' res
end
else if f = 's' then
if l == '' then
return strip(v, 't')
else
return strip(v, l)
else if f == 'w' then do
parse var l st ',' le
return substr(v, st, le)
end
else
call err 'bad format' f l 'for' v
endProcedure fmt
/*--- format special (title, null Value also for numbers) ------------*/
fmtS: procedure expose m.
parse arg v, ty 2 l
if ty == 'f' then do
if \ dataType(v, 'n') then do
parse value l'.0.0.' with b '.' a '.' e '.'
return right(v, b + a + (a \== 0) + e + 2 * (e > 0))
end
end
else if ty == 'e' then do
if \ dataType(v, 'n') then do
parse var l b '.' a '.' e '.'
if b == '' then b = 2
if a == '' then a = 2
if e == '' then e = 2
return right(v, b + a + (a \== 0) + e + (e > 0))
end
end
return fmt(v, ty || l)
endProcedure fmtS
fmtTime: procedure expose m.
parse arg s, signed
return fmtUnits(s, 't', signed==1)
endProcedure fmtTime
fmtDec: procedure expose m.
parse arg s, signed
return fmtUnits(s, 'd', signed==1)
endProcedure fmtDec
fmtUnits: procedure expose m.
parse arg s, scale, signed
if s >= 0 then
res = fmtUnitsNN(s, scale, wi)
else
res = '-'fmtUnitsNN(abs(s), scale, wi)
len = m.fmt.units.scale.f.length + signed
if length(res) <= len then
return right(res, len)
if \ abbrev(res, '-') then
return right(right(res, 1), len, '+')
if length(res) = len+1 & datatype(right(res, 1), 'n') then
return left(res, len)
return right(right(res, 1), len, '-')
endProcedure fmtUnits
fmtUnitsNN: procedure expose m.
parse arg s, scale
sf = 'FMT.UNITS.'scale'.F'
sp = 'FMT.UNITS.'scale'.P'
if m.sf \== 1 then do
call fmtIni
if m.sf \== 1 then
call err 'fmtUnitsNN bad scale' scale
end
do q=3 to m.sp.0 while s >= m.sp.q
end
do forever
qb = q-2
qu = q-1
r = format(s / m.sp.qb, ,0)
if q > m.sf.0 then
return r || substr(m.sf.units, qb, 1)
if r < m.sf.q * m.sf.qu then
return (r % m.sf.qu) || substr(m.sf.units, qu, 1) ,
|| right(r //m.sf.qu, m.sf.width, 0)
/* overflow because of rounding, thus 1u000: loop back */
q = q + 1
end
endProcedure fmtUnitsNN
fmtIni: procedure expose m.
if m.fmt.ini == 1 then
return
m.fmt.ini = 1
call fmtIniUnits 't', '?smhd', 0 100 60 60 24 100, 0.01, 2
call fmtIniUnits 'd', '?.kMGTPE', 0 copies('1000 ',8), 0.001, 3
return
endProcedure fmtIni
fmtIniUnits: procedure expose m.
parse arg sc, us, fact, prod, wi
sf = 'FMT.UNITS.'sc'.F'
sp = 'FMT.UNITS.'sc'.P'
m.sf.0 = words(fact)
if length(us) + 1 <> m.sf.0 then
call err 'fmtIniUnits mismatch' us '<==>' fact
m.sf.1 = word(fact, 1)
m.sp.1 = prod
do wx=2 to m.sf.0
wx1 = wx-1
m.sf.wx = word(fact, wx)
m.sp.wx = m.sp.wx1 * m.sf.wx
end
m.sp.0 = m.sf.0
m.sf.units = us
m.sf.width = wi
m.sf.length= 2 * wi + 1
m.sf = 1
return
endProcedure fmtIniUnits
/* copy fmt end **************************************************/
/* copy fmtF begin **************************************************/
fmtFCsvAll: procedure expose m.
parse arg fSep
if fSep = '' then
fSep = ','
if \ inO(i) then
return
f = oFlds(i)
li = ''
do fx=1 to m.f.0
li = li',' substr(m.f.fx, 2)
end
call out substr(li, 3)
do until \ inO(i)
li = ''
do fx=1 to m.f.0
if m.f.fx = '' then do
li = li',' m.i
end
else do
fld = substr(m.f.fx, 2)
li = li',' m.i.fld
end
end
call out substr(li, 3)
end
return
endProcedure fmtFCsvAll
fmtFAdd: procedure expose m.
parse arg m
fx = m.m.0
do ax=2 to arg()
fx = fx + 1
parse value arg(ax) with m.m.fx.fld m.m.fx.fmt m.m.fx.tit
end
m.m.0 = fx
return m
endProcedure fmtFAdd
fmtFAddFlds: procedure expose m.
parse arg m, st
fx = m.m.0
do sx=1 to m.st.0
fx = fx + 1
parse value m.st.sx with m.m.fx.fld m.m.fx.fmt m.m.fx.tit
end
m.m.0 = fx
return m
endProcedure fmtFAddFlds
fmtF: procedure expose m.
parse arg m, st
if arg() >= 3 then
mid = arg(3)
else
mid = ' '
li = ''
do fx=1 to m.m.0
f = st || m.m.fx.fld
li = li || mid || fmtS(m.f, m.m.fx.fmt)
end
return substr(li, 1 + length(mid))
endProcedure fmtF
fmtFTab: procedure expose m.
parse arg m, rdr, wiTi
if m == '' then
m = 'FMTF.F'
return fmtFWriteSt(fmtFReset('FMTF.F'), env2buf(rdr)'.BUF', wiTi)
endProcedure fmtFTab
fmtFReset: procedure expose m.
parse arg m
m.m.0 = 0
return m
endProcedure fmtFReset
fmtFWriteSt: procedure expose m. ?????????
parse arg m, st, wiTi
if m.st.0 < 1 then
return 0
if m.m.0 < 1 then
call fmtFAddFlds m, oFlds(m.st.1)
call fmtFDetect m, st
if wiTi \== 0 then
call out fmtFTitle(m)
do sx=1 to m.st.0
call out fmtF(m, m.st.sx)
end
return st.0
fmtFWriteSt
fmtFTitle: procedure expose m.
parse arg m
if arg() >= 2 then
mid = arg(2)
else
mid = ' '
li = ''
do fx=1 to m.m.0
if m.m.fx.tit \= '' then
t = m.m.fx.tit
else if m.m.fx.fld = '' then
t = '='
else
t = substr(m.m.fx.fld, 1+abbrev(m.m.fx.fld, '.'))
li = li || mid || fmtS(t, m.m.fx.fmt)
end
return substr(li, 1 + length(mid))
res = ''
fs = m.form.FLDS
do ix=1 to m.fs.0
res = res fmtS(m.fs.ix, m.form.ix)
end
return substr(res, 2)
endProcedure fmtFldTitle
fmtFldTitle: procedure expose m.
parse arg form
res = ''
fs = m.form.FLDS
do ix=1 to m.fs.0
res = res fmtS(m.fs.ix, m.form.ix)
end
return substr(res, 2)
endProcedure fmtFldTitle
fmtFld: procedure expose m.
parse arg form, st
res = ''
fs = m.form.FLDS
do ix=1 to m.fs.0
f = m.fs.ix
res = res fmt(m.st.f, m.form.ix)
end
return substr(res, 2)
endProcedure fmtData
fmtFldSquash: procedure expose m.
parse arg newFo, class, src
fs = oFlds(class)
do fx = 1 to m.fs.0
fd = m.fs.fx
lMi = 9e9
lMa = 0
rMi = 9e9
rMa = 0
len = 0
do sx = 1 to m.src.0
x = verify(m.src.sx.fd, ' ', 'n')
if x < 1 then
iterate
lMi = min(lMi, x)
lMa = max(lMa, x)
x = length(strip(m.src.sx.fd, 't'))
rMi = min(rMi, x)
rMa = max(rMa, x)
end
if rMa = 0 then
m.newFo.fx = 'w1,1'len
else
m.newFo.fx = 'w'lMi',' || (rMa+1-lMi)
end
m.newFo.0 = m.fs.0
m.newFo.flds = fs
return newFo
endProcedure fmtFldSquash
fmtFDetect: procedure expose m.
parse arg m, st
do fx=1 to m.m.0
if m.m.fx.fmt = '' then
m.m.fx.fmt = fmtFDetect1(st, m.m.fx.fld)
end
return m
endProcedure fmtDetect
fmtFDetect1: procedure expose m.
parse arg st, suf
aMa = -1
aCnt = 0
aDiv = 0
nCnt = 0
nMi = ''
nMa = ''
nDi = -1
nBe = -1
nAf = -1
eMi = ''
eMa = ''
do sx=1 to m.st.0
f = m.st.sx || suf
v = m.f
aMa = max(aMa, length(v))
if \ dataType(v, 'n') then do
aCnt = aCnt + 1
if length(v) > 100 then
aDiv = 99
else if aDiv <=3 then
if aDiv.v \== 1 then do
aDiv.v = 1
aDiv = aDiv + 1
end
iterate
end
nCnt = nCnt + 1
if nMi == '' then
nMi = v
else
nMi = min(nMi, v)
if nMa == '' then
nMa = v
else
nMa = max(nMa, v)
parse upper var v man 'E' exp
if exp \== '' then do
en = substr(format(v, 2, 2, 9, 0), 7)
if en = '' then
en = exp
if eMi == '' then
eMi = en
else
eMi = min(eMi, en)
if eMa == '' then
eMa = en
else
eMa = max(eMa, en)
end
parse upper var man be '.' af
nBe = max(nBe, length(be))
nAf = max(nAf, length(af))
nDi = max(nDi, length(be || af))
end
/* say 'suf' suf aCnt 'a len' aMa 'div' aDiv
say ' ' nCnt 'n' nMi'-'nMa 'be' nBe 'af' nAf,
'di' nDi 'ex' eMi'-'eMa */
if nCnt = 0 | aDiv > 3 then
newFo = 'l'max(0, aMa)
else if eMi \== '' then do
eMa = max(eMa, substr(format(nMa, 2, 2, 9, 0), 7))
newFo = 'e' || (1+(eMi < 0)) || '.' || (max(0, nDi-1))'.' ,
|| max(length(eMa+0), length(eMi+0))
end
else if nAf > 0 then
newFo ='f'nBe'.'nAf
else
newFo ='f'nBe'.0'
/* say ' ' newFo */
return newFo
endProcedure fmtFDetect1
fmtFldRW: procedure expose m.
parse arg fo
ty = oGetClassPara(m.j.in)
call assert 'oFlds(ty) == m.fo.flds', 'fo different flds than class'
call out fmtFldTitle(fo)
do while in(ii)
call out fmtFld(fo, ii)
end
return
endProcedure fmtClassRW
fmtFldSquashRW: procedure expose m.
parse arg in, opCl
if in = '' then
in = m.j.in
if opCl == 'opCl' then
call jOpen in, 'r'
ty = oGetClassPara(in)
flds = oFlds(ty)
st = 'FMT.CLASSAD'
do ix=1 while jRead(in, st'.'ix)
end
m.st.0 = ix - 1
fo = fmtFldSquash(sqFo, ty, st)
call out fmtFldTitle(fo)
do ix = 1 to m.st.0
call out fmtFld(fo, st'.'ix)
end
if opCl == 'opCl' then
call jClose in
return
endProcedure fmtFldSquashRW
/* copy fmtF end * **************************************************/
/* copy sort begin ****************************************************/
sort: procedure expose m.
parse arg i, o, cmp
if cmp == '' then
m.sort.comparator = "cmp = m.l.l0 <<= m.r.r0"
else if length(cmp) < 6 then
m.sort.comparator = "cmp = m.l.l0" cmp "m.r.r0"
else if pos(';', cmp) < 1 then
m.sort.comparator = "aLe = l'.'l0; aRi = r'.'r0; cmp =" cmp
else
m.sort.comparator = "aLe = l'.'l0; aRi = r'.'r0;" cmp
call sort1 i, 1, m.i.0, o, 1, sort.work, 1
m.o.0 = m.i.0
return
endProcedure sort
sort1: procedure expose m.
parse arg i, i0, le, o, o0, w, w0
if le <= 3 then do
if le = 3 then do
call sortMerge i, i0, i0+1, i, i0+1, i0+2, w, w0
call sortMerge i, i0+2, i0+3, w, w0, w0+2, o, o0
end
else if le = 2 then
call sortMerge i, i0, i0+1, i, i0+1, i0+2, o, o0
else if le = 1 then
m.o.o0 = m.i.i0
return
end
h = (le + 1) % 2
call sort1 i, i0, h, o, o0+le-h, w, w0
call sort1 i, i0+h, le-h, w, w0, o, o0
call sortMerge o, o0+le-h, o0+le, w, w0, w0+le-h, o, o0
return
endProcedure sort1
sortMerge: procedure expose m.
parse arg l, l0, le, r, r0, re, o, o0
do while l0 < le & r0 < re
interpret m.sort.comparator
if cmp then do
m.o.o0 = m.l.l0
l0 = l0 + 1
end
else do
m.o.o0 = m.r.r0
r0 = r0 + 1
end
o0 = o0 + 1
end
do while l0 < le
m.o.o0 = m.l.l0
l0 = l0 + 1
o0 = o0 + 1
end
do while r0 < re
m.o.o0 = m.r.r0
r0 = r0 + 1
o0 = o0 + 1
end
return
endProcedure sortMerge
/* copy sort end ****************************************************/
/* copy match begin ***************************************************/
/************************************* begin copy match ******/
/*--- wildCard matching with the following wildchars:
* 0-n chars
? 1 char
fill matched expressions instem st if st is non empty
return 1 if mask matches wert ----------------------------------*/
match: procedure expose m.
parse arg wert, mask, st
if st == '' then
return matchRO(wert, mask)
m.st.0 = -9
return matchSt(wert, mask, st, 0)
endProcedure match
/*--- return the fixed prefix of maskt -------------------------------*/
matchPref: procedure
arg mask, suff
ix = verify(mask, '*?', 'm')
if ix = 0 then
return mask
else
return left(mask, ix-1)suff
endProcedure matchPref
/*--- return true if mask matches wert -------------------------------*/
matchRO: procedure
arg wert, mask
ix = verify(mask, '*?', 'm')
if ix < 1 then return (mask == wert)
if length(wert) < ix-1 then return 0
if left(mask, ix-1) \== left(wert, ix-1) then return 0
if substr(mask, ix, 1) == '?' then do
if length(wert) < ix then return 0
return matchRO(substr(wert, ix+1), substr(mask, ix+1))
end
mask = substr(mask, ix+1) /* * 0 - n Chars */
do ex = 1+length(wert) to ix by -1
if matchRO(substr(wert, ex), mask) then return 1
end
return 0
endProcedure matchRO
/*--- wildCard matching: fill matched expressions instem st
return 1 if mask matches wert ----------------------------------*/
matchSt: procedure expose m.
parse arg wert, mask, st, sx
ix = verify(mask, '*?', 'm')
if ix < 1 then do
if mask \== wert then
return 0
m.st.0 = sx
return 1
end
if \ abbrev(wert, left(mask, ix-1)) then
return 0
reMa = substr(mask, ix+1)
sx = sx + 1
if substr(mask, ix, 1) == '?' then do /* ? 1 Character */
if length(wert) < ix then
return 0
m.st.sx = substr(wert, ix, 1)
return matchSt(substr(wert, ix+1), reMa, st, sx)
end
do lx = 1+length(wert) to ix by -1 /* greedy: from all to empty */
if matchSt(substr(wert, lx), reMa, st, sx) then do
m.st.sx = substr(wert, ix, lx-ix)
return 1
end
end
return 0
endProcedure matchSt
matchTrans: procedure expose m.
parse arg mask, st
r = ''
ox = 1
sx = 0
ix = verify(mask, '*?', 'm')
do sx=1 to m.st.0 while ix > 0
if sx > m.st.0 then
call err 'matchTrans('mask',' st') has only' ,
m.st.0 'variables'
r = r || substr(mask, ox, ix-ox)m.st.sx
ox = ix+1
ix = verify(mask, '*?', 'm', ox)
end
if ix > 0 then
call err 'matchTrans('mask',' st') has only' ,
m.st.0 'variables'
return r || substr(mask, ox)
endProcedure matchTrans
/* copy match end *****************************************************/
/* copy comp begin *****************************************************
the shell compiler
syntax and semantics of the shell language see javaDoc
***********************************************************************/
/***** initialisation *************************************************/
/*--- module initialisation ------------------------------------------*/
compIni: procedure expose m.
if m.compIni = 1 then
return
m.compIni = 1
call pipeIni
call scanReadIni
cc = classNew('n Compiler u')
call mNewArea 'COMP.AST', '='
m.comp.stem.0 = 0
m.comp.idChars = m.scan.alfNum'@_'
call compIniKI '=', "skeleton", "expression or block"
call compIniKI '.', "object", "expression or block"
call compIniKI '-', "string", "expression or block"
call compIniKI '@', "shell", "pipe or $;"
call compIniKI ':', "assignAttributes", "assignment or statement"
call compIniKI '|', "assignTable", "header, sfmt or expr"
call compIniKI '#', "text", "literal data"
return
endProcedure compIni
compReset: procedure expose m.
parse arg m
m.m.scan = scanRead(,,'|0123456789')
m.m.chDol = '$'
m.m.chSpa = ' ' || x2c('09')
m.m.chNotBlock = '${}='
m.m.chNotWord = m.m.chNotBlock || m.m.chSpa
m.m.chKind = '.-=#@:|'
m.m.chKin2 = '.-=#;:|'
m.m.chKinC = '.-=@'
m.m.chOp = '.-<@|?'
m.m.chOpNoFi = '.-@|?'
return m
endProcedure compReset
compIniKI: procedure expose m.
parse arg ki, m.comp.kind.ki.name, m.comp.kind.ki.expec
return
/*--- constructor of Compiler ----------------------------------------*/
comp: procedure expose m.
parse arg src
nn = oNew('Compiler')
if src \== '' then
m.nn.cmpRdr = o2File(src)
else
m.nn.cmpRdr = ''
return nn
endProcedure comp
/**** user interface **************************************************/
/*--- compile and run ------------------------------------------------*/
compRun: procedure expose m.
parse arg spec, inO, ouO, infoA
cmp = comp(inO)
r = compile(cmp, spec)
if infoA \== '' then
m.infoA = 'run'
if ouO \== '' then
call pipeBeLa '>' ouO
call oRun r
if ouO \== '' then
call pipeEnd
return 0
endProcedure compRun
/*--- compile the source and return an oRunner with the code ---------*/
compile: procedure expose m.
parse arg m, spec
call compReset m
kind = '@'
spec = strip(spec)
do while pos(left(spec, 1), m.m.chKind) > 0
kind = left(spec, 1)
spec = strip(substr(spec, 2))
end
call scanSrc m.m.scan, spec
m.m.compSpec = 1
res = compCUnit(m, kind, 1)
do while abbrev(m.m.dir, '$#')
call envPutO substr(m.m.dir, 3, length(m.m.dir)-4),
, compCUnit(m, right(m.m.dir, 1))
end
if \ m.m.compSpec then
call jClose m.m.scan
return res
endProcedure compile
/*--- cUnit = compilation Unit = separate compilations
no nesting| --------------------------------------------*/
compCUnit: procedure expose m.
parse arg m, ki, isFirst
s = m.m.scan
code = ''
do forever
m.m.dir = ''
src = compUnit(m, ki, '$#')
if \ compDirective(m) then
return scanErr(s, m.comp.kind.ki.expec "expected: compile",
m.comp.kind.ki.name "stopped before end of input")
if \ compIsEmpty(m, src) then do
/*wkTst??? allow assTb in separatly compiled units */
if isFirst == 1 & m.src.type == ':' ,
& pos(' ', src) < 1 & abbrev(src, 'COMP.AST.') then
call mAdd src, '', ''
code = code || ';'compAst2code(m, src, ';')
end
if m.m.dir == 'eof' then do
if \ m.m.compSpec | m.m.cmpRdr == '' then
return oRunner(code)
call scanReadReset s, m.m.cmpRdr
call jOpen s, m.j.cRead
m.m.compSpec = 0
end
else if length(m.m.dir) == 3 then
ki = substr(m.m.dir, 3, 1)
else
return oRunner(code)
end
endProcedure compCUnit
/*--- directives divide cUnits ---------------------------------------*/
compDirective: procedure expose m.
parse arg m
m.m.dir = ''
s = m.m.scan
lk = scanLook(s)
cx = pos('#', lk, 3)
if \ abbrev(lk, '$#') then do
if \ scanAtEnd(m.m.scan) then
return 0
m.m.dir = 'eof'
return 1
end
else if scanLit(s, '$#end' , '$#out') then do
m.m.dir = 'eof'
return 1
end
else if pos(substr(lk, 3, 1), m.m.chKinD) > 0 then do
m.m.dirKind = substr(lk, 3, 1)
m.m.dir = left(lk, 3)
end
else if cx > 3 & pos(substr(lk, cx+1, 1), m.m.chKinD) > 0 then do
m.m.dirKind = substr(lk, 3, 1)
m.m.dir = left(lk, cx+1)
end
else
call scanErr s, 'bad directive:' word(lk, 1)
if \ scanLit(s, m.m.dir) then
call scanErr m.m.scan, 'directive mismatch' m.m.dir
return 1
endProcedure compDirective
/**** parse the whole syntax *******************************************
currently, with the old code generation,
parsing and code generation is intermixec
migrating to AST should will separate these tasks
***********************************************************************/
compUnit: procedure expose m.
parse arg m, kind, stopper
s = m.m.scan
if pos(kind, m.m.chKind';') < 1 then
return scanErr(s, 'bad kind' kind 'in compUnit(...'stopper')')
if stopper == '}' then do
if kind \== '#' then do
one = compExpr(m, 'b', translate(kind, ';', '@'))
if compisEmpty(m, one) then
return compAST(m, 'block')
else
return compAST(m, 'block', one)
end
tx = '= '
cb = 1
do forever /* scan nested { ... } pairs */
call scanVerify s, '{}', 'm'
tx = tx || m.s.tok
if scanLit(s, '{') then
cb = cb + 1
else if scanLook(s, 1) \== '}' then
call scanErr s, 'closing } expected'
else if cb <= 1 then
leave
else if scanLit(s, '}') then
cb = cb - 1
else
call scanErr s, 'closing } programming error'
tx = tx || m.s.tok
end
return compAst(m, 'block', tx)
end
else if pos(kind, '.-=') > 0 then do
return compData(m, kind)
end
else if pos(kind, '@;') > 0 then do
call compSpNlComment m
return compShell(m)
end
else if kind == '|' | kind == ':' then do
if kind == '|' then
res = compAssTab(m)
else
res = compAssAtt(m)
if abbrev(res, '#') then
return compAst(m, ':', substr(res, 3))
else
return compAst(m, ';', substr(res, 3))
end
else if kind == '#' then do
res = compAST(m, 'block')
call compSpComment m
if \ scanReadNl(s) then
call scanErr s,
, 'space nl expected in heredata until' stopper
do while \ abbrev(m.s.src, stopper)
call mAdd res, '=' strip(m.s.src, 't')
if \ scanReadNl(s, 1) then do
if stopper = '$#' then
leave
call scanErr s, 'eof in heredata until' stopper
end
end
return res
end
endProcedure compUnit
/*--- compile data lines return stmts or expr ------------------------*/
compData: procedure expose m.
parse arg m, ki
s = m.m.scan
lines = compAST(m, 'block')
do forever
state = 'f'
do forever
l = compExpr(m, 'd', ki)
if \ scanReadNL(s) then
state = 'l'
if \ compIsEmpty(m, l) | (state=='' &\abbrev(l, 'c')) then
call mAdd lines, l
if state == 'l' then
leave
call compComment m
state = ''
end
one = compStmt(m)
if one == '' then
leave
call mAdd lines, one
call compComment m
end
return lines
endProcedure compData
/*--- compile shell and return code ----------------------------------*/
compShell: procedure expose m.
parse arg m
a = compAst(m, ';')
m.a.text = ''
do forever
one = compPipe(m)
if one \== '' then
m.a.text = m.a.text || one
if \ scanLit(m.m.scan, '$;') then
return a
call compSpNlComment m
end
endProcedure compShell
/*--- compile an expression, type d=data, b=block w=word, s=strip ---*/
compExpr: procedure expose m.
parse arg m, type, ki
s = m.m.scan
if length(type) \== 1 | pos(type, 'dsbw') < 1 then
call scanErr s, 'bad type' type 'in compExpr(,' type','ki ')'
if length(ki) \== 1 | pos(ki, m.m.chKind';') < 1 then
call scanErr s, 'bad kind' ki 'in compExpr(,' type','ki ')'
charsNot = if(type=='b', m.m.chNotBlock,
, if(type=='w', m.m.chNotWord,m.m.chDol))
laTx = 9e9
st = compNewStem(m)
gotCom = 0
if pos(type, 'sb') > 0 then do
call compSpComment m
gotCom = gotCom | m.m.gotComment
end
ki2 = if(ki=='=', '-=', ki)
do forever
if scanVerify(s, charsNot, 'm') then do
call mAdd st, ki2 m.s.tok
laTx = min(laTx, m.st.0)
end
else do
pr = compPrimary(m, ki, 1)
if pr = '' then
leave
call mAdd st, pr
laTx = 9e9
end
gotCom = gotCom | compComment(m)
end
do rx = m.st.0 by -1 to laTx while m.st.rx = ki2
end
if pos(type, 'bs') > 0 then do
if rx >= laTx then
m.st.rx = strip(m.st.rx, 't')
m.st.0 = rx
end
if ki == '=' then
if m.st.0 < 1 then
return 'e='
else
ki = '-'
return substr('ce', 2-gotCom, rx < 1)ki'0*' st
endProcedure compExpr
/*--- compile a primary and return code ------------------------------*/
compPrimary: procedure expose m.
parse arg m, ki, withChain
s = m.m.scan
if \ scanLit(s, '$') then
return ''
if scanString(s) then /*wkTst??? brauchts beides? */
return translate(ki, '.--', '@;=')'=' m.s.val
if withChain then do
if scanLit(s, '.', '-') then do
op = m.s.tok
return op'('compCheckNN(m, compObj(m, op),
, 'objRef expected after $'op)
end
end
if pos(ki, '.<') >= 1 then
f = '. envGetO'
else
f = '- envGet'
if scanLit(s, '{') then do
if scanLit(s, '?') then
f = '- envIsDefined'
else if scanLit(s, '>') then
f = '- envReadO'
res = compCheckNE(m, compExpr(m, 'b', '='), 'var name')
if \scanLit(s, '}') then
call scanErr s, 'closing } missing after ${'
return f'(' || comp2Code(m, '-'res)')'
end
if scanName(s) then
return f"('"m.s.tok"')"
call scanBack s, '$'
return ''
endProcedure compPrimary
compObj: procedure expose m.
parse arg m, ki
s = m.m.scan
pk = compOpKi(m, '?')
one = compBlock(m, ki pk)
if one \== '' then
return compAstAddOp(m, one, ki)
pp = ''
if pk \== '' then do
ki = right(pk, 1)
pp = left(pk, length(pk)-1)
end
one = compPrimary(m, translate(ki, '.', '@'), 0)
if one \== '' then
return pp || one
if ki == '.' then do
if scanLit(s, 'compile') then do
if pos(scanLook(s, 1), m.m.chKinC) < 1 then
call scanErr s, 'compile kind expected'
call scanChar s, 1
return pp'. compile(comp(env2Buf()), "'m.s.tok'")'
end
end
call scanBack s, pk
return ''
endProcedure compObj
compFile: procedure expose m.
parse arg m
res = compCheckNE(m, compExprBlock(m, '='),
, 'block or expr expected for file')
if \ abbrev(res, '.') then do
end
else if substr(res, verify(res, '.', n), 3) == '0* ' then do
st = word(res, 2)
if m.st.0 = 1 & abbrev(m.st.1, '. envGetO(') then
/* if undefined variable use new jbuf */
if pos(')', m.st.1) == length(m.st.1) then
m.st.1 = left(m.st.1, length(m.st.1)-1) ,
|| ", '-b')"
end
return compASTAddOp(m, res, '<')
endProcedure compFile
/*--- scan an operator chain and a kind ------------------------------*/
compOpKi: procedure expose m.
parse arg m, opt
s = m.m.scan
op = ''
if opt == '<' then do
call scanVerify s, m.m.chOpNoFi
op = m.s.tok
if scanLit(s, '<') then
return op'<'
end
call scanVerify s, m.m.chOp
op = op || m.s.tok
k1 = scanLook(s, 1)
if k1 \== '' & pos(k1, m.m.chKind) > 0 then do
call scanLit s, k1
return op || k1
end
if opt == '?' | op == '' | pos(right(op, 1), m.m.chKind) > 0 then
return op
call scanErr s, 'no kind after ops' op
endProcedure compOpKi
/*--- block or expression --------------------------------------------*/
compExprBlock: procedure expose m.
parse arg m, ki
s = m.m.scan
pk = compOpKi(m, '<')
if right(pk, 1) == '<' then
return compAstAddOp(m, compFile(m), pk)
res = compBlock(m, ki pk)
if res \== '' then
return res
if pk \== '' then
lk = right(pk, 1)
else
lk = translate(ki, '.', '@')
res = compExpr(m, 's', lk)
if res \== '' then
return compASTAddOp(m, res, pk)
call scanBack s, pk
return res
endProcedure compExprBlock
/*--- compile a pipe and return code ---------------------------------*/
compPipe: procedure expose m.
parse arg m
s = m.m.scan
ios = ''
stmts = ''
stmtLast = ''
do forever
io1 = compRedirIO(m, 1)
if io1 \== '' then do
ios = ios',' io1
call compSpNlComment m
end
else do
if stmtLast \== '' then do
if \ scanLit(s, '$|') then
leave
call compSpNlComment m
end
one = comp2code(m, ';'compStmts(m))
if one == '' then do
if stmtLast \== '' then
call scanErr s, 'stmts expected after $|'
if ios == '' then
return ''
leave
end
if stmtLast \== '' then
stmts = stmts'; call pipe' || stmtLast
stmtLast = ';' one
end
end
if stmts \== '' then
stmtLast = insert('Begin', stmts, pos('pipe;', stmts)+3) ,
|| '; call pipeLast' stmtLast'; call pipeEnd'
if ios \== '' then do
if stmtLast == '' then
stmtLast = '; call pipeWriteAll'
stmtLast = '; call pipeBeLa 'substr(ios, 3) || stmtLast';' ,
'call pipeEnd'
end
return stmtLast
endProcedure compPipe
/*--- compile an io redirection, return
if makeExpr then "option", expr
else code write inut to standard out -------------*/
compRedirIO: procedure expose m.
parse arg m
s = m.m.scan
if \ scanLit(s, '$<', '$>>', '$>') then
return ''
opt = substr(m.s.tok, 2)
return "'"opt"'" comp2Code(m, compFile(m))
endProcedure compRedirIO
/*--- compile stmts (stmt or java) -----------------------------------*/
compStmts: procedure expose m.
parse arg m
lst = compNewStem(m)
do forever
one = compStmt(m)
if one == '' then do
do forever
la = compExpr(m, 's', ';')
if compIsEmpty(m, la) then
leave
la = strip(comp2code(m, ';'la))
if right(la, 1) \== ',' then do
one = one la
leave
end
one = one strip(left(la, length(la)-1))
call compSpNlComment m
end
if one = '' then
return 'l*' lst
one = ';' one
end
call mAdd lst, one
call compSpNlComment m
end
endProcedure compStmts
/*--- compile a single statement -------------------------------------*/
compStmt: procedure expose m.
parse arg m
s = m.m.scan
if scanLit(s, "$=") then do
res = compAss(m)
if res == '' then
call scanErr s, 'assignment expected after $='
return res
end
if scanLit(s, '$@') then do
if \ scanName(s) then
return 'l;' comp2Code(m,
, '@'compCheckNE(m, compExprBlock(m, '@'),
, "block or expr expected after $@"))
fu = m.s.tok
if fu == 'for' | fu == 'with' | fu == 'forWith' then do
v = comp2Code(m, '-'compCheckNE(m, compExpr(m, 'b', '='),
, "variable name after $@for"))
call compSpComment m
st = comp2Code(m, ';'compCheckNN(m, compStmt(m, 'with'),
, "statement after $@for" v))
if fu == 'forWith' then
st = 'call envSetWith envGetO('v');' st
if abbrev(fu, 'for') then
st = 'do while envReadO('v');' st'; end'
if fu == 'forWith' then
st = 'call envPushWith "";' st '; call envPopWith'
else if fu == 'with' then
st = 'call envPushName' v';' st '; call envPopWith'
return ';' st
end
if fu == 'do' then do
call compSpComment m
var = if(scanName(s), m.s.tok, '')
pre = var
call compSpComment m
if scanLook(s, 1) \== '=' then
var = ''
call compSpComment m
suf = compExpr(m, 's', ';')
if \ compIsEmpty(m, suf) then
suf = comp2Code(m, ':'suf)
else if var \== '' then
call scanErr s, "$@do control construct expected"
else
suf = ''
call compSpComment m
st = comp2Code(m, ";"compCheckNN(m, compStmt(m),
, "$@do statement"))
return "; do" pre suf";",
if(var \== "", "call envPut '"var"'," var";") st"; end"
end
if fu == 'ct' then do
call compSpComment m
call compInter(comp2Code(m, ';'compCheckNN(m, compStmt(m),
, 'ct statement')));
return '; '
end
if fu == 'proc' then do
nm = compCheckNE(m, compExpr(m, 'b', '='), "proc name")
call compSpComment m
st = oRunner(comp2Code(m, ';'compCheckNN(m, compStmt(m),
, 'proc statement')));
call envPutO compInter('return' comp2Code(m, '-'nm)), st
return '; '
end
if scanLit(s, '(') then do
call compSpComment m
if \ scanLit(s, ')') then
call scanErr s, 'closing ) expected after $@'fu'('
return '; call oRun envGetO("'fu'")'
end
if scanLit(s, '{', '.{', '-{', '={') then do
br = m.s.tok
a = compExpr(m, 'b', if(br == '{', '-', left(br, 1)))
if \ scanLit(s, '}') then
call scanErr s, 'closing } expected after $@'fu || br
res = '; call oRun envGetO("'fu'")'
if pos(left(a, 1), 'ec') < 1 then
res = res',' comp2code(m, a)
return res
end
call scanErr s, 'procCall, for, do, ct, proc' ,
'or objRef expected after $@'
end
if scanLit(s, '$$') then
return compCheckNN(m, compExprBlock(m, '='),
, 'block or expression expected after $$')
return ''
endProcedure compStmt
compAss: procedure expose m.
parse arg m, aExt
s = m.m.scan
sla = scanLook(s)
slx = verify(sla, m.m.chKind'/'m.m.chOp, 'n')
if slx > 0 then
sla = left(sla, slx-1)
sla = pos('/', sla) > 0
nm = ''
if \ sla then do
nm = compExpr(m, 'b', '=')
if compIsEmpty(m, nm) then
return ''
nm = comp2Code(m, '-'nm)
if \ scanLit(s, "=") then
return scanErr(s, '= expected after $=' nm)
end
m.m.bName = ''
vl = compCheckNE(m, compExprBlock(m, '='),
, 'block or expression after $=' nm '=')
if sla then
if m.m.bName == '' then
call scanErr s, 'missing blockName'
else
nm = "'"m.m.bName"'"
va = compAstAftOp(m, vl)
if va \== '' & m.va.type == ':' then do
pu = "call envPushName" nm
if abbrev(m.m.astOps, '<') then
call mAdd va, pu ", 'asM'", "call envPopWith"
else if abbrev(m.m.astOps, '<<') then
call mAdd va, pu ", 'asM'", "call envPopWith"
else
call mAdd va, pu ", 'as1'", "call envPopWith"
return va
end
if compAstKind(m, vl) == '-' then
return '; call envPut' nm',' comp2Code(m, vl)aExt
else
return '; call envPutO' nm',' comp2Code(m, '.'vl)aExt
endProcedure compAss
/*--- block deals with the correct kind and operators
the content is parsed by compUnit ------------------------------*/
compBlock: procedure expose m.
parse arg m, dKi ops
s = m.m.scan
if \ scanLit(s, '{', '¢', '/') then
return ''
start = m.s.tok
if (ops \== '' & pos(right(ops, 1), m.m.chKind) < 1) ,
| pos(dKi, m.m.chKind) < 1 then
return scanErr(s, 'bad kind' ops 'for block (def' dKi')')
if ops == '' then do
ki = dKi
end
else do
ki = right(ops, 1)
ops = left(ops, length(ops)-1)
end
starter = start
if start == '{' then
stopper = '}'
else if start == '¢' then
stopper = '$!'
else do
call scanVerify s, '/', 'm'
starter = '/'m.s.tok'/'
stopper = '$'starter
if \scanLit(s, '/') then
call scanErr s, 'ending / after stopper' stopper 'expected'
end
res = compUnit(m, ki, stopper)
if \ scanLit(s, stopper) then do
if pos(ki, ':|') < 1 | \ abbrev(stopper, '$') then
call scanErr s, 'ending' stopper 'expected after' starter
else if \ scanLit(s, substr(stopper, 2)) then
call scanErr s, 'ending' stopper 'or' substr(stopper, 2),
'expected after' starter
end
if abbrev(starter, '/') then
m.m.bName = substr(starter, 2, length(starter)-2)
else
m.m.bName = ''
if m.res.text == '' then
m.res.text = ' '
return compAstAddOp(m, res, ops)
endProcedure compBlock
compAssAtt: procedure expose m. aClass
parse arg m
res = ''
aClass = ''
s = m.m.scan
last = ''
do forever
if compSpNlComment(m, '*') then do
end
else if pos(scanLook(s, 1), '/!}') > 0 then do
leave
end
else if scanLit(s, ';', '$;') then do
if last = ';' then
res = res'; call envWithNext'
last = ';'
end
else do
s1 = compAss(m, ", 1")
if s1 == '' then do
s1 = compStmt(m)
if s1 == '' then
leave
end
else do
if last == ';' then
res = res'; call envWithNext'
last = 'a'
end
res = res';' comp2code(m, ';'s1)
end
if res == '' then
res = ';'
end
if last == '' then
return res
else
return '# call envWithNext "b";' res ,
'; call envWithNext "e";'
endProcedure compAssAtt
compAssTab: procedure expose m. aClass
parse arg m
s = m.m.scan
call compSpNlComment m, '*'
hy = 0
tab = ''
do forever
bx = m.s.pos
if \ scanName(s) then
leave
hx = hy + 1
h.hx.beg = bx
if hx > 1 & bx <= h.hy.end then
call scanErr s, 'header overlap' m.s.tok 'pos' bx
h.hx = m.s.tok
tab = tab', f' m.s.tok 'v'
h.hx.end = m.s.pos
hy = hx
call compSpComment m, '*'
end
if tab \== '' then
aClass = classNew('n* Ass u' substr(tab, 3))
res = ''
isFirst = 1
do while scanReadNl(s)
do forever
call compSpNlComment m, '*'
s1 = compStmt(m)
if s1 == '' then
leave
res = res';' comp2code(m, ';'s1)
last = 's'
end
if pos(scanLook(s, 1), '/!}') > 0 then
leave
do qx=1
bx = m.s.pos
s1 = compExpr(m, 'w', '=')
if compIsEmpty(m, s1) then
leave
ex = m.s.pos
if ex <= bx then
return scanErr(s, 'colExpr backward')
do hy=1 to hx while bx >= h.hy.end
end
hz = hy+1
if hz <= hx & ex > h.hz.beg then
call scanErr s, 'value on hdr' h.hy 'overlaps' h.hz
else if hy > hx | bx >= h.hy.end | ex <= h.hy.beg then
call scanErr s, 'value from' bx 'to' ex ,
'no overlap with header' h.hy
if qx > 1 then
nop
else if isFirst then do
res = res"; call envWithNext 'b', '"aClass"'"
isFirst = 0
end
else
res = res"; call envWithNext"
res = res"; call envPut '"h.hy"'," comp2Code(m, "-"s1)", 1"
call compSpComment m, '*'
end
end
if isFirst then
return res
else
return '#' res"; call envWithNext 'e'"
endProcedure compassTab
/**** lexicals ********************************************************/
/*--- skip a comment. return 0 if there is none ----------------------*/
compComment: procedure expose m.
parse arg m
s = m.m.scan
res = 0
do forever
if scanLit(s, '$**') then
m.s.pos = 1 + length(m.s.src) /* before next nl */
else if scanLit(s, '$*+') then
call scanReadNl s, 1
else if scanLit(s, '$*(') then do
do forever
if scanVerify(s, m.m.chDol, 'm') then iterate
if scanReadNl(s) then iterate
if compComment(m) then iterate
if \ scanLit(s, '$') then
call scanErr s, 'source end in comment'
if scanLit(s, '*)') then
return 1
if scanLit(s, '$') then iterate
if scanString(s) then iterate
end
end
else
return res
res = 1
end
endProcedure compComment
/*--- skip spaces and comments ---------------------------------------*/
compSpComment: procedure expose m.
parse arg m, xtra
s = m.m.scan
sp = 0
co = 0
do forever
if scanVerify(s, m.m.chSpa) then
sp = 1
else if compComment(m) then
co = 1
else if xtra == '' then
leave
else if \ scanLit(s, xtra) then
leave
else do
co = 1
m.s.pos = 1+length(m.s.src)
end
end
m.m.gotComment = co
return co | sp
endProcedure compSpComment
/*--- skip spaces, NLs and comments ----------------------------------*/
compSpNlComment: procedure expose m.
parse arg m, xtra
found = 0
do forever
if compSpComment(m, xtra) then
found = 1
else if scanReadNl(m.m.scan) then
found = 1
else
return found
end
endProcedure compSpComment
/**** small helper routines ******************************************/
compInter: procedure expose m.
interpret arg(1)
return
endProcedure compInter
/*--- if va == null then issue an error with msg --------------------*/
compCheckNN: procedure expose m.
parse arg m, va, msg
if va == '' then
call scanErr m.m.scan, msg 'expected'
return va
endProcedure compCheckNN
/*--- return true iff expression is empty ---------------------------*/
compIsEmpty: procedure expose m.
parse arg m, ex
if pos(' ', ex) < 1 & pos('COMP.AST.', ex) > 0 then do
a = substr(ex, pos('COMP.AST.', ex))
a = compAstAftOp(m, a)
if m.a.type = 'block' then
return 0 /* m.a.0 == 0 */
else
return m.a.text == ''
end
e1 = word(ex, 1)
return ex = '' | verify(e1, 'ec', 'm') > 0
endProcedure compIsEmpty
/*--- if va == null or empty then issue an error with msg -----------*/
compCheckNE: procedure expose m.
parse arg m, ex, msg
e1 = left(ex, 1)
if compIsEmpty(m, ex) then
call scanErr m.m.scan, msg 'expected'
return ex
endProcedure compCheckNE
/**** AST = Astract Syntax Graph ***************************************
goal is to migrate to migrate to old codeGenerator to AST
***********************************************************************/
/*--- create a new AST -----------------------------------------------*/
compAST: procedure expose m.
parse arg m, tp
n = mNew('COMP.AST')
m.n.type = tp
if wordPos(tp, 'block') > 0 then do
do cx=1 to arg()-2
m.n.cx = arg(cx+2)
end
m.n.0 = cx-1
end
else do
m.n.text = arg(3)
m.n.0 = 0
end
m.a.isAnnotated = 1
return n
endProcedure compAST
/*--- add operandands to an AST -------------------------------------*/
compASTAddOp: procedure expose m.
parse arg m, a, ops
if ops == '' then
return a
if pos('COMP.AST.', a) < 1 then
return ops || a
if m.a.type = 'ops' then do
m.a.text = ops || m.a.text
return a
end
n = compAst(m, 'ops', ops)
call mAdd n, a
return n
endProcedure compAstAddOp
/*--- return the first AST after the operand chain
put the operands into m.m.astOps ---------------------------*/
compASTaftOp: procedure expose m.
parse arg m, a
m.m.astOps = ''
if \ abbrev(a, 'COMP.AST.') then
return ''
do while m.a.type == 'ops'
m.m.astOps = m.a.text || m.m.astOps
a = m.a.1
end
return a
endProcedure compASTAftOpType
/*--- return the kind of an AST --------------------------------------*/
compASTKind: procedure expose m.
parse arg m, a
m.m.astOps = ''
if \ abbrev(a, 'COMP.AST.') then
return left(a, 1)
c = a
do while m.c.type == 'ops'
if m.c.text \== '' then
return left(m.c.text, 1)
c = m.c.1
end
if a == c then
return '?'
return compAstKind(m, c)
endProcedure compASTKind
/*--- return the code for an AST with operand chain trg --------------*/
compAst2Code: procedure expose m.
parse arg m, a, aTrg
if pos(' ', a) > 0 | \ abbrev(a, 'COMP.AST.') then
return comp2Code(m, aTrg || a)
if \ abbrev(a, 'COMP.AST.') then
call err 'bad ast' a
do while m.a.type == 'ops'
aTrg = aTrg || m.a.text
a = m.a.1
end
trg = compAstOpsReduce(m, aTrg)
if m.a.type == translate(right(trg, 1), ';', '@') then do
if length(trg) == 1 then do
if pos(trg, ';@') > 0 then
return 'do;' m.a.text ';end'
else
return m.a.text
end
else
return compAST2Code(m, a, left(trg, length(trg)-1))
end
if m.a.type == 'block' then do
op = right(trg, 1)
tLe = left(trg, length(trg)-1)
call compASTAnnBlock m, a
if pos(m.a.maxKind, '.-<') > 0 & pos(op, '.-|?') > 0 then do
if m.a.0 = 1 then do
o1 = if(op=='-', '-', '.')
r = compAst2Code(m, m.a.1, o1)
r = compC2C(m, o1, compAstOpsReduce(m, tLe||o1), r)
if pos(op, '.-<') > 0 then
return '('r')'
else
return r
end
if m.a.0 = 0 & op == '?' then
return compC2C(m, '.', compAstOpsReduce(m, tLe'.'))
if op == '-' then do
cd = ''
do cx = 1 to m.a.0
cd = cd '('compAst2Code(m, m.a.cx, '-')')'
end
return compC2C(m, '-', trg, substr(cd, 2))
end
call scanErr m.m.scan, 'bad block cardinality' aTrg
end
cd = ''
do cx = 1 to m.a.0
cd = cd';' compAst2Code(m, m.a.cx, ';')
end
if right(trg, 1) == '@' then
trg = overlay(';', trg, length(trg))
return compC2C(m, ';', trg, 'do;' cd'; end')
end
else if m.a.type == ';' then do
return compC2C(m, ';', trg, m.a.text)
if right(trg, 1) == '-' then
return compAst2Code(m, "- o2String('"oRunner(m.a.text)"')",
, trg)
if right(trg, 1) == '<' then
return compAst2Code(m, "< o2File('"oRunner(m.a.text)"')",
, trg)
end
else if m.a.type == ':' then do
if m.a.0 = 0 then
call mAdd a, 'call envPushWith', 'call envPopWith'
return compC2C(m, ';', trg,
, 'do;' m.a.1';' m.a.text';' m.a.2'; end')
end
call scanErr m.m.scan, 'implement type' m.a.type 'for' a 'trg' trg
endProcedure compAst2Code
/*--- do a chain of code transformations
from code of kind fr by opList
op as from kind operand
= constant -
- rexx string Expr cast to string/ concat file/output
. rexx object Expr cast to object
< rexx file Expr cast to file
; rexx Statements execute, write obj, Str
@ - cast to ORun, run an obj, write file
| - extract exactlyOne
? - extract OneOrNull
----------------------------------------------------------------------*/
compC2C: procedure expose m.
parse arg m, fr, opList, code
oldCode = fr':' code '==>' opList '==>'
do tx=length(opList) by -1 to 1
to = substr(opList, tx, 1)
if fr == to then
iterate
nn = '||||'
if to == '-' then do
if fr == '=' then
nn = quote(code)
else if abbrev(fr code, '. envGetO(') then
nn = 'envGet(' || substr(code, 9)
else if fr == ';' then
nn = "o2String('"oRunner(code)"')"
else if pos(fr, '.<') > 0 then
nn = "o2String("code")"
end
else if to == '.' then do
if fr == '=' then
nn = quote(s2o(code))
else if abbrev(fr expr, '- envGet(') then
nn = 'envGetO('substr(expr, 8)
else if fr == '-' then
nn = 's2o('code')'
else if fr == '<' then
nn = code
else if fr == ';' then
nn = quote(oRunner(code))
end
else if to == '@' then do
if fr == '.' then
nn = 'call oRun' code
else if fr == '<' then
nn = 'call pipeWriteAll' code
else if fr == ';' then
nn = code
to = ';'
end
else if to == ';' then do
if fr == '=' then
nn = 'call out' quote(code)
else if fr == '-' then
nn = 'call out' code
else if fr == '.' | fr == '<' then
nn = 'call outO' code
end
else if to == ':' then do
if fr == '=' then
nn = quote(code)
else
nn = code
to = ';'
end
else if to == '<' then do
if fr == '-' then
nn = 'file('code')'
else if fr == '=' then
nn = "file("quote(code)")"
else if fr == '.' then
nn = 'o2File('code')'
else if fr == ';' then
nn = 'o2File('oRunner(code)')'
end
else if to == '|' | to == '?' then do
if fr == '<' | fr == '.' then
nn = 'fileSingle('code if(to == '|','', ", ''")')'
else if fr == '@' | fr == ';' then
/* ???wkTst optimize: do it directly */
nn = compC2C(m, fr, to'<', code)
to = '.'
end
if nn == '||||' then
return scanErr(m.m.scan,
,'compC2C bad fr' fr 'to' to 'list' opList)
fr = to
code = nn
end
return code
endProcedure compC2C
/*--- reduce a chain of operands -------------------------------------*/
eliminate duplicates and identity transformations ----------*/
compAstOpsReduce: procedure expose m.
parse arg m, ops
ki = ops
ki = space(translate(ops, ' ', 'e('), 0)
fr = ';<; <;< -.- <@<'
to = '; < - < '
fr = fr '== -- .. << ;; @@ @('
to = to '= - . < ; @ (@'
wc = words(fr)
do until ki = oldKi
oldKi = ki
do wx=1 to wc
do forever
wf = word(fr, wx)
cx = pos(wf, ki)
if cx < 1 then
leave
ki = left(ki, cx-1) || word(to, wx) ,
|| substr(ki, cx+length(wf))
end
end
end
return ki
endProcedure compASTOpsReduce
/*--- annotate a block if necessary ----------------------------------*/
compASTAnnBlock: procedure expose m.
parse arg m, a
if m.a.isAnnotated == 1 then
return
mk = ''
do cx=1 to m.a.0
c = m.a.cx
if pos(' ', c) > 0 | \ abbrev(c, 'COMP.AST.') then
ki = left(c, 1)
else if \ abbrev(c, 'COMP.AST.') then
return scanErr(m.m.scan, 'bad ast' c 'parent' a) /0
else
call scanErr m.m.scan, 'implement kind of' c 'type' m.c.type
if pos(ki, '=-.<;@:|') < 1 then do
if pos(ki, 'el0') < 1 then
call err 'bad kind' ki
end
else if mk == '' | pos(ki, '=-.<;@:|') > pos(mk, '=-.<;@:|') then
mk = ki
end
m.a.maxKind = mk
m.a.isAnnotated = 1
return
endProcedrue compASTAnnBlock
/**** old code generator ***********************************************
plan is to replace it with AST ******************************/
/*--- transform abstract syntax tree to code ------------------------
wkTst??? codeTree besser dokumentieren
optimizer an/und/abschaltbar machen
(test sollte laufen, allenfalls gehen rexx variabeln
verloren)
syntax tree is simple, only where
* a transformation is needed from several places or
* must be deferred for possible optimizations
sn = ops* syntax node op or syntax function
( '=' constant none
| '-' rexxExpr yielding string cast to string
| '.' rexxExpr yielding object cast to object
| '<' rexxExpr yielding file cast to file
| ';' rexxStmts execute, write obj, Str
| '*' stem yielding multiple sn none
)
ops = '@' cast to ORun
| '|' single
| 'e' empty = space only
| 'c' empty = including a comment
| '0' cat expression parts
| 'l' cat lines
| '(' add ( ... ) or do ... end
---------------------------------------------------------------------*/
comp2Code: procedure expose m.
parse arg m, ki expr
if expr == '' & pos(' ', ki) < 1 & pos('COMP.AST.', ki) > 0 then do
cx = pos('COMP.AST.', ki)
return compAst2Code(m, substr(ki, cx), left(ki, cx-1))
end
/* wkTst??? optimize: use stem with code and interpret */
if expr = '' & pos(right(ki, 1), '@;=') < 1 then
return scanErr(m.m.scan, 'comp2Code empty expr' ki expr)
do forever
ki = comp2CodeKind(m, ki)
if length(ki) <= 1 then
if pos(ki, m.m.chKind';<') > 0 then
return expr
else
call err 'comp2Code bad return' ki expr
fr = right(ki, 1)
to = substr(ki, length(ki)-1, 1)
opt = ''
if pos(to, 'l0') > 0 | (to == '*' & fr == '*') then do
opt = to
to = substr(ki, length(ki)-2, 1)
end
toBef = to
nn = '||||'
if fr == '*' then do
if opt == '' then
call scanErr m.m.scan, 'no sOp for * kind' ki expr
cat = comp2CodeCat(m, expr, opt, to)
parse var cat to nn
end
else if to == '-' then do
if fr == '=' then
nn = quote(expr)
else if abbrev(fr expr, '. envGetO(') then
nn = 'envGet(' || substr(expr, 9)
else if fr == ';' then
nn = "o2String('"oRunner(expr)"')"
else if pos(fr, '.<') > 0 then
nn = "o2String("expr")"
end
else if to == '.' then do
if fr == '=' then
nn = quote(s2o(expr))
else if abbrev(fr expr, '- envGet(') then
nn = 'envGetO('substr(expr, 8)
else if fr == '-' then
nn = 's2o('expr')'
else if fr == '<' then
nn = expr
else if fr == ';' then
nn = quote(oRunner(expr))
end
else if to == '@' then do
if fr == '.' then
nn = 'call oRun' expr
else if fr == '<' then
nn = 'call pipeWriteAll' expr
else if fr == ';' then
nn = expr
to = ';'
end
else if to == ';' then do
if fr == '=' then
nn = 'call out' quote(expr)
else if fr == '-' then
nn = 'call out' expr
else if fr == '.' | fr == '<' then
nn = 'call outO' expr
else if fr == '#' then
nn = 'call envPushWith ;'expr'; call envPopWith'
end
else if to == ':' then do
if fr == '=' then
nn = quote(expr)
else
nn = expr
to = ';'
end
else if to == '<' then do
if fr == '-' then
nn = 'file('expr')'
else if fr == '=' then
nn = "file("quote(expr)")"
else if fr == '.' then
nn = 'o2File('expr')'
else if fr == ';' then
nn = 'o2File('oRunner(expr)')'
end
else if to == '(' then do
nn = compAddBracks(m, fr, expr)
to = fr
end
else if to == '|' | to == '?' then do
if fr == '<' | fr == '.' then do
nn = 'fileSingle('expr if(to == '|','', ", ''")')'
to = '.'
end
else if fr == '@' | fr == ';' then do
to = to'<'fr
nn = expr
end
end
if nn == '||||' then
return scanErr(m.m.scan,
,'comp2code bad fr' fr 'to' toBef 'for' ki expr)
ki = left(ki, length(ki)-2-length(opt))to
expr = nn
end
endProcedure comp2Code
/*--- optimize operands: eliminate duplicates and
identity transformations -------------------*/
comp2CodeKind: procedure expose m.
parse arg m, ki
ki = '$'space(translate(ki, ' ', 'ce'), 0)
fr.2 = '== -- .. << ;; (( -( .( ;( (< @; @@ ;@ @( $l $0 @#'
to.2 = '= - . < ; ( (- (. (; < ; @ @ (@ $ $ ;#'
fr.3 = ';0; ;l; -.- -;- .-. .;. ;<; ;<( <(; @(- @(l |(l ?(l'
to.3 = ' 0; l; - - . . ; ;< <; ;(- ;(l (|l (?l'
do until ki = oldKi
oldKi = ki
do le=3 by-1 to 2
do cx=1 while cx <= length(ki)+1-le
wx = wordPos(substr(ki, cx, le), fr.le)
if wx > 0 then
ki = left(ki, cx-1) || ,
word(to.le, wx) || substr(ki, cx+le)
end
end
end
return substr(ki, 2)
endProcedure comp2CodeKind
/*--- generate one codeString for one stem -------------------------*/
comp2CodeCat: procedure expose m.
parse arg m, st, sOp, trgt
toCode = trgt == '@' | trgt == ';'
if m.st.0 < 1 & trgt \== '<' then
return trgt
tr1 = trgt
if \ toCode then do
/* check wether we need to evaluate statements
and cast the outptut to an object */
maxTy = 0
do x=1 to m.st.0
maxTy = max(maxTy, pos(left(m.st.x, 1), '=-.<;@'))
end
if trgt \== '<' then do
if maxTy >= 5 then do
tr1 = ';'
toCode = 1
end
end
else do /* handle files */
if maxTy > 1 then do /* not constant */
res = ';'
do sx=1 to m.st.0
res = res';' comp2Code(m, ';'m.st.sx)
end
return '<'res
end
/* constant file write to jBuf */
buf = jOpen(jBuf(), m.j.cWri)
do sx=1 to m.st.0
call jWrite buf, substr(m.st.sx, 3)
end
return '<' quote(jClose(buf))
end
end
if m.st.0 = 1 then do
if trgt == '|' | trgt == '?' then
return left(m.st.1, 1) comp2Code(m, m.st.1)
else if trgt \== '<' then
return trgt comp2Code(m, trgt || m.st.1)
end
tr2 = tr1
if toCode then do
mc = '; '
if sOp == 0 then do
mc = ''
tr2 = ':'
end
end
else if sOp == '0' then
mc = if(tr1 == '.' | tr1 == '-', '', ' || ')
else if sOp == 'l' then
mc = ' '
else
call scanErr m.m.scan, 'bad sOp' sOp ,
'in comp2CodeCat('m',' st',' sOp',' trgt')'
if symbol('m.st.1') \== 'VAR' then
return err("bad m."st'.1')
sep = if(tr1 == '.' | tr1 == '-' | tr1 == '=', ' || ', ' ')
sep = if(sOp = 0, ' || ', ' ')
tr3 = left(tr2, sOp \== 0)
res = comp2Code(m, tr3 || m.st.1)
do sx = 2 to m.st.0
if (tr2 == '.' | tr2 == '-') ,
& (m.st.sx = '-' | m.st.sx = '.') then do
/* empty expr is simply a rexx syntax space */
if right(res, 1) \== ' ' then
res = res' '
end
else do
act = comp2Code(m, tr3 || m.st.sx)
res = compCatRexx(res, act, mc, sep)
end
end
return copies(trgt || sOp, tr1 \== trgt)tr1 res
endProcedure comp2CodeCat
/*--- add expression brackets if necessary --------------------------*/
compAddBracks: procedure expose m.
parse arg m, ki, ex
if ki == ';' then
return 'do;' ex || left(';', ex \= '') 'end'
if \ (ki == '.' | ki == '-') then
return ex
ex = strip(ex)
e1 = left(ex, 1)
if e1 == '(' & pos('(', ex, 2) = 0 & pos(')', ex) = length(ex) then
return ex
if pos(e1, '"''') > 0 & pos(e1, ex, 2) = length(ex) then
return ex
return '('ex')'
endProcedure compAddBracks
/*--- cat two rexx parts, avoid strange effects--------------------*/
compCatRexx: procedure expose m.
parse arg le, ri, mi, sep
if mi \== '' then
return le || mi || ri
lr = right(le, 1)
rl = left(ri, 1)
if (lr == "'" | lr == '"') then do
if rl == lr then /* "a","b" -> "ab" */
return left(le, length(le)-1) || substr(ri, 2)
else if rl == '(' then /* "a",( -> "a" || ( */
return le||sep||ri /* avoid function call */
end
else if pos(lr, m.comp.idChars) > 0 then
if pos(rl, m.comp.idChars'(') > 0 then
return le || sep || ri /* a,b -> a || b */
return le || mi || ri
endProcedure compCatRexx
/*--- push an empty stem on the stack --------------------------------*/
compNewStem: procedure expose m.
parse arg m
st = mAdd('COMP.STEM', '')
do ix=1 to arg()-1
m.st.ix = arg(ix+1)
end
m.st.0 = ix-1
return st
endProcedure compNewStem
/* copy comp end ******************************************************/
/* copy scan begin ****************************************************
Scan: scan an input:
scanLine(m,ln) : begin scanning a single line (string)
scanRead??(m,ln): begin scanning all lines of an opened reader
scanAtEnd(m) : returns whether we reached end of input
scanLit(m,lit) : scan Literal lit if present or return 0
scanChar(m,n) : scan next n characters
scanName(m) : scan a name
ScanNat(m) : scan a natural number (without sign)
scanString(m,q): scan a String with quote q. (with doubble = 1)
scanVerify(m,c,o): verify(...,c,o,...)
scanKeyValue(m): scan a key = value clause (with spaces)
scanWord(m,u) : scan a space delimited word or a string,
if u=1 then uppercase non-strings
scanErr(m, txt): error with current scan location
m is an adress, to store our state
if a scan function succeeds, the scan posititon is moved
returns: true if scanned, false otherwise
m.m.tok ==> last token
m.m.val ==> last value for scanString/Word/KeyValue
m.key ==> key for scanKeyValue
m.m.pos ==> scan position
m.m.src ==> scan source
***********************************************************************/
scanIni: procedure expose m.
if m.scan.ini == 1 then
return
m.scan.ini = 1
m.scan.alfLC = 'abcdefghijklmnopqrstuvwxyz'
m.scan.alfUC = translate(m.scan.alfLC)
m.scan.alfa = m.scan.alfLC || m.scan.alfUC
m.scan.alfNum = m.scan.alfa || '0123456789'
return
endProcedure scanIni
scanReset: procedure expose m.
parse arg m, n1, np, co
m.m.rdr = ''
m.m.jReading = 0 /* if called without jReset */
m.m.jWriting = 0
return scanOpts(m, n1, np, co)
endProcedure scanReset
scanOpts: procedure expose m.
parse arg m, m.m.scanName1, namePlus, m.m.scanComment
if m.m.scanName1 == '' then
m.m.scanName1 = m.scan.alfa
if namePlus == '' then
m.m.scanNameR = m.m.scanName1 || '0123456789'
else
m.m.scanNameR = m.m.scanName1 || namePlus
return m
endProcedure scanOpts
/*--- begin scanning a single line -----------------------------------*/
scanSrc: procedure expose m.
parse arg m, m.m.src
return scanOpen(m)
endProcedure scanSrc
scanOpen: procedure expose m.
parse arg m
m.m.tok = ''
m.m.val = ''
m.m.key = ''
m.m.pos = 1
m.m.atEnd = m.m.rdr == ''
m.m.jReading = 1
return m
endProcedure scanOpen
/*--- return the next len characters ---------------------------------*/
scanLook: procedure expose m.
parse arg m, len
if len == '' then
return substr(m.m.src, m.m.pos)
else
return substr(m.m.src, m.m.pos,
, min(len, 1 + length(m.m.src) - m.m.pos))
endProcedure scanLook
/*--- scan the literal lit ------------------------------------------*/
scanLit: procedure expose m.
parse arg m
do ax=2 to arg()
if abbrev(substr(m.m.src, m.m.pos), arg(ax)) then do
m.m.tok = arg(ax)
m.m.pos = m.m.pos + length(arg(ax))
return 1
end
end
m.m.tok = ''
return 0
endProcedure scanLit
/*--- scan the next len characters -----------------------------------*/
scanChar: procedure expose m.
parse arg m, len
nx = 1 + length(m.m.src)
if len \= '' then
nx = min(m.m.pos + len, nx)
m.m.tok = substr(m.m.src, m.m.pos, nx - m.m.pos)
m.m.pos = nx
return m.m.tok \== ''
endProcedure scanChar
/*--- scan a string with quote char qu -------------------------------*/
scanString: procedure expose m.
parse arg m, prefs
m.m.tok = ''
bx = m.m.pos
if prefs = '' then do
qu = substr(m.m.src, bx, 1)
if pos(qu, "'""") < 1 then
return 0
ax = bx + 1
end
else do
do px=1 until abbrev(substr(m.m.src, bx), p1)
p1 = word(prefs, px)
if p1 = '' then
return 0
end
qu = right(p1, 1)
ax = bx + length(p1)
end
m.m.val = ''
do forever
qx = pos(qu, m.m.src, ax)
if qx < 1 then
return scanErr(m, 'ending Apostroph('qu') missing')
m.m.val = m.m.val || substr(m.m.src, ax, qx-ax)
if qx >= length(m.m.src) then
leave
else if substr(m.m.src, qx+1, 1) <> qu then
leave
ax = qx+2
m.m.val = m.m.val || qu
end
m.m.tok = substr(m.m.src, bx, qx+1-bx)
m.m.pos = qx+1
return 1
endProcedure scanString
/*--- scan a Name, first char in *.scanName1, rest in *.scanNameR ----*/
scanName: procedure expose m.
parse arg m
if pos(substr(m.m.src, m.m.pos, 1),
, m.m.scanName1) <= 0 then do
m.m.tok = ''
return 0
end
return scanVerify(m, m.m.scanNameR)
endProcedure scanName
/*--- scan with verify, vOpt is passed to verify ---------------------*/
scanVerify: procedure expose m.
parse arg m, alpha, vOpt, onlyIfMatch
if vOpt == '' then /* empty string does not take default */
nx = verify(m.m.src, alpha, , m.m.pos)
else
nx = verify(m.m.src, alpha, vOpt, m.m.pos)
if nx = 0 then
if onlyIfMatch == 1 then
nx = m.m.pos
else
nx = length(m.m.src) + 1
m.m.tok = substr(m.m.src, m.m.pos, nx - m.m.pos)
m.m.pos = nx
return m.m.tok \== ''
endProcedure scanVerify
/*--- scan a natural number (no sign, decpoint ...) ------------------*/
scanNat: procedure expose m.
parse arg m, chEn
if \ scanVerify(m, '0123456789') then
return 0
if chEn \== 0 then
if pos(scanLook(m , 1), m.m.scanNameR) > 0 then
call scanErr m, 'illegal number end after' m.m.tok
return 1
endProcedure ScanNat
/*--- scan an integer (optional sign, no decpoint ...) ---------------*/
scanInt: procedure expose m.
parse arg m, chEn
call scanLit m, '+', '-'
si = m.m.tok
if \ scanNat(m, chEn) then do
m.m.pos = m.m.pos - si
return 0
end
m.m.tok = si || m.m.tok
return 1
endProcedure scanInt
/*--- scan a number (optional sign, decpoint, exponent) ------------*/
scanNum: procedure expose m.
parse arg m, chEn
sx = m.m.pos
call scanLit m, '+', '-'
po = scanLit(m, '.')
if \ scanNat(m, 0) then do
m.m.pos = sx
return 0
end
if \ po then
if scanLit(m, '.') then
call scanNat m, 0
if scanLit(m, 'e', 'E') then
if \ scanInt(m, 0) then
call scanErr m, 'exponent expected after' ,
substr(m.m.src, sx, m.m.pos-sx)
m.m.tok = substr(m.m.src, sx, m.m.pos-sx)
m.m.val = translate(m.m.tok)
if chEn \== 0 then
if pos(scanLook(m , 1), m.m.scanNameR) > 0 then
call scanErr m, 'illegal number end after' m.m.tok
return 1
endProcedure scanNum
/*--- scan a word and put value into *.val
a word is either delimited by space or stopper
or a string (with single or double quotes -------*/
scanWord: procedure expose m.
parse arg m, stopper
if scanString(m) then return 1
if \scanVerify(m, ' 'stopper, 'm') then return 0
m.m.val = m.m.tok
return 1
endProcedure scanWord
scanType: procedure expose m.
parse arg m, opt
m.m.tok = ''
if scanName(m) then
m.m.type = 'n'
else if scanNum(m) then
m.m.type = 0
else if scanString(m) then
m.m.type = left(m.m.tok, 1)
else if scanSpaceNl(m) then
m.m.type = 's'
else do
call scanChar m, 1
m.m.type = m.m.tok
end
return m.m.type
endProcedure scanType
scanBack: procedure expose m.
parse arg m, tok
if m.m.pos <= length(tok) then
call scanErr sc, 'cannot back "'tok'" length'
cx = m.m.pos - length(tok)
if substr(m.m.src, cx, length(tok)) \== tok then
call scanErr sc, 'cannot back "'tok'" value'
m.m.pos = cx
return
endProcedure scanBack
/*--- scan a key = word phrase
put key into m.key and word into m.m.val -------*/
scanKeyValue: procedure expose m.
parse arg m, def
if \ scanName(m) then
return 0
m.m.key = m.m.tok
if \ scanLit(scanSkip(m), '=') then do
m.m.val = def
m.m.tok = ' no='
end
else if \scanWord(scanSkip(m)) then
return scanErr(m, 'word expected after' m.m.key '=')
return 1
endProcedure scanKeyValue
/*--- return true/false whether we are at the end of input ----------*/
scanAtEnd: procedure expose m.
parse arg m
return m.m.atEnd & m.m.pos > length(m.m.src)
endProcedure scanAtEnd
/*--- skip over spaces, nl and comments (if option set) --------------*/
scanSpaceNL: procedure expose m.
parse arg m
lastTok = m.m.tok
if m.m.rdr \== '' then
interpret 'res = ' objMet(m, 'scanSpaceNl')
else
res = scanSpaceCom(m)
m.m.tok = lastTok
return res
endProcedure scanSpaceNL
scanSpaceCom: procedure expose m.
parse arg m
res = scanVerify(m, ' ')
if m.m.scanComment \== '' then
if abbrev(substr(m.m.src, m.m.pos), m.m.scanComment) then do
m.m.pos = 1 + length(m.m.src)
return 1
end
return res
endProcedure scanSpaceCom
/*--- skip over space, nl and comments and return m -----------------*/
scanSkip: procedure expose m.
parse arg m
call scanSpaceNl m
return m
endProcedure scanSkip
/*--- emit an error with current scan pos ----------------------------*/
scanErr: procedure expose m.
parse arg m, txt
m.m.err.0 = 0
call err 'scanErr' txt'\n'scanInfo(m, m'.ERR')
return 0
endProcedure scanErr
scanPos: procedure expose m.
parse arg m
if m.m.rdr \== '' then
interpret 'return' objMet(m, 'scanPos')
else if scanAtEnd(m) then
return E
else
return 1 m.m.pos
endProcedure scanPos
scanInfo: procedure expose m.
parse arg m
msg = 'last token' m.m.tok 'scanPosition' ,
strip(left(substr(m.m.src, m.m.pos), 40), 't')
if m.m.rdr == '' then
return msg'\npos' m.m.Pos 'in string' strip(m.m.src, 't')
else
interpret 'return msg ||' objMet(m, 'scanInfo')
endProcedure scanInfo
/* copy scan end ****************************************************/
/* copy scanRead begin ************************************************/
scanReadIni: procedure expose m.
if m.scanRead.ini = 1 then
return
m.scanRead.ini = 1
call scanIni
call jIni
ts = classNew('n Scan u f TOK v, f VAL v, f KEY v, f TYPE v')
call classNew 'n ScanRead u JRW', 'm',
, 'jReset call scanReadReset m, arg, arg2, arg3',
, 'jOpen call scanReadOpen m',
, 'jClose call jClose m.m.rdr',
, 'jRead call scanType m; call oClaCopy "'ts'", m, var;' ,
'return m.m.type \== ""',
, 'scanReadNl return scanReadNlImpl(m, unCond)',
, 'scanSpaceNl scanReadSpaceNl(m)',
, 'scanInfo scanReadInfo(m)',
, 'scanPos scanReadPos(m)'
call classNew "n EditRead u JRW", "m",
, "jRead return editRead(m, var)",
, "jOpen" ,
, "jReset m.m.linex = arg - 1"
return
endProcedure scanReadIni
/*--- begin scanning the lines of a reader ---------------------------*/
scanRead: procedure expose m.
parse arg rdr, n1, np, co
return scanOpts(oNew('ScanRead', rdr), n1, np, co)
scanReadReset: procedure expose m.
parse arg m, r, n1, np, co
call scanReset m, n1, np, co
m.m.rdr = r
return m
endProcedure scanReadReset
scanReadOpen: procedure expose m.
parse arg m, r, n1, np, co
call scanOpen m
m.m.atEnd = 0
m.m.lineX = 0
call jOpen m.m.rdr, m.j.cRead
call scanReadNl m, 1
return m
endProcedure scanReadOpen
/*--- scan over next newLine
if unCond \== 1 only if we are already at endOfLine
return true if we scanned a NL ------------------------------*/
scanReadNl: procedure expose m.
parse arg m, unCond
interpret objMet(m, 'scanReadNl')
endProcedure scanReadNl
/*--- implementation of scanReadNl ----------------------------------*/
scanReadNLimpl: procedure expose m.
parse arg m, unCond
if unCond \== 1 then
if m.m.pos <= length(m.m.src) then
return 0
if m.m.atEnd then
return 0
m.m.atEnd = \ jRead(m.m.rdr, m'.SRC')
if m.m.atEnd then do
m.m.pos = 1 + length(m.m.src)
end
else do
m.m.pos = 1
m.m.lineX = m.m.lineX + 1
end
return \ m.m.atEnd
endProcedure scanReadNLimpl
scanReadSpaceNl: procedure expose m.
parse arg m
fnd = 0
do forever
if scanSpaceCom(m) then
fnd = 1
if \ scanReadNl(m) then
return fnd
fnd = 1
end
endProcedure scanReadSpaceNl
scanReadPos: procedure expose m.
parse arg m, msg
if scanAtEnd(m) then
return E
else
return m.m.lineX m.m.pos
endProcedure scanReadPos
scanReadInfo: procedure expose m.
parse arg m, msg
if scanAtEnd(m) then
msg = msg'\natEnd after'
else
msg = msg'\npos' m.m.pos 'in'
return msg 'line' m.m.lineX':' strip(m.m.src, 't')
endProcedure scanReadInfo
/*--- use scan sqlEdit macro --> temporarily here --------------------*/
/*--- read next line from edit data ----------------------------------*/
editRead: procedure expose m.
parse arg m, var
m.m.lineX = m.m.lineX + 1
if adrEdit('(ll) = line' m.m.lineX, 12) ^= 0 then
return 0
m.var = ll
return 1
endProcedure editRead
/*--- search loop in edit macro --------------------------------------*/
scanSqlSeekId: procedure expose m.
parse arg m, lx, cmd, opts
if opts = '' then
opts = word
/* line 1 col 0, otherwise first word is skipped*/
if adrEdit("cursor =" max(trunc(lx), 1) 0, 12) = 12 then
return -1
do while adrEdit("seek" cmd opts, 4) = 0 /* find each command*/
call adrEdit "(fx) = cursor"
if m.debug then do
call adrEdit "(LI) = LINE" fx
call debug 'scanSqlSeekId after' lx 'found' cmd 'at' fx li
end
call jReset m.m.rdr, fx
call jOpen m, '<'
m.m.lineX = fx
do while word(scanPos(m), 1) <= fx & scanSqlClass(m)
if m.m.sqlClass = 'i' & m.m.val == cmd then
return fx
end
call jClose m
end
return -1
endProcedure scanSqlSeekId
/* copy scanRead end **************************************************/
/* copy scanWin begin *************************************************
scan the the concatenation of the lines of a reader
any token my be split over several line
except the end-of-line-comment-token
***********************************************************************/
scanWinIni: procedure expose m.
if m.scanWin.ini = 1 then
return
m.scanWin.ini = 1
call scanReadIni
call jIni
call classNew 'n ScanWin u JRW', 'm',
, 'jReset call scanWinReset m, arg, arg2, arg3',
, 'jOpen call scanWinOpen m, arg(3) ',
, 'jClose call scanWinClose m ',
, 'scanReadNl return scanWinNl(m, unCond)',
, 'scanSpaceNl scanWinSpaceNl(m)',
, 'scanInfo scanWinInfo(m)',
, 'scanPos scanWinPos(m)'
return
endProcedure scanWinIni
/*--- instanciate a new window scanner, open rdr ---------------------*/
scanWin: procedure expose m.
parse arg rdr, wiSz, wiBa, cuPo, cuLe
return scanWinOpts(oNew('ScanWin', rdr), wiSz, wiBa, cuPo, cuLe)
/*--- set the reader and attributes of window scanner m -------------*/
scanWinReset: procedure expose m.
parse arg m, r, wiSz, wiGa, cuPo, cuLe
call scanReset m
m.m.rdr = r
m.m.atEnd = 'still closed'
return scanWinOpts(m, wiSz, wiGa, cuPo, cuLe)
endProcedure scanWinReset
/*--- set the attributes of window scanner m ------------------------*/
scanWinOpts: procedure expose m.
parse arg m, wiSz, wiGa, cuPo, cuLe
wiSz = word(wiSz 5, 1)
wiGa = word(wiGa 1, 1)
m.m.cutPos = word(cuPo 1, 1)
m.m.cutLen = word(cuLe 72, 1)
m.m.winTot = (wiSz * 2 + wiGa) * m.m.cutLen
m.m.posLim = (wiSz + wiGa) * m.m.cutLen
m.m.posOff = wiGa * m.m.cutLen
return m
endProcedure scanWinOpts
/*--- open reader and start scanning --------------------------------*/
scanWinOpen: procedure expose m.
parse arg m, lx
call scanOpen m
m.m.atEnd = 0
if lx = '' then
m.m.lineX = 1
else
m.m.lineX = lx
m.m.pos = 1
m.m.src = ''
call jOpen m.m.rdr, m.j.cRead
call scanWinRead m
return m
endProcedure scanWinOpen
scanWinClose: procedure expose m.
parse arg m
m.m.atEnd = 'still closed'
call jClose m.m.rdr
return
endProcedure scanWinClose
/*--- move the source window: cut left side and append at right side
return number of characters cut at left ------------------------*/
scanWinRead: procedure expose m.
parse arg m
dlt = 0
if m.m.atEnd then
return 0
if m.m.pos >= m.m.posLim then do /* cut left side */
dlt = m.m.pos - (m.m.pos // m.m.cutLen + m.m.posOff)
m.m.src = substr(m.m.src, dlt+1)
m.m.pos = m.m.pos - dlt
m.m.lineX = m.m.lineX + dlt % m.m.cutLen
end
do while length(m.m.src) < m.m.winTot /* read and fill to len */
if \ jRead(m.m.rdr, m'.'one) then do
m.m.atEnd = 1
return dlt
end
m.m.src = m.m.src || substr(m.m.one, m.m.cutPos, m.m.cutLen)
end
call assert 'length(m.m.src) = m.m.winTot'
return dlt
endProcedure scanWinRead
/*--- return position of next line start -----------------------------*/
scanWinNLPos: procedure expose m.
parse arg m
return m.m.pos + m.m.cutLen - ((m.m.pos - 1) // m.m.cutLen)
/*--- scan over spaces and comments ----------------------------------*/
scanWinSpaceNL: procedure expose m.
parse arg m
res = 0
do forever
call scanWinRead m
if scanVerify(m, ' ') then do
res = 1
iterate
end
else if scanLit(m, '/*') then do
ex = pos('*/', m.m.src, m.m.pos+2)
if ex <= m.m.pos then
return scanErr(m, '*/ missing after /*')
m.m.pos = ex+2
res = 1
end
else do
cl = length(m.m.scanComment)
np = scanWinNlPos(m)
if \ ( cl>0 & m.m.pos+cl <= np & m.m.scanComment ,
== substr(m.m.src, m.m.pos, cl)) then
return res
m.m.pos = np
res = 1
end
end
endProcedure scanWinSpaceNl
/*--- return current position in input ------------------------------*/
scanWinPos: procedure expose m.
parse arg m
if scanAtEnd(m) then
return 'E'
else
ps = m.m.pos - 1
return (m.m.lineX + (ps % m.m.cutLen)) (ps // m.m.cutLen + 1)
endProcedure scanWinPos
/*--- return a description of the current scan position --------------*/
scanWinInfo: procedure expose m.
parse arg m
p = scanWinPos(m)
if p == 'E' then do
res = 'atEnd after'
p = m.m.lineX - 1 + length(m.m.src) % m.m.cutLen
end
else do
res = 'pos' word(p, 2) 'in'
p = word(p, 1)
end
return '\n'res 'line' p':' strip(substr(m.m.src,
, 1 + (p - m.m.lineX) * m.m.cutLen, m.m.cutLen), 't')
endProcedure scanWinInfo
/* copy scanWin end *************************************************/
/* copy scanSql begin *************************************************/
/*--- initialize with reader inRdr ----------------------------------*/
scanSql: procedure expose m.
parse arg inRdr
return scanSqlReset(scanWin(inRdr), inRdr)
scanSqlReset: procedure expose m.
parse arg m, r, scanWin
if scanWin \== 0 then
call scanWinOpts m, 5, 2, 1, 72
m.m.rdr = r
return scanOpts(m, , '0123456789_' , '--')
endProcedure scanSqlReset
/*--- scan a sql token put class in m.sqlclass:
'i': ordinary identifier e.g. Name
'd': delimited identifier e.g. "Delimited"
'q': qualified identifier e.g. abc."efg"
'u': integer units e.g. 8G
'n': number e.g. -234 or .2e3
's': string e.g. 'abc''ef'
'' : at end
: any other character e.g. ;
----------------------------------------------------------------*/
scanSqlClass: procedure expose m.
parse arg m, retSpace
m.m.val = ''
if scanSpaceNl(m) & retSpace = 1 then do
m.m.sqlClass = 'b'
return 1
end
c2 = scanLook(m ,2)
if scanString(m, "' x' X'") then do
m.m.sqlClass = 's'
if \abbrev(m.m.tok, "'") then
m.m.val = x2c(m.m.val)
end
else if scanSqlQuId(m) then do
if m.m.val.0 > 1 then
m.m.sqlClass = 'q'
else if abbrev(m.m.tok, '"') then
m.m.sqlClass = 'd'
else
m.m.sqlClass = 'i'
end
else if scanSqlNum(m, 0) then
m.m.sqlClass = 'n'
else if scanChar(m, 1) then
m.m.sqlClass = m.m.tok
else if scanAtEnd(m) then do
m.m.sqlClass = ''
return 0
end
else
call scanErr m, 'cannot scan sql'
return 1
endProcedure scanSqlClass
scanSqlSkipBrackets: procedure expose m.
parse arg m, br
if br \== '' then
nop
else if scanLit(m, '(') then
br = 1
else
return 0
do while scanSqlClass(m) & m.m.sqlClass \== ';'
if m.m.sqlClass = '(' then br = br + 1
else if m.m.sqlClass \== ')' then iterate
else if br > 1 then br = br - 1
else return 1
end
call scanErr m, '; or eof, but' br 'closing ) expected'
endProcedure skipBrackets
/*--- scan an ordinary sql identifier e.g. abc, ef_12 ----------------*/
scanSqlId: procedure expose m.
parse arg m
if \ scanName(m) then
return 0
m.m.val = translate(m.m.tok)
return 1
endProcedure scanSqlId
/*--- scan a delimited or ordinay sql identifier ---------------------*/
scanSqlDeId: procedure expose m.
parse arg m
if scanSqlId(m) then
return 1
if \ scanString(m, '"') then
return 0
m.m.val = strip(m.m.val, 't')
return 1
endProcedure scanSqlDeId
/*--- scan a qualified sql identifier --------------------------------*/
scanSqlQuId: procedure expose m.
parse arg m
res = ''
rto = ''
do qx=1
if \ scanSqlDeId(m) then do
if qx <> 1 then
call scanErr m, 'id expected after .'
return 0
end
m.m.val.qx = m.m.val
res = res'.'m.m.val
rto = rto'.'m.m.tok
if \ scanLit(scanSkip(m), '.') then
leave
call scanSpaceNl m
end
m.m.val.0 = qx
m.m.val = substr(res, 2)
m.m.tok = substr(rto, 2)
return 1
endProcedure scanSqlQuId
/*--- scan a sql number ----------------------------------------------*/
scanSqlNum: procedure expose m.
parse arg m, checkEnd, noSp
si = ''
if noSp == 1 then
call err 'deimplement noSp, use scanNum instead'
if scanLit(m, '+', '-') then do
si = m.m.tok
call scanSpaceNl m
ch = scanLook(m, 2)
if left(ch, 1) == '.' then
ch = substr(ch, 2)
if pos(left(ch, 1), '0123456789') < 1 then do
call scanBack m, si
m.m.val = ''
return 0
end
end
res = scanNum(m, checkEnd)
m.m.val = si || m.m.val
return res
endProcedure scanSqlNum
/*--- scan a sql number with a unit which may follow without space ---*/
scanSqlNumUnit: procedure expose m.
parse arg m, both, units
if \ scanSqlNum(m, 0) then
return 0
nu = m.m.val
sp = scanSpaceNl(m)
if scanSqlId(m) then do
if units == '' | wordpos(m.m.val, units) > 0 then
nu = nu m.m.val
else if both | \ sp then
call scanErr m, 'scanSqlNumUnit after' nu 'bad unit' m.m.val
else
call scanBack m, m.m.tok
end
else if both then
call scanErr m, 'scanSqlNumUnit no unit after' nu
else if \sp & pos(scanLook(m, 1), m.m.scanNameR) > 0 then
call scanErr m, 'scanSqlNumUnit bad number end after' nu
m.m.val = nu
return 1
endProcedure scanSqlNumUnit
/*--- scan a sql number with a unit which may follow without space ---*/
scanSqlStmt: procedure expose m.
parse arg m, delim
if delim == '' then
delim = ';'
res = ''
vChrs = strip('''"/'delim || left(m.m.scanComment, 1))
do forever
if scanSpaceNl(m) then
if right(res, 1) \== ' ' then
res = res' '
if scanVerify(m, vChrs, 'm') then
res = res || m.m.tok
else if scanString(m) then
res = res || m.m.tok
else if scanLit(m, delim) then do
m.m.val = res
return 1
end
else if scanChar(m, 1) then do
res = res || m.m.tok
end
else do
m.m.val = res
return res \= ''
end
end
endProcedure scanSqlStmt
/* copy scanSql end *************************************************/
/* copy scanUtil begin *************************************************
scan db2 utility input statements using scan and a reader
**********************************************************************/
/*--- initialize with reader inRdr ----------------------------------*/
scanUtilReader: procedure expose m.
parse arg m, inRdr
call scanReader m, inRdr
call scanOptions sc, , , '--'
call scanUtilReset m
return m
endProcedure scanUtilReader
scanUtilSql: procedure expose m.
parse arg inRdr
m = scanSql(inRdr)
call scanUtilReset m
return m
endProcedure scanUtilReader
scanUtilReset: procedure expose m.
parse arg m
m.m.utilBrackets = 0
m.scanUtil = 'BACKUP CATENFM CATMAINT CHECK' ,
'COPY COPYTOCOPY DIAGNOSE EXEC LISTDEF LOAD' ,
'MERGECOPY MODIFY OPTIONS QUIESCE REBUILD' ,
'RECOVER REORG REPAIR REPORT RESTORE' ,
'RUNSTATS STOSPACE TEMPLATE UNLOAD'
return m
endProcedure scanUtilReset
/*--- scan next token and put its class in m.sc.utilClass:
'u' a utility name
'n' a name
'"' a quoted name
"'" an apostroph'd string
'.' a .
',' a ,
'v' a value
'' at end
---------------------------------------------------------------*/
scanUtil: procedure expose m.
parse arg sc
m.sc.utilSpace = scanSpaceNl(sc)
ty = '?'
if scanLit(sc, '(') then do
m.sc.utilBrackets = m.sc.utilBrackets + 1
end
else if scanLIT(sc, ')') then do
m.sc.utilBrackets = m.sc.utilBrackets - 1
if m.sc.utilBrackets < 0 then
call scanErr sc, 'unmatched closing bracket )'
end
else if scanLit(sc, ',') then do
end
else if scanLit(sc, '.') then do
end
else if scanString(sc, "'") then do
end
else if scanString(sc, '"') then do
end
else if scanName(sc) then do
m.sc.val = translate(m.sc.tok)
if m.sc.utilBrackets > 0 then
ty = 'n'
else if 0 < wordPos(m.sc.val, m.scanUtil) then
ty = 'u'
else
ty = 'n'
end
else if scanVerify(sc, ' (),''"', 'm') then do
ty = 'v'
m.sc.val = translate(m.sc.tok)
end
else if \scanAtEnd(sc) then do
call scanErr sc, 'scanUtil stopped before end'
end
else do
ty = ''
m.sc.val = ''
end
if ty == '?' then
m.sc.utilClass = left(m.sc.tok, 1)
else
m.sc.utilClass = ty
return m.sc.utilClass
endProcedure scanUtil
/*--- scan a value or a bracketed list of values ---------------------*/
scanUtilValue: procedure expose m.
parse arg sc, remApo, nl
if remApo = '' | rempApo = 0 then
remApo = "nv"
else if rempApo = 1 then
remApo = "nv'"
if '(' \== scanUtil(sc) then
return scanUtilValueOne(sc, remApo)
v = ''
brx = m.sc.utilBrackets
oLine = word(scanPos(sc), 1)
do forever
call scanUtil sc
one = scanUtilValueOne(sc, remApo)
if one == '' then
call scanErr sc, 'eof in brackets'
else if brx > m.sc.utilBrackets then
return v
nLine = word(scanPos(sc), 1)
if \ m.sc.utilSpace then
v = v || one
else if nl \== '' & oLine <> nLine then
v = v || nl || one
else
v = v' 'one
oLine = nLine
end
endProcedure scanUtilValue
scanUtilValueOne: procedure expose m.
parse arg sc, valTy
if m.sc.utilClass == '' then
return ''
else if m.sc.utilClass == 'u' then
call scanErr sc, 'util in scanUtilValueOne'
if pos(m.sc.utilClass, valTy) > 0 then
return m.sc.val
else
return m.sc.tok
endProcedure scanUtilValueOne
/*--- skip over nested brackets --------------------------------------*/
scanUtilSkipBrackets: procedure expose m.
parse arg m, br, doCat
if br \== '' then
lim = m.m.utilBrackets - br
else if scanLit(m, '(') then do
lim = m.m.utilBrackets
m.m.utilBrackets = lim + 1
end
else
return 0
doCat = doCat == 1
res = ''
do while scanUtil(m) \== ''
if m.m.utilBrackets <= lim then do
if doCat then
m.m.val = res
return 1
end
if doCat then
res = res m.m.tok
end
return scanErr(m, 'eof with' m.m.utilBrackets 'open (')
endProcedure skipBrackets
/*--- analyze a punch file write intoField to stdOut -----------------*/
scanUtilInto: procedure expose m.
parse arg m
if m.m.utilBrackets \== 0 then
call scanErr m, 'scanUtilInto with brackets' m.m.utilBrackets
/*sc = scanUtilReader(m.j.in)
call jOpen sc, 'r'
*/ do forever
cl = scanUtil(m)
if cl == '' then
return 0
if cl = 'n' & m.m.tok == 'INTO' then
leave
end
if scanUtil(m) \== 'n' | m.m.tok \== 'TABLE' then
call scanErr m, 'bad into table '
if \ scanSqlQuId(scanSkip(m)) then
call scanErr m, 'table name expected'
if m.m.utilBrackets \== 0 then
call scanErr m, 'into table in brackets' m.m.utilBrackets
m.m.tb = m.m.val
m.m.part = ''
m.m.when = ''
do forever
cl = scanUtil(m)
if cl == '' then
call scanErr m, 'eof after into'
if cl == 'n' & m.m.tok == 'PART' then do
if scanUtil(m) == 'v' then
m.m.part = m.m.val
else
call scanErr m, 'bad part'
end
else if cl == 'n' & wordPos(m.m.val, 'WHEN WORKDDN') > 0 then do
call scanUtilSkipBrackets m
end
else if cl == '(' then do
leave
end
end
oX = m.m.lineX
oL = overlay('', m.m.src, 1, m.m.pos-2)
do while m.m.utilBrackets > 0
call scanUtil m
if oX \== m.m.lineX then do
call out strip(oL, 't')
oX = m.m.lineX
oL = m.m.src
end
end
call out left(oL, m.m.pos)
/* call jClose sc
*/ return 1
endProcedure scanUtilInto
/* copy scanUtil end **************************************************/
/* copy pipe begin *****************************************************
***********************************************************************/
pipeIni: procedure expose m.
if m.pipe.ini == 1 then
return
m.pipe.ini = 1
call catIni
call classNew "n PipeFrame u"
call mapReset env.vars
m.env.with.0 = 0
call mapReset env.c2w
call mNewArea 'ENV.WICO', '='
m.pipe.0 = 0
call pipeBeLa /* by default pushes in and out */
return
endProcedure pipeIni
pipeOpen: procedure expose m.
parse arg e
if m.e.inCat then
call jClose m.e.in
m.e.inCat = 0
if m.e.in == '' then
m.e.in = m.j.in
call jOpen m.e.in, m.j.cRead
if m.e.out == '' then
m.e.out = m.j.out
call jOpen m.e.out, m.e.outOp
return e
endProcedure pipeOpen
pipePushFrame: procedure expose m.
parse arg e
call mAdd pipe, e
m.j.in = m.e.in
m.j.out = m.e.out
return e
endProcedure pipePushFrame
pipeBegin: procedure expose m.
e = pipeFrame()
do ax=1 to arg()
call pipeAddIO e, arg(ax)
end
if m.e.out \== '' then
call err 'pipeBegin output redirection' m.e.in
call pipeAddIO e, '>' Cat()
return pipePushFrame(pipeOpen(e))
endProcedure pipeBegin
pipe: procedure expose m.
px = m.pipe.0
f = m.pipe.px
call pipeClose f
m.f.in = jOpen(m.f.out, m.j.cRead)
m.f.out = jOpen(Cat(), '>')
m.j.in = m.f.in
m.j.out = m.f.out
return
endProcedure pipe
pipeLast: procedure expose m.
px = m.pipe.0
f = m.pipe.px
m.f.in = pipeClose(f)
m.f.out = ''
do ax=1 to arg()
if word(arg(ax), 1) = m.j.cRead then
call err 'pipeLast input redirection' arg(ax)
else
call pipeAddIO f, arg(ax)
end
if m.f.out == '' then do
preX = px-1
preF = m.pipe.preX
m.f.out = m.preF.out
end
call pipeOpen f
m.j.in = m.f.in
m.j.out = m.f.out
return
endProcedure pipeLast
pipeBeLa: procedure expose m.
e = pipeFrame()
do ax=1 to arg()
call pipeAddIO e, arg(ax)
end
return pipePushFrame(pipeOpen(e))
endProcedure pipeBeLa
/*--- activate the last pipeFrame from stack
and return outputbuffer from current pipeFrame --------------*/
pipeEnd: procedure expose m.
ox = m.pipe.0 /* wkTst??? streamLine|| */
if ox <= 1 then
call err 'pipeEnd on empty stack' ex
ex = ox - 1
m.pipe.0 = ex
e = m.pipe.ex
m.j.in = m.e.in
m.j.out = m.e.out
return pipeClose(m.pipe.ox)
endProcedure pipeEnd
pipeFrame: procedure expose m.
m = oMutate(mBasicNew("PipeFrame"), "PipeFrame")
m.m.in = ''
m.m.inCat = 0
m.m.out = ''
m.m.outOp = '>'
return m
endProcedure pipeFrame
pipeClose: procedure expose m.
parse arg m, finishLazy
call jClose m.m.in
call jClose m.m.out
return m.m.out
endProcedure pipeClose
pipeAddIO: procedure expose m.
parse arg m, opt file
if opt == m.j.cRead then do
if m.m.in == '' then
m.m.in = o2file(file)
else if m.m.inCat then
call catWriteAll m.m.in, o2file(file)
else do
m.m.in = jOpen(cat(m.m.in, o2file(file)), m.j.cApp)
m.m.inCat = 1
end
return m
end
if \ (opt = m.j.cWri | opt == m.j.cApp) then
call err 'pipeAddIO('opt',' file') bad opt'
else if m.m.out \== '' then
call err 'pipeAddIO('opt',' file') duplicate output'
m.m.out = o2file(file)
m.m.outOp = opt
return m
endProcedure pipeAddIO
/*--- write all from rdr (rsp in) to out, not lazy ----------------*/
pipeWriteNow: procedure expose m.
parse arg rdr
call jWriteNow m.j.out, if(rdr == '', m.j.in, rdr)
return
endProcedure pipeWriteNow
/*--- write all from rdr (rsp in) to out, possibly lazy -----------*/
pipeWriteAll: procedure expose m.
parse arg rdr
call jWriteAll m.j.out, if(rdr == '', m.j.in, rdr)
return
endProcedure pipeWriteAll
pipePreSuf: procedure expose m.
parse arg le, ri
do while in(v)
call out le || m.v || ri
end
return
endProcedure pipePreSuf
/*--- out interface of pipe -----------------------------------------*/
outIni: procedure expose m.
call pipeIni
return
endProcedure outIni
outDst: procedure expose m.
parse arg wrt
oldOut = m.j.out
if wrt == '' then
wrt = jOpen(oNew('JSay'), '>')
m.j.out = wrt
return oldOut
endProcedure outDst
/*--- return a JRW from rdr or in ------------------------------------*/
env2Rdr: procedure expose m.
parse arg rdr
if envInp(rdr) then
return jBuf(ggStr)
else
return o2file(ggObj)
endProcedure env2Rdr
/* env2str is part of out interface --> inp2str */
inp2str: procedure expose m.
parse arg rdr, fmt
if envInp(rdr) then
return ggStr
else
return o2String(ggObj, fmt)
endProcedure inp2str
env2Buf: procedure expose m.
parse arg rdr
if envInp(rdr) then
return jBuf(ggStr)
if classInheritsOf(ggCla, class4Name('JBuf')) ,
& m.ggObj.jUsers < 1 then
return ggObj
b = jOpen(jBuf(), m.j.cWri)
call jWriteNow b, o2File(ggObj)
return jClose(b)
endProcedure env2Buf
/*--- return true iff input is a kind of string ---------------------*/
envInp: procedure expose m. expose ggStr ggObj ggCla
parse arg inp
if inp == '' then
inp = m.j.in
return oStrOrObj(inp)
endProcedure envInp
envIsDefined: procedure expose m.
parse arg na
return '' \== mapValAdr(env.vars, na)
endProcedure envIsDefined
envPushWith: procedure expose m.
parse arg obj, cl, fn, elCl
tos = m.env.with.0 + 1
m.env.with.0 = tos
m.env.with.tos.fun = fn
m.env.with.tos.muElCl = ''
if fn == '' then do
call envSetWith obj, cl
return
end
if cl == '' then
cl = objClass(obj)
if fn == 'as1' then do
call envSetWith obj, cl
m.env.with.tos.muElRef = m.cl.valueCl \== '',
& m.cl.valueCl \== m.class.classV
if m.env.with.tos.muElRef then
m.env.with.tos.muElCl = m.cl.valueCl
else
m.env.with.tos.muElCl = cl
return
end
else if fn \== 'asM' then
call err 'bad fun' fn
if m.cl.stemCl == '' then
call err 'class' className(cl) 'not stem'
cc = m.cl.stemCl
isRef = m.cc == 'r'
m.env.with.tos.muElRef = isRef
if m.cc \== 'r' then
m.env.with.tos.muElCl = cc
else if elCl \== '' then
m.env.with.tos.muElCl = elCl
else if m.cc.class == '' then
call err 'elCl null for envPushWith('obj ','cl ','multi', ...)'
else
m.env.with.tos.muElCl = m.cc.class
m.env.with.tos.class = ''
m.env.with.tos.muCla = cl
m.env.with.tos.muObj = obj
return
endProcedure envPushWith
envSetWith: procedure expose m.
parse arg obj, cl
if cl == '' & obj \== '' then
cl = objClass(obj)
tos = m.env.with.0
m.env.with.tos = obj
m.env.with.tos.class = cl
return
endProcedure envSetWith
envWithObj: procedure expose m.
tos = m.env.with.0
if tos < 1 then
call err 'no with in envWithObj'
return m.env.with.tos
endProcedure envWithObj
envAccPath: procedure expose m. m cl
parse arg pa, stop, nllNw
nullNew = nllNw == 1
dx = verify(pa, m.class.cPath, 'm')
if dx = 0 then do
n1 = pa
p2 = ''
end
else do
n1 = left(pa, dx-1)
p2 = substr(pa, dx)
end
wCla = ''
do wx = m.env.with.0 by -1 to if(stop==1, m.env.with.0, 1)
wCla = m.env.with.wx.class
if symbol('m.wCla.f2c.n1') == 'VAR' then
return oAccPath(m.env.with.wx, pa, m.env.with.wx.class)
end
if stop == 1 then
return 'no field' n1 'in class' className(wCla)
vv = mapValAdr(env.vars, n1)
if vv \== '' then
if p2 == '' then
return oAccPath(vv, '', m.class.classR)
else
return oAccPath(vv, '|'p2, m.class.classR)
else if nullNew & p2 == '' then
return oAccPath(mapValAdr(env.vars, n1,'a'), p2,m.class.classR)
else
return 'undefined variable' pa
endProcedure envAccPath
envWithNext: procedure expose m.
parse arg beEn, defCl, obj
tos = m.env.with.0
if tos < 1 then
call err 'envWithNext with.0' tos
st = m.env.with.tos.muObj
if beEn == 'b' then do
if m.env.with.tos.fun == 'asM' then
m.st.0 = 0
if m.env.with.tos.muElCl == '' then
m.env.with.tos.muElCl = defCl
end
else if m.env.with.tos.fun == 'asM' then
m.st.0 = m.st.0 + 1
else if m.env.with.tos.fun == '' then
call outO m.env.with.tos
else if beEn = '' then
call err 'no multi allowed'
if beEn == 'e' then
return
if m.env.with.tos.fun == 'as1' then do
if m.env.with.tos == '' then
call err 'implement withNext null'
return
end
/* if obj \== '' then do
if \ m.env.with.tos.muElRef then
call err 'obj but not ref'
m.nn = obj
call envSetWith obj
end
*/
if m.env.with.tos.fun == '' then do
call envSetWith mNew(m.env.with.tos.muElCl)
return
end
nn = st'.' || (m.st.0 + 1)
if m.env.with.tos.muElRef then do
m.nn = mNew(m.env.with.tos.muElCl)
call envSetWith m.nn
end
else do
call mReset nn, m.env.with.tos.muElCl
call envSetWith nn
end
return
endProcedure envWithNext
envPushName: procedure expose m.
parse arg nm, multi, elCl
res = envAccPath(nm, , 1)
if res \== 1 then
return err(res 'in envPushName('nm',' multi')')
do while m.cl == 'r'
if m.m == '' then do
res = oRefSetNew(m, cl)
if res \== 1 then
call err res 'in envPushName('nm',' multi')'
end
m = m.m
cl = objClass(m)
end
call envPushWith m, cl, multi, elCl
return
endProcedure envPushName
envNewWiCo: procedure expose m.
parse arg co, cl
k1 = strip(co cl)
n = mapGet('ENV.C2W', k1, '')
if n \== '' then
return n
k2 = k1
if co \== '' then do
k2 = strip(m.co.classes cl)
n = mapGet('ENV.C2W', k2, '')
end
k3 = k2
if n == '' then do
cx = wordPos(cl, m.co.classes)
if cx > 0 then do
k3 = space(subWord(m.co.classes, 1, cx-1),
subWord(m.co.classes, cx+1) cl, 1)
n = mapGet('ENV.C2W', k3, '')
end
end
if n == '' then
n = envNewWico2(co, k3)
call mapAdd 'ENV.C2W', k1, n
if k2 \== k1 then
call mapPut 'ENV.C2W', k2, n
if k3 \== k2 & k3 \== k1 then
call mapPut 'ENV.C2W', k3, n
return n
endProcedure envNewWiCo
envNewWiCo2: procedure expose m.
parse arg co, clLi
n = mNew('ENV.WICO')
if co == '' then
m.n.level = 1
else
m.n.level = m.co.level + 1
m.n.classes = clLi
na = ''
do cx = 1 to words(clLi)
c1 = word(clLi, cx)
na = na className(c1)
do qx=1 to 2
ff = c1 || word('.FLDS .STMS', qx)
do fx = 1 to m.ff.0
fn = m.ff.fx
if fn == '' then
iterate
fn = substr(fn, 2)
m.n.f2c.fn = cx
end
end
end
m.n.classNames = space(na, 1)
return n
endProcedure envNewWiCo2
envPopWith:procedure expose m.
tos = m.env.with.0
m.env.with.0 = tos - 1
return
endProcedure envPopWith
envGet: procedure expose m.
parse arg na
res = envAccPath(na)
if res == 1 then
res = oAccStr(m, cl)
if res == 1 then
return str
return err(res 'in envGet('na')')
endProcedure envGet
envGetO: procedure expose m.
parse arg na, opt
res = envAccPath(na, , opt == '-b')
if res == 1 then
res = oAccO(m, cl, opt)
if res == 1 then
return ref
return err(res 'in envGetO('na')')
endProcedure envGetO
envPutO: procedure expose m.
parse arg na, ref, stop
res = envAccPath(na, stop, 1)
if res == 1 then
res = ocPutO(m, cl, ref)
if res = 1 then
return ref
return err(res 'in envPutO('na',' ref',' stop')')
endProcedure envPutO
envPut: procedure expose m.
parse arg na, va, stop
res = envAccPath(na, stop , 1)
if res == 1 then
res = ocPut(m, cl, va)
if res == 1 then
return va
return err(res 'in EnvPut('na',' va',' stop')')
endProcedure envPut
envRead: procedure expose m.
parse arg na
return in("ENV.VARS."na)
envReadO: procedure expose m.
parse arg na
res = inO()
if res == '' then
return 0
call envPutO na, res
return 1
endProcedure envReadO
envHasKey: procedure expose m.
parse arg na
return mapHasKey(env.vars, na)
envRemove: procedure expose m.
parse arg na
return mapRemove(env.vars, na)
/* copy pipe end ******************************************************/
/* copy cat begin ****************************************************
***********************************************************************/
/*--- create a new cat -----------------------------------------------*/
cat: procedure expose m.
m = oNew('Cat') /* calls catReset */
do ax=1 to arg()
call catWriteAll m, arg(ax)
end
return m
endProcedure cat
catReset: procedure expose m.
parse arg m
m.m.RWs.0 = 0
m.m.catWr = ''
m.m.catRd = ''
m.m.catIx = -9e9
m.m.catKeepOpen = ''
return m
endProcedure catReset
catClose: procedure expose m.
parse arg m
if m.m.catWr \== '' then do
call jClose m.m.catWr
call mAdd m'.RWS', m.m.catWr
m.m.catWr = ''
end
if m.m.catRd \== '' then do
call jClose m.m.catRd
m.m.catRd = ''
end
m.m.catIx = -9e9
return m
endProcedure catClose
catOpen: procedure expose m.
parse arg m, oo
if oo == m.j.cRead then do
m.m.catIx = 0
call catNextRdr m
m.m.jReading = 1
end
else if oo == m.j.cWri | oo == m.j.cApp then do
if oo == m.j.cWri then
m.m.RWs.0 = 0
m.m.catIx = -9e9
m.m.jWriting = 1
end
else do
call err 'catOpen('m',' oo') bad opt'
end
return m
endProcedure catOpen
/*--- return and open next reader ------------------------------------*/
catNextRdr: procedure expose m.
parse arg m
if m.m.catRd \== '' then
call jClose m.m.catRd
cx = m.m.catIx + 1
m.m.catIx = cx
if cx > m.m.RWs.0 then do
m.m.catRd = ''
return 0
end
m.m.catRd = m.m.RWs.cx
if cx = word(m.m.catKeepOpen, 1) then
m.m.catKeepOpen = subWord(m.catKeepOpen, 2)
else
call jOpen m.m.catRd , m.j.cRead
return 1
endProcedure catNextRdr
catReadO: procedure expose m.
parse arg m
do while m.m.catRd \== ''
res = jReadO(m.m.catRd)
if res \== '' then
return res
call catNextRdr m
end
return ''
endProcedure catReadO
catWrite: procedure expose m.
parse arg m, line
if m.m.catWr == '' then
m.m.catWr = jOpen(jBuf(), m.j.cWri)
call jWrite m.m.catWr, line
return
endProcedure catWrite
catWriteO: procedure expose m.
parse arg m, var
if m.m.catWr == '' then
m.m.catWr = jOpen(jBuf(), m.j.cWri)
call jWriteO m.m.catWr, var
return
endProcedure catWriteO
/*--- write contents of a reader to cat
or keep it for later reading -------------------------------*/
catWriteAll: procedure expose m.
parse arg m
if m.m.catWr \== '' then do
call mAdd m'.RWS', jClose(m.m.catWr)
m.m.catWr = ''
end
do ax=2 by 1 to arg()
r = o2File(arg(ax))
call mAdd m'.RWS', r
if m.r.jReading then do
m.m.catKeepOpen = m.m.rws.0 m.m.catKeepOpen
call jOpen r, m.j.cRead
end
end
return
endProcedure catWriteAll
/*--- create a reader/WriteO for an external file --------------------*/
file: procedure expose m.
parse arg str
return oNew('File', str)
endProcedure file
fileChild: procedure expose m.
parse arg m, name, opt
interpret objMet(m, 'fileChild')
endProcedure fileChild
fileRm: procedure expose m.
parse arg m
interpret objMet(m, 'fileRm')
return
endProcedure fileRm
filePath: procedure expose m.
parse arg m
interpret objMet(m, 'filePath')
endProcedure filePath
fileIsFile: procedure expose m.
parse arg m
interpret objMet(m, 'fileIsFile')
endProcedure fileIsFile
fileIsDir: procedure expose m.
parse arg m
interpret objMet(m, 'fileIsDir')
endProcedure fileIsDir
fileMkDir: procedure expose m.
parse arg m, opt
interpret objMet(m, 'fileMkDir')
return
endProcedure fileRm
fileRmDir: procedure expose m.
parse arg m, opt
interpret objMet(m, 'fileRmDir')
return
endProcedure fileRm
/*--- create a reader/WriteO for the filelist of a directory----------*/
fileList: procedure expose m.
parse arg m, opt
str = oIfStr(m, '')
if str == '' then
return oNew('FileList', filePath(m), opt)
else
return oNew('FileList', dsn2Jcl(str), opt)
endProcedure fileList
fileSingle: procedure expose m.
parse arg m
call jOpen m, '<'
res = jReadO(m)
two = jReadO(m)
call jClose m
if res == '' then
if arg() < 2 then
call err 'empty file in fileSingle('m')'
else
res = arg(2)
if two \== '' then
call err '2 or more recs in fileSingle('m')'
return res
endProcedure fileSingle
catIni: procedure expose m.
if m.cat.ini == 1 then
return
m.cat.ini = 1
call jIni
call classNew "n Cat u JRWO", "m",
, "jOpen call catOpen m, opt",
, "jReset call catReset m, arg",
, "jClose call catClose m",
, "jReadO return catReadO(m)",
, "jWrite call catWrite m, line; return",
, "jWriteO call catWriteO m, var; return",
, "jWriteAll call catWriteAll m, rdr; return"
call oAdd1Method m.class.classV, 'o2File return file(m.m)'
call oAdd1Method m.class.classW, 'o2File return file(substr(m,2))'
os = errOS()
if os == 'TSO' then
call fileTsoIni
else if os == 'LINUX' then
call fileLinuxIni
else
call err 'file not implemented for os' os
return
endProcedure catIni
/* copy cat end ****************************************************/
/* copy fiLinux begin *************************************************/
/*--- send ggShCmd to shell bash,
fail if rc <> 0 or not listed in ggRet -----------------------*/
adrSh: procedure expose m. /* really no need for variables???? */
parse arg ggShCmd, ggRet
address 'bash' ggShCmd
if rc == 0 then return 0
else if ggRet == '*' then return rc
else if wordPos(rc, ggRet) > 0 then return rc
else
call err 'adrSh rc' rc 'for' ggShCmd
endProcedure adrSh
fileLinuxReset: procedure expose m.
parse arg m, nm
m.m.spec = nm
if abbrev(nm, '&') then do
if nm == '&in' then do
m.m.stream = .input
m.m.jReading = 1
end
else if nm == '&out' then do
m.m.stream = .output
m.m.jWriting = 1
end
else do
call err 'bad spec' nm
end
end
else do
m.m.stream = .Stream%%new(nm)
m.m.stream%%init(m.m.stream%%qualify)
end
return m
endProcedure fileLinuxReset
fileLinuxOpen: procedure expose m.
parse arg m, opt
if opt == m.j.cRead then do
res = m.m.stream%%open(read shareread)
m.m.jReading = 1
end
else do
if opt == m.j.cApp then
res = m.m.stream%%open(write append)
else if opt == m.j.cWri then
res = m.m.stream%%open(write replace)
else
call err 'fileLinuxOpen('m',' opt') with bad opt'
m.m.jWriting = 1
end
if res \== 'READY:' then
call err 'fileLinuxOpen fails' res':' opt ,
"'"m.m.stream%%qualify"'"
return m
endProcedure fileLinuxOpen
fileLinuxClose:
parse arg m
res = m.m.stream%%close
if res \== 'READY:' then
call err 'fileLinuxClose' res':' m.m.stream%%qualify
return m
endProcedure fileLinuxClose
fileLinuxRead: procedure expose m.
parse arg m, var
res = m.m.stream%%lineIn
if res == '' then
if m.m.stream%%state \== 'READY' then
return 0
m.var = res
m.class.o2c.var = m.class.classV
return 1
endProcedure fileLinuxRead
fileLinuxWrite: procedure expose m.
parse arg m, line
if m.m.stream%%lineOut(line) then
call err 'fileLinuxWrite'
return
endProcedure fileLinuxWrite
fileLinuxRmDir: procedure expose m.
parse arg m, opt
if opt == '' then
return adrSh('rmdir' m.m.spec)
else if opt == '-r' then
return adrSh('rm -r' m.m.spec)
else
call err 'bad opt' opt 'in fileLinuxRmDir'
endProcedure fileLInuxRmDir
fileLinuxListReset: procedure expose m.
parse arg m, m.m.spec, o
if o == 'r' then
m.m.opt = 'S'
else if o == '' then
m.m.opt = ''
else
call err 'bad opt' o 'in fileLinuxListReset'
m.m.rx = 'closed'
return m
endProcedure fileLinuxListReset
fileLinuxListOpen: procedure expose m.
parse arg m
if m \== translate(m) then
call err 'bad m for fileLinuxList:' m
if m.m.opt == '' then
rc = sysFileTree(m.m.spec'/*', 'm.'m'.LIST')
else
rc = sysFileTree(m.m.spec'/*', 'm.'m'.LIST', m.m.opt)
if rc \== 0 then
call err 'rc' rc 'in sysFileTree('m.m.spec', m.'m'.LIST)'
m.m.rx = 0
m.m.jReading = 1
return m
endProcedure fileLinuxListOpen
fileLinuxListRead: procedure expose m.
parse arg m, var
x = m.m.rx + 1
if x > m.m.list.0 then
return 0
m.var = substr(m.m.list.x, 43)
m.m.rx = x
call oMutate var, m.class.classV
return 1
endProcedure fileLinuxListRead
fileLinuxIni: procedure expose m.
if m.fileLinux.ini == 1 then
return
m.fileLinux.ini = 1
m.file.sep = '/'
call jIni
call classNew "n File u JRW", "m",
, "jReset call fileLinuxReset m, arg",
, "jOpen call fileLinuxOpen m, opt",
, "jClose call fileLinuxClose m",
, "jRead return fileLinuxRead(m, var)",
, "jWrite call fileLinuxWrite m, line",
, "jWriteO call jWrite m, o2String(var)",
, "filePath return m.m.stream%%qualify",
, "fileIsFile return sysIsFile(m.m.stream%%qualify)" ,
, "fileIsDir return sysIsFileDirectory(m.m.stream%%qualify)" ,
, "fileChild return file(m.m.stream%%qualify'/'name)",
, "fileRm return adrSh(m.m.spec)",
, "fileMkDir return adrSh('mkdir' m.m.stream%%qualify)" ,
, "fileRmDir return fileLinuxRmDir(m, opt)"
call classNew "n FileList u JRW", "m",
, "jReset call fileLinuxListReset m, arg, arg2",
, "jOpen call fileLinuxListOpen m, opt",
, "jClose m.m.rx = 'closed'",
, "jRead return fileLinuxListRead(m, var)"
return
endProcedure fileLinuxIni
/* copy fiLinux end *************************************************/
/* copy fileTso begin *************************************************/
fileTsoReset: procedure expose m.
parse arg m, sp
m.m.readIx = 'c'
if symbol('m.m.defDD') \== 'VAR' then do
m.fileTso.buf = m.fileTso.buf + 1
m.m.defDD = 'CAT'm.fileTso.buf
m.m.buf = 'FILETSO.BUF'm.fileTso.buf
m.m.spec = sp
end
if sp \== '' then do
m.m.spec = dsnSpec(sp)
rr = translate(subword(m.m.spec, 4))
m.m.stripT = \ (pos(':V', rr) > 0 | pos('RECFM(V', rr) > 0)
end
return m
endProcedure fileTsoReset
fileTsoOpen: procedure expose m.
parse arg m, opt
buf = m.m.buf
if opt == m.j.cRead then do
aa = dsnAlloc(m.m.spec, 'SHR', m.m.defDD)
if m.dsnAlloc.dsn <> '' then
if sysDsn("'"m.dsnAlloc.dsn"'") <> 'OK' then
call err 'cannot read' m.dsnAlloc.dsn':',
sysDsn("'"m.dsnAlloc.dsn"'")
call readDDBegin word(aa, 1)
m.m.jReading = 1
m.buf.0 = -1
m.m.readIx = 0
end
else do
if opt == m.j.cApp then
aa = dsnAlloc(m.m.spec, 'MOD', m.m.defDD)
else if opt == m.j.cWri then
aa = dsnAlloc(m.m.spec, 'OLD', m.m.defDD)
else
call err 'fileTsoOpen('m',' opt') with bad opt'
call writeDDbegin word(aa, 1)
m.m.jWriting = 1
m.buf.0 = 0
m.m.readIx = 'w'
end
m.m.dd = word(aa, 1)
m.m.free = subword(aa, 2)
m.m.dsn = m.dsnAlloc.dsn
return m
endProcedure fileTsoOpen
fileTsoClose: procedure expose m.
parse arg m
buf = m.m.buf
if m.m.readIx \== 'c' then do
if m.m.readIx == 'w' then do
if m.buf.0 > 0 then
call writeDD m.m.dd, 'M.'BUF'.'
call writeDDend m.m.dd
end
else do
call readDDend m.m.dd
end
interpret m.m.free
end
m.buf.0 = 'closed'
m.m.readIx = 'c'
m.m.free = ''
m.m.dd = ''
return m
endProcedure fileTsoClose
fileTsoRead: procedure expose m.
parse arg m, var
ix = m.m.readIx + 1
buf = m.m.buf
if ix > m.buf.0 then do
res = readDD(m.m.dd, 'M.'buf'.')
if \ res then
return 0
ix = 1
end
m.m.readIx = ix
m.var = m.buf.ix
call oMutate var, m.class.classV
return 1
endProcedure fileTsoRead
fileTsoWrite: procedure expose m.
parse arg m, var
buf = m.m.buf
ix = m.buf.0 + 1
m.buf.0 = ix
if m.m.stripT then
m.buf.ix = strip(var, 't')
else
m.buf.ix = var
if ix > 99 then do
call writeDD m.m.dd, 'M.'buf'.'
m.buf.0 = 0
end
return
endProcedure fileTsoWrite
fileTsoWriteO: procedure expose m.
parse arg m, var
if objClass(var, m.class.classV) == m.class.classV then do
call fileTsoWrite m, m.var
return
end
call err 'fileTsoWriteO('m',' var') cannot write objects of class',
objClass(var)
endProcedure fileTsoWriteO
fSub: procedure expose m.
return file('.sysout(T) writer(intRdr)')
endProcedure fSub
fEdit: procedure expose m.
parse arg spec, vw
if spec == '' then
spec = 'new ::f'
else if abbrev(spec, '::') then
spec = 'new' spec
else if abbrev(spec, ':') then
spec = 'new' ':'spec
f = mNew('FileEdit', spec)
m.f.editType = if(abbrev(translate(vw), 'V'), 'view', 'edit')
return f
endProcedure fEdit
fileTsoEditClose: procedure expose m.
parse arg m
dsn = m.m.dsn
if dsn \== '' then do
call fileTsoClose m
call adrIsp m.m.editType "dataset('"dsn"')", 4
return
end
fr = m.m.free
dd = m.m.dd
m.m.free = ''
call fileTsoClose m
call adrIsp "LMINIT DATAID(lmmId) ddName("dd") ENQ(SHRW)"
eRc = adrIsp(m.m.editType "dataid("lmmId")", '*')
lRc = adrIsp("LMFree DATAID("lmmId")", '*')
interpret fr
if (eRc \== 0 & eRc \== 4) | lRc \== 0 then
call err m.m.editType 'rc' eRc', lmFree rc' lRc
return
endProcedure fileTsoEditClose
fileTsoIni: procedure expose m.
if m.fileTso.ini == 1 then
return
m.fileTso.ini = 1
m.file.sep = '.'
m.fileTso.buf = 0
call jIni
um = "call err 'for tso undefined method'"
call classNew "n File u JRW", "m",
, "jOpen call fileTsoOpen m, opt",
, "jReset call fileTsoReset m, arg",
, "jClose call fileTsoClose m",
, "jRead return fileTsoRead(m, var)",
, "jWrite call fileTsoWrite m, line",
, "jWriteO call fileTsoWriteO m, var",
, "filePath return word(m.m.spec, 1)" ,
, "fileIsFile" um "'fileIsFile'" ,
, "fileIsDir return 1" ,
, "fileChild return file(word(m.m.spec, 1)'.'name opt)",
, "fileRm" um "'fileRm'" ,
, "fileMkDir" ,
, "fileRmDir" um "'fileRmDir'"
/* , "filePath return m.m.stream%%qualify",
, "fileIsFile return sysIsFile(m.m.stream%%qualify)" ,
, "fileIsDir return sysIsFileDirectory(m.m.stream%%qualify)" ,
, "fileChild return file(m.m.stream%%qualify'/'name)",
, "fileRm return adrSh(m.m.spec)",
, "fileMkDir return adrSh('mkdir' m.m.stream%%qualify)" ,
, "fileRmDir return fileLinuxRmDir(m, opt)" */
call classNew "n FileList u JRW", "m",
, "jReset if arg2 == 'r' then m.m.dsnMask=arg'.**';",
"else m.m.dsnMask=arg'.*';",
, "jOpen call csiOpen m, m.m.dsnMask",
, "jClose" ,
, "jRead return csiNext(m, var)"
call classNew "n FileEdit u File", "m",
, "jClose call fileTsoEditClose m"
return
endProcedure fileTsoIni
/* copy fileTso end *************************************************/
/* copy sqlO begin ***************************************************
sql interface mit o und j Anbindung
***********************************************************************/
sqlOini: procedure expose m.
if m.sqlO.ini == 1 then
return
call sqlIni
m.sqlO.ini = 1
m.sqlO.cursors = left('', 200)
call pipeIni
call classNew 'n SqlSel u JRWO', 'm',
, "jReset m.m.src = arg; m.m.type = arg2;",
, "jOpen call sqlSelOpen m, opt",
, "jClose call sqlSelClose m",
, "jReadO return sqlSelReadO(m)"
call classNew 'n SqlDRS u SqlSel', 'm',
, "jReset m.m.loc = arg; m.m.type = arg2;",
, "jOpen call sqlDRSOpen m, opt",
, "jClose call sqlSelClose m",
, "jReadO return sqlSelReadO(m)"
return
endProcedure sqlOini
/*--- connect to the db2 subsystem sys -----------------------------*/
sqlOConnect: procedure expose m.
parse arg sys, retCon
call sqlOIni
return sqlConDis(sys, retCon)
endProcedure sqlOConnect
sqlSel: procedure expose m.
parse arg src, type
s = oNew('SqlSel', inp2str(src, '%S%+Q\s'), type)
call pipeWriteAll s
return m.s.rowCount
endProcedure sqlSel
sqlStmtsOpt: procedure expose m.
parse arg src, opts
upper opts
sub = ''
o = ''
ggRet = ''
do wx=1 to words(opts)
w = word(opts, wx)
if w == '-C72' then
o = o'-c72'
else if w == '-O' | w == 'O' then
o = o'-o'
else if w = '*' | datatype(w, 'n') then
ggRet = ggRet w
else if length(w) == 4 then
sub = w
else
call err 'bad opt' w 'in opts' opts 'not -c72 -o or subsys'
end
call sqlOIni
if sub == '' then
call sqlOConnect
else if sub \== m.sql.connected then
call sqlConnect sub
return sqlStmts(src, strip(ggRet), strip(o))
endProcedure sqlStmtsOpt
/*** execute sql's in a stream (separated by ;)
opt: 'o' ==> write objects, otherwise fmtFTab
's' ==> spufi formatting (window 72) otherwise linebreak */
sqlStmts: procedure expose m.
parse arg src, ggRet, opt
dlm = ';'
isStr = envInp(src)
if isStr then
s = scanSrc(scanSqlReset(scanReset(sqlStmts), '', 0), ggStr)
else do
fi = o2File(ggObj)
if pos('c72', opt) > 0 then
s = jOpen(scanSql(fi), '<')
else
s = jOpen(scanSqlReset(scanRead(fi), fi, 0), '<')
end
do while scanSqlStmt(s, dlm)
if m.s.val = '' then
iterate
w1 = translate(word(m.s.val, 1))
if w1 == 'TERMINATOR' then do
dlm = strip(substr(m.s.val, 12))
if length(dlm) \== 1 then
call scanErr s, 'bad terminator' dlm 'in' strip(m.s.val)
iterate
end
call out sqlStmt(m.s.val, ggRet, opt)
end
if \ isStr then
call jClose s
return 0
endProcedure sqlStmts
sqlStmt: procedure expose m.
parse arg src, ggRet, opt
bx = verify(src, '( ')
if bx < 1 then
return ''
fun = translate(word(substr(src, bx), 1))
w2 = translate(word(substr(src, bx), 2))
res = ''
if fun == 'SELECT' | fun = 'WITH' then do
s = oNew('SqlSel', inp2str(src, '%S%+Q\s'))
if pos('o', opt) > 0 then
call pipeWriteAll s
else
call fmtFTab sqlStmtFmt, s
res = m.s.rowCount 'rows fetched'
end
else if fun = 'SET' & abbrev(w2, ':') then do
ex = pos('=', w2)
if ex > 2 then
var = strip(substr(w2, 2, ex-2))
else
var = strip(substr(w2, 2))
if var = '' then
var = 'varUnbekannt'
call sqlExec src, ggRet
res = 'sqlCode' sqlCode var'='value(var)
end
else if fun = 'SET' | (fun = 'DECLARE' & w2 = 'GLOBAL') then do
call sqlExImm src, ggRet
res = 'sqlCode' sqlCode
end
else if fun = 'CALL' then do
res = sqlStmtCall(src, ggRet, opt)
end
else do
if pos('-', ggRet) < 1 & fun = 'DROP' then
ggRet = -204 ggRet
call sqlExec src, ggRet
res = 'sqlCode' sqlCode
if wordPos(fun, 'DELETE INSERT UPDATE') > 0 THEN
res = res',' sqlErrd.3 'rows' ,
translate(fun, m.mAlfLC, m.mAlfUC)'d'
end
aa = strip(src)
ll = 75 - length(res)
if length(aa) > ll then
aa = space(aa, 1)
if length(aa) > ll then
aa = left(aa, ll-3)'...'
return res':' aa
endProcedure sqlStmt
sqlStmtCall: procedure expose m.
parse arg src, ggRet, opt
s = scanSrc(scanSqlReset(sqlstmtcall, ,0), src)
if \ scanSqlId(scanSkip(s)) | m.s.val \== 'CALL' then
call scanErr s, 'not a call'
if \ scanSqlQuId(scanSkip(s)) then
call scanErr s, 'qualified id missing after call'
loc = ''
if m.s.val.0 = 1 then
wh = 'name =' quote(m.s.val.1, "'")
else if m.s.val.0 = 2 then
wh = "schema = '"strip(m.s.val.1)"'" ,
"and name = '"strip(m.s.val.2)"'"
else if m.s.val.0 = 3 then do
loc = m.s.val.1
wh = "schema = '"strip(m.s.val.2)"'" ,
"and name = '"strip(m.s.val.3)"'"
end
else
call scanErr s, 'storedProcedureName' m.s.val ,
'has' m.s.val.0 'parts, should have 1, 2 or 3'
pn = m.s.val
da = sqlStmtCallDa(sqlStmtCall, loc, wh)
if \ scanLit(scanSkip(s), '(') then
call scanErr s, '( expected after call' pn
varChars = f
do ax=1
m.da.ax.varName = ''
isEmpty = 0
if scanLit(scanSkip(s), ':') then do
if \ scanVerify(scanSkip(s), m.mAlfDot) then
call scanErr s, 'variable expected after : in call' pn
m.da.ax.varName = m.s.tok
if m.da.ax.io == 'i' | m.da.ax.io == 'b' then
m.da.ax.sqlData = envGet(m.da.ax.varName)
end
else if scanString(s) then
m.da.ax.sqlData = m.s.val
else if scanVerify(s, ',):;', 'm') then
m.da.ax.sqlData = strip(m.s.tok)
else
isEmpty = 1
if scanLit(scanSkip(s), ')') then
leave
if \ scanLit(s, ',') then
call scanErr s, if(isEmpty, 'value, var, ') ,
|| "',' or ')' expected"
end
if ax \= m.da.sqlD then
if \ (ax=1 & m.da.sqlD = 0 & isEmpty) then
call scanErr s, 'call with' ax 'parms but' ,
pn 'needs' m.da.sqld
caCo = sqlExec('call' pn 'using descriptor :M.'da, 466)
call out '--- called' pn', sqlCode' caCo
do ax=1 to m.da.sqlD
call Out ' parm' ax m.da.ax.io m.da.ax.parmName,
|| if(m.da.ax.varName \== '',' $'m.da.ax.varName),
'=' m.da.ax.sqlData
if m.da.ax.varName \== '' then
call envPut m.da.ax.varName, m.da.ax.sqlData
end
if caCo = 466 then do
drop sqlDP
call sqlExec 'describe procedure :pn into :m.sqlDp'
if m.sqldp.sqlD < 1 then
call err 'bad sqldp sqlD='m.sqldp.sqlD 'for sqlCode' caCo
do dx=1 to m.sqldp.sqlD
call out ' dynamic result set' dx m.sqldp.dx.sqlName ,
'locator='m.sqldp.dx.sqlLocator
end
do dx=1 to m.sqldp.sqlD
drs = 'dynamic result set' dx'='m.sqldp.dx.sqlName 'of' pn
call out '--- begin of' drs
rdr = sqlDRS(m.sqldp.dx.sqlLocator)
if pos('o', opt) > 0 then
call pipeWriteAll rdr
else
call fmtFTab sqlStmtFmt, rdr
call out '---' m.rdr.rowCount 'rows fetched from' drs
end
end
return 'sqlCode' caCo
endProcedure sqlStmtCall
sqlStmtCallDa: procedure expose m.
parse arg da, loc, wh
cr = if(loc=='',,loc'.')'sysIbm'
sql = "select 'SCHEMA=''' || strip(schema) || ''''",
"|| ' and name=''' || strip(name ) || ''''",
"|| ' and specificName=''' || strip(specificName) || ''''",
"|| ' and routineType =''' || strip(routineType ) || ''''",
"|| ' and VERSION =''' || strip(VERSION ) || ''''",
"from" cr".SysRoutines ",
"where" wh "and active = 'Y'"
if sqlpreAllCl(49, sql, rou, ':m.rou') <> 1 then
call err m.rou.0 'routines found for' wh
rdr = jOpen(sqlRdr('select * from' cr'.sysParms where' m.rou,
'order by ordinal'), '<')
do ix=1 while assNN('A', jReadO(rdr))
if m.a.ordinal <> ix then
call err 'ix' ix 'mismatch ordinal' m.a.ordinal
ty = m.a.dataTypeId
m.da.ix.sqlType = ty
m.da.ix.sqlLen = m.a.length
m.da.ix.sqlLen.sqlPrecision = m.a.length
m.da.ix.sqlLen.sqlScale = m.a.scale
if wordPos(ty, 384 385) > 0 then /* date */
m.da.ix.sqlLen = 10
else if wordPos(ty, 388 389) > 0 then /* time */
m.da.ix.sqlLen = 8
else if wordPos(ty, 392 393) > 0 then /* timestamp */
m.da.ix.sqlLen = 26
m.da.ix.sqlData = ''
m.da.ix.parmName= m.a.parmName
m.da.ix.io = translate(m.a.rowType, 'iob', 'POB')
m.da.ix.sqlInd = 1
end
m.da.sqlD = ix - 1
return da
endProcedure sqlStmtCallDa
sqlRdr: procedure expose m.
parse arg src, type
return oNew('SqlSel', inp2str(src, '%S%+Q\s'), type)
endProcedure sqlRdr
/*--- prepare and open cursor
generate type and fetchList ------------------------------------*/
sqlSelOpen: procedure expose m.
parse arg m, opt
if opt\== m.j.cRead then
call err 'opt not' m.j.cRead 'sqlSelOpen('m',' opt')'
m.m.cursor = sqlGetCursor()
call sqlPreOpen m.m.cursor, m.m.src, m.m.type == ''
m.m.jReading = 1
m.m.rowCount = 'open'
return m
endProcedure sqlOpen
/*--- dynamic result sets --------------------------------------------*/
sqlDRS: procedure expose m.
parse arg loc, type
return oNew('SqlDRS', loc, type)
endProcedure sqlDRS
sqlDRSOpen: procedure expose m.
parse arg m, opt
if opt\== m.j.cRead then
call err 'opt not' m.j.cRead 'sqlDRSOpen('m',' opt')'
crs = sqlGetCursor('a')
crN = 'C'crs
m.m.cursor = crs
m.sql.crs.d.sqlD = 'noSqlDA'
m.sql.crs.into = ''
call sqlexec 'allocate C'crs 'cursor for result set :m.m.loc'
call sqlExec('describe cursor :crN into :M.SQL.'crs'.D')
m.m.jReading = 1
m.m.rowCount = 0
return m
endProcedure sqlDRSOpen
/*--- return a free cursor -------------------------------------------*/
sqlGetCursor: procedure expose m.
parse arg rng
if rng == '' then
return sqlGetCursorRng(rng, 10, 49)
else if rng == 'h' then
return sqlGetCursorRng(rng, 60, 99)
else if rng == 'a' then
return sqlGetCursorRng(rng, 110, 199)
else
call err 'bad cursor range' rng
endProcedure sqlGetCursor
sqlGetCursorRng: procedure expose m.
parse arg rng, fr, to
cx = pos(' ', m.sqlO.cursors, fr)
if cx < fr & cx > to then
call err "no more '"rng"' cursors between" fr "and" to,
":"m.sqlO.cursors
m.sqlO.cursors = overlay('u', m.sqlO.cursors, cx)
return cx
endProcedure sqlGetCursor
/*--- mark a cursor as closed ----------------------------------------*/
sqlFreeCursor: procedure expose m.
parse arg cx
if substr(m.sqlo.cursors, cx, 1) \== 'u' then
call err 'sqlFreeCursor('cx') not in use :'m.sqlo.cursors
m.sqlO.cursors = overlay(' ', m.sqlO.cursors, cx)
return
endProcedure sqlFreeCursor
/*--- create the type, fetch vars etc. from the sqlDA ---------------*/
sqlIntoClass: procedure expose m.
parse arg m
da = 'SQL.'m.m.cursor
if m.m.type = '' | m.m.type == '*' then do
call sqlIntoVars m.m.cursor
ff = mCat(da'.COL', '%+Q v, f ')
m.m.type = classNew('n* SQL u f' ff 'v')
end
else do
f = class4name(m.m.type)'.FLDS'
if m.f.0 < sqlDescribeOutput(m.m.cursor) then
call err 'not enough fields in' m.m.type 'for' m.m.src
do ix=1 to m.da.d.sqlD
if translate(m.f.ix) \== m.f.ix then
call err 'fld' ix m.f.ix 'not uppercase for sql'
m.da.d.col.ix = substr(m.f.ix, 2)
end
call sqlIntoVarsNull m.m.cursor
end
return
endProcedure sqlIntoClass
/*--- fetch cursor for this sqlSel -----------------------------------*/
sqlSelReadO: procedure expose m.
parse arg m
if m.m.rowCount == 'open' then do
call sqlIntoClass m
m.m.rowCount = 0
end
trace ?r
v = mNew(m.m.type)
if \ sqlFetch(m.m.cursor, v) then
return ''
m.m.rowCount = m.m.rowCount + 1
return v
endProcedure sqlSelReadO
/*--- close sql Cursor -----------------------------------------------*/
sqlSelClose: procedure expose m.
parse arg m, v
call sqlClose m.m.cursor
call sqlFreeCursor m.m.cursor
return m
endProcedure sqlSelClose
/*--- generate the format ff for a sql cx as specified in sp
use the information from the sqlDa -------------------------*/
deleteSqlGenFmt: procedure expose m.
parse arg ff, cx, sp
if abbrev(sp, '=') then
return substr(sp, 2)
if sp = '' then
sp = '*st'
m.ff.0 = m.sql.cx.d.sqlD
m.ff.flds = oFlds(sqlType(cx))
if abbrev(sp, '*') then do
do ix=1 to m.ff.0
m.ff.ix = substr(sp, 2)
end
return ff
end
if abbrev(fmts, '=') then
m.Sql.cx.FMT = substr(fmts, 2)
defs = 'ir7 fr9 sl12 Tl26' sp
do wx = 1 to words(defs)
parse value word(defs, wx) with ty 2 fo
select
when ty = 'd' then t.384 = fo
when ty = 'f' then t.480 = fo'/f'
when ty = 'i' then t.496 = fo'/i'
when ty = 'n' then t.484 = fo'/n'
when ty = 's' then t.448 = fo
when ty = 't' then t.388 = fo
when ty = 'T' then t.392 = fo
otherwise call err 'bad type' ty 'for format' fo
end
end
if symbol('t.496') == 'VAR' then
t.500 = t.496
if symbol('t.448') == 'VAR' then do
t.452 = t.448
t.456 = t.448
t.464 = t.448
end
do wx = 1 to m.ff.0
ty = m.sql.cx.d.wx.sqlType
le = m.sql.cx.d.wx.sqlLen
withNulls = ty // 2
ty = ty - withNulls
if symbol('t.ty') <> 'VAR' then
call err 'sqlType' ty 'not supported'
parse var t.ty fo 2 fl '/' op
if op = 'i' then
if le = 2 then le = 6
else le = 12
else if op <> '' then
call err 'length for sqlType' ty 'op' op 'not implemented'
if fl = '=' then
fl = le
else if abbrev(fl, '<') then
fl = min(le, substr(fl, 2))
m.ff.wx = fo || fl
end
return ff
endProcedure sqlGenFmt
/* copy sqlO end **************************************************/
/* copy sql begin ***************************************************
sql interface
***********************************************************************/
sqlIni: procedure expose m.
parse arg opt
if m.sql.ini == 1 & opt \== 1 then
return
m.sqlNull = '---'
m.sqlInd = 'sqlInd'
m.sqlRetOK.0 = 0
m.sqlMsgCa = 0
m.sqlMsgDsntiar = 1
m.sqlMsgCodeT = 0
call sqlPushRetOk
m.sql.ini = 1
m.sql.connected = ''
isInProd = wordPos(sysvar(sysNode), 'RZ2 RZ4') > 0
m.sql.handleRestrictOnDrop = \ isInProd
return
endProcedure sqlIni
/*--- prepare statement 's'cx from sql src into descriptor desc ------*/
sqlPrepare: procedure expose m.
parse arg cx, src, descOut, descInp
s = ''
src = inp2str(src, '%+Q\s')
m.sql.cx.d.sqlD = 'noSqlDA'
m.sql.cx.into = ''
if descOut == 1 then
s = 'into :M.SQL.'cx'.D'
res = sqlExec('prepare s'cx s 'from :src')
if res < 0 then
return res
if descInp == 1 | (descInp == '' & pos('?', src) > 0) then
res = sqlExec('describe input s'cx 'into :M.SQL.'cx'.I')
else
m.sql.cx.i.sqlD = 0
return res
endProcedure
/*--- prepare and declare 'c'cx from sql src -------------------------*/
sqlPreDeclare: procedure expose m.
parse arg cx, src, descOut, descInp
res = sqlPrepare(cx, src, descOut, descInp)
if res >= 0 then
return sqlExec('declare c'cx 'cursor for s'cx)
return res
endProcedure sqlPreDeclare
/*--- prepare, declare and open 'c'cx from sql src -------------------*/
sqlPreOpen: procedure expose m.
parse arg cx, src, descOut, descInp
res = sqlPreDeclare(cx, src, descOut, descInp)
if res >= 0 then
return sqlOpen(cx)
return res
endProcedure sqlPreOpen
/*--- open cursor 'c'cx using arguments arg(2), arg(3)... ------------*/
sqlOpen: procedure expose m.
parse arg cx
do ix=1 to arg()-1
call sqlDataSet 'SQL.'cx'.I', ix, arg(ix+1)
end
return sqlExec('open c'cx 'using descriptor :M.SQL.'cx'.I')
endProcedure sqlOpen
/*--- close cursor 'c'cx ---------------------------------------------*/
sqlClose: procedure expose m.
parse arg cx, src
return sqlExec('close c'cx)
endProcedure sqlClose
/*--- fetch cursor 'c'cx into variables ggVars -----------------------*/
sqlFetchInto:
parse arg ggCx, ggVars
if ggVars == '' then
ggVars = 'descriptor :M.SQL.'ggCX'.D'
/* accept sqlCodes > 0 except 100 */
ggRes = sqlExec('fetch c'ggCx 'into' ggVars, 100 m.sqlRetOk)
if ggRes == 0 then
return 1
if ggRes == 100 then
return 0
return ggRes
endProcedure sqlFetchInto
/*--- fetch cursor 'c'cx into destination dst and put sqlNull --------*/
sqlFetch: procedure expose m.
parse arg cx, dst, opts
vars = sqlIntoVars(cx)
if \ sqlFetchInto(cx, vars) then
return 0
call sqlSetNull cx, dst
return 1
endProcedure sqlFetch
sqlSetNull: procedure expose m.
parse arg cx, dst
do nx=1 to m.sql.cx.sqlNull.0
col = m.sql.cx.sqlNull.nx
if m.dst.col.sqlInd < 0 then
m.dst.col = m.sqlNull
end
return
endProcedure sqlSetNull
sqlIntoVars: procedure expose m.
parse arg cx
if m.sql.cx.into \== '' then
return m.sql.cx.into
do ix=1 to sqlDescribeOutput(cx)
/* fetch uppercases variable names */
cn = translate(word(m.sql.cx.d.ix.sqlName, 1))
if cn == '' | symbol(c.cn) == 'VAR' then
cn = 'COL'ix
c.cn = 1
m.sql.cx.col.ix = cn
end
return sqlIntoVarsNull(cx)
endProcedure sqlIntoVars
/*--- describe output (if not already done)
and return size of sqlDa ------------------------------------*/
sqlDescribeOutput: procedure expose m.
parse arg cx, force
if force == 1 | \ datatype(m.sql.cx.d.sqlD, 'n') then
call sqlExec 'describe s'cx 'into :M.SQL.'cx'.D', 0
return m.sql.cx.d.sqlD
endProcedure sqlDescribeOutput
sqlIntoVarsNull: procedure expose m.
parse arg cx
nx = 0
vars = ''
do ix=1 to sqlDescribeOutput(cx)
cn = m.sql.cx.col.ix
vars = vars', :m.dst.'cn
if m.sql.cx.d.ix.sqlType // 2 = 1 then do
vars = vars' :m.dst.'cn'.sqlInd'
nx = nx + 1
m.sql.cx.sqlNull.nx = cn
end
end
m.sql.cx.col.0 = m.sql.cx.d.sqlD
m.sql.cx.sqlNull.0 = nx
m.sql.cx.into = substr(vars, 3)
return m.sql.cx.into
endProcedure sqlIntoVarsNull
/*--- return sql variable list for stem st and fields the word in vars
if withInd == 1 then with sqlIndicator variables
sqlVars('S', 'A B') --> ':S.A, :S.B'
sqlVars('S', 'A B', 1) --> ':S.A :S.A.SQLIND, :S.B :S.B.SQLIND'
----------------------------------------------------------------------*/
sqlVars: procedure expose m. /* ??????????????? ==> sqlJRopen */
parse arg st, vars, withInd
res = ''
if st ^== '' then
st = st'.'
do ix=1 to words(vars)
res = res', :'st || word(vars, ix)
if withInd == 1 then
res = res ':'st || word(vars, ix)'.sqlInd'
end
return substr(res, 3)
endProcedure sqlVars
sqlVarsNull: procedure expose m.
parse arg st, vars
hasNulls = 0
do ix = 1 to words(vars)
fld = word(vars, ix)
if m.st.fld.sqlInd < 0 then do
m.st.fld = m.sqlNull
hasNulls = 1
end
end
return hasNulls
endProcedure sqlVarsNull
/*--- open cursor 'c'cx fetch all into variables vars and close
st = passed stem, sx = row number
return number of rows fetched ----------------------------------*/
sqlOpAllCl:
parse arg ggCx, st, ggVars
do ggAx=4 to arg()
call sqlDataSet 'SQL.'ggCx'.I', ggAx-3, arg(ggAx)
end
ggRes = sqlOpen(ggCx)
if ggRes < 0 then
return ggRes
do sx = 1 until ggRes \== 1
ggRes = sqlFetchInto(ggCx, ggVars)
end
m.st.0 = sx - 1
call sqlClose ggCx
if ggRes == 0 then
return m.st.0
return ggRes
endProcedure sqlOpAllCl
sqlDataSet: procedure expose m.
parse arg da, ix, val
m.da.ix.sqlData = val
m.da.ix.sqlInd = - (arg(ix+2) == m.sqlNull)
/* data types schienen einmal nicht zu funktionieren .......
if wordPos(m.da.ix.sqlType, '384 385 388 389 392 393') > 0 then
m.da.ix.sqlType = 448 + (m.da.ix.sqlType // 2) */
return
endProcedure sqlDataSet
/*--- prepare, declare open cursor 'c'cx, fetch all and close
return number of rows fetched ----------------------------------*/
sqlPreAllCl:
parse arg ggCx, ggSrc, st, ggVars
ggRes = sqlPreDeclare(ggCx, ggSrc)
if ggRes >= 0 then
return sqlOpAllCl(ggCx, st, ggVars)
return ggRes
endProcedure sqlPreAllCl
/*--- execute statement 's'cx using arguments arg(2), arg(3)... ------*/
sqlExecute:
parse arg ggCx ggRetOk /* no , for ggRetOk, arg(2) is used already| */
do ggAx=2 to arg()
call sqlDataSet 'SQL.'ggCx'.I', ggAx-1, arg(ggAx)
end
return sqlExec('execute s'ggCx 'using descriptor :M.SQL.'ggCx'.I',
, ggRetOk)
endProcedure
/*--- execute immediate the sql src ----------------------------------*/
sqlExImm:
parse arg ggSrc, ggRetOk
return sqlExec('execute immediate :ggSrc', ggRetOk)
endProcedure sqlExImm
sqlCommit: procedure expose m.
parse arg src
return sqlExec('commit')
endProcedure sqlCommit
/*--- execute sql thru the dsnRexx interface -------------------------*/
sqlExec: /* no procedure, to keep variables sql... */
parse arg ggSqlStmt, ggRetOk, ggNo
if ggNo <> '1' then
ggSqlStmt = 'execSql' ggSqlStmt
address dsnRexx ggSqlStmt
/* say 'sqlCode' sqlCode 'rc' rc 'for' ggSqlStmt ggNo */
if rc = 0 then
return 0
if ggRetOk = '' then
ggRetOk = m.sqlRetOk
if wordPos(rc, '1 -1') < 0 then
call err 'dsnRexx rc' rc sqlmsg()
else if pos('*', ggRetOk) > 0 | wordPos(sqlCode, ggRetOk) > 0 ,
then do
if sqlCode < 0 & pos('say', ggRetOk) > 0 then
say 'sqlError' sqlmsg()
return sqlCode
end
else if rc < 0 then do
if sqlErrorHandler(ggSqlStmt, sqlCode, sqlErrMc) then
sqlCode = 0
else
call err sqlmsg()
end
else if sqlCode <> 0 | (pos('w',ggRetOk)<1 & sqlWarn.0^==' ') then
call errSay sqlMsg(), ,'w'
return sqlCode
endSubroutine sqlExec
sqlErrorHandler: procedure expose m.
parse arg a1 verb rest, cd, errMc
if translate(a1) \== execSql then
return 0
upper verb
if cd = -672 & verb == 'DROP' ,
& m.sql.handleRestrictOnDrop == 1 then do
say 'sqErrorHandler trying to drop restrict on drop on' errMc
call sqlExec 'alter table' errMc ,
'drop restrict on drop'
say 'sqlErrorHandler retrying' verb rest
call sqlExec verb rest
return 1
end
return 0
endProcedure sqlErrHandler
/*--- connect to the db2 subsystem sys -----------------------------*/
sqlConnect: procedure expose m.
parse upper arg sys, retOk
call sqlIni
address tso "SUBCOM DSNREXX"
if rc <> 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
if sys = '-' then
return 0
res = sqlExec("connect" sys, retOk ,1)
if res >= 0 then
m.sql.connected = sys
return res
endProcedure sqlConnect
/*--- diconnect from db2 ---------------------------------------------*/
sqlDisconnect: procedure expose m.
parse arg retOk
m.sql.connected = ''
return sqlExec("disconnect ", retOk, 1)
endProcedure sqlDisconnect
/*--- connect and/or disconnect to DB2 -------------------------------*/
sqlConDis: procedure expose m.
parse upper arg sys, retOk
if sys \== '' then
nop
else if sysvar(sysnode) == 'RZ1' then
sys = 'DBAF'
else
call err 'no default subsys for' sysvar(sysnode)
call sqlIni
if sys == m.sql.connected then
return 0
if m.sql.connected \== '' then
call sqlDisconnect
if sys = '-' then
return 0
return sqlConnect(sys, retOk)
endProcedure sqlConDis
/*--- push and pop currently accepted sqlCodes -----------------------*/
sqlPushRetOk: procedure expose m.
parse arg rr
nx = m.sqlRetOk.0 + 1
m.sqlRetOk.0 = nx
m.sqlRetOk.nx = rr
m.sqlRetOk = rr
return
endProcedure sqlPushRetOk
sqlPopRetOk: procedure expose m.
nx = m.sqlRetOk.0 - 1
if nx < 1 then
call err 'sqlPopRetOk with .0' m.sqlRetOk.0
m.sqlRetOk = m.sqlRetOk.nx
m.sqlRetOk.0 = nx
return
endProcedure sqlPopRetOk
/*--- issue an sql error message -------------------------------------*/
sqlMsg: /* no procedure, to keep variables sql... */
ggRes = ''
if \ dataType(sqlCode, 'n') then do
ggRes = 'sqlCode' sqlCode 'not numeric\n'sqlMsgCa()
end
else do
signal on syntax name sqlMsgOnSyntax
if m.sqlMsgCodeT == 1 then
ggRes = 'sqlCode' sqlCodeT(sqlCode, sqlErrMc, sqlwarn.0':' ,
|| sqlwarn.1||sqlwarn.2||sqlwarn.3||sqlwarn.4||sqlwarn.5',',
|| sqlwarn.6||sqlwarn.7||sqlwarn.8||sqlwarn.9||sqlwarn.10)
if 0 then
sqlMsgOnSyntax: do
ggRes = sqlMsgCa(),
'\n<<rexx sqlCodeT not found or syntax>>'
end
signal off syntax
if m.sqlMsgDsnTiar == 1 then do
ggRes = ggRes || sqlDsntiar()
ggWa = sqlMsgWarn(sqlWarn)
if ggWa \= '' then
ggRes = ggRes'\nwarnings' ggWa
end
if m.sqlMsgCa == 1 then
ggRes = ggRes'\n'sqlMsgCa()
end
ggSqlSp = ' ,:+-*/&%?|()¢!'
ggXX = pos(':', ggSqlStmt)+1
do ggSqlVx=1 to 12 while ggXX > 1
ggYY = verify(ggSqlStmt, ggSqlSp, 'm', ggXX)
if ggYY < 1 then
ggYY = length(ggSqlStmt) + 1
ggSqlVa.ggSqlVx = substr(ggSqlStmt, ggXX, ggYY - ggXX)
do ggQQ = ggXX-2 by -1 to 1 ,
while substr(ggSqlStmt, ggQQ, 1) == ' '
end
do ggRR = ggQQ by -1 to 1 ,
while pos(substr(ggSqlStmt, ggRR, 1), ggSqlSp) < 1
end
if ggRR < ggQQ & ggRR > 0 then
ggSqlVb.ggSqlVx = substr(ggSqlStmt, ggRR+1, ggQQ-ggRR)
else
ggSqlVb.ggSqlVx = ''
ggXX = pos(':', ggSqlStmt, ggYY+1) + 1
end
ggSqlVa.0 = ggSqlVx-1
if datatype(sqlErrd.5, 'n') & sqlErrd.5 > 0 then do
ggW2 = translate(word(ggSqlStmt, 2))
ggW3 = translate(word(ggSqlStmt, 3))
if ggW2 == 'PREPARE' then
ggRes = ggRes || sqlMsgSrF('FROM')
else if ggW2 ggW3 == 'EXECUTE IMMEDIATE' then
ggRes = ggRes || sqlMsgSrF(1)
else
ggRes = ggRes || sqlMsgSrF()
end
ggRes = ggRes'\nstmt = ' ggSqlStmt
ggPref = '\nwith'
do ggXX=1 to ggSqlVa.0
ggRes = ggRes || ggPref ggSqlVb.ggXX ':'ggSqlVa.ggXX ,
'=' value(ggSqlVa.ggXX)
ggPref = '\n '
end
if abbrev(ggRes, '\n') then
return substr(ggRes, 3)
return ggRes
endSubroutine sqlMsg
sqlMsgSrF:
parse arg ggF
if ggF \== '' & \ datatype(ggF, 'n') then do
do ggSqlVx=1 to ggSqlVa.0
if translate(ggSqlVb.ggSqlVx) = ggF then
return sqlMsgSrc(value(ggSqlVa.ggSqlVx), sqlErrd.5)
end
end
if datatype(ggF, 'n') & ggF <= ggSqlVa.0 then
return sqlMsgSrc(value(ggSqlVa.ggF), sqlErrd.5)
return sqlMsgSrc(ggSqlStmt , sqlErrd.5)
endSubroutine sqlMsgSrF
/*--- use dsnTiar to translate sql Info to error text ----------------*/
sqlDsnTiar:
sqlWarn = sqlWarn.0 || sqlWarn.1 || sqlWarn.2 || sqlWarn.3,
|| sqlWarn.4 || sqlWarn.5 || sqlWarn.6 || sqlWarn.7,
|| sqlWarn.8 || sqlWarn.9 || sqlWarn.10
if sqlCode = -438 then
return '\nSQLCODE = -438:',
'APPLICATION RAISED ERROR WITH sqlState' sqlState,
'and DIAGNOSTIC TEXT:' sqlErrMc
if digits() < 10 then
numeric digits 10
sqlCa = d2c(sqlCode, 4) ,
|| d2c(max(70, length(sqlErrMc)), 2)left(sqlErrMc, 70) ,
|| left(sqlErrP, 8) ,
|| d2c(sqlErrD.1, 4)d2c(sqlErrD.2, 4)d2c(sqlErrD.3, 4) ,
|| d2c(sqlErrD.4, 4)d2c(sqlErrD.5, 4)d2c(sqlErrD.6, 4) ,
|| sqlWarn || sqlState
if length(sqlCa) <> 124 then
call err 'sqlDa length' length(sqlCa) 'not 124' ,
'\nsqlCa=' sqlMsgCa()
return sqlDsnTiarCall(sqlCa)
/*--- call dsnTiar o translate sql Info to error text ----------------*/
sqlDsnTiarCall: procedure expose m.
parse arg ca
liLe = 78
msLe = liLe * 10
if length(ca) <> 124 then
call err 'sqlDa length' length(ca) 'not 124:' ca', hex='c2x(ca)
ca = 'SQLCA ' || d2c(136, 4) || ca
msg = d2c(msLe,2) || left('', msLe)
len = d2c(liLe, 4)
ADDRESS LINKPGM "DSNTIAR ca msg LEN"
if rc <> 0 then
call err 'linkPgm dsnTiar rc' rc 'sqlCa' ca
res = ''
do c=3 by liLe to msLe
if c = 3 then do
l1 = strip(substr(msg, c+10, 68))
cx = pos(', ERROR: ', l1)
if cx > 0 then
l1 = left(l1, cx-1)':' strip(substr(l1, cx+9))
res = res'\n'l1
end
else if substr(msg, c, 10) = '' then
res = res'\n 'strip(substr(msg, c+10, 68))
else
leave
end
return res
endProcedure sqlDsnTiarCall
sqlMsgCa:
ggWarn = ''
do ggX=0 to 10
if sqlWarn.ggX \== ' ' then
ggWarn = ggWarn ggx'='sqlWarn.ggx
end
if ggWarn = '' then
ggWarn = 'none'
return 'sqlCode' sqlCode 'sqlState='sqlState,
'\n errMC='translate(sqlErrMc, ',', 'ff'x),
'\n warnings='ggWarn 'erP='sqlErrP,
'\n errD.1='sqlErrD.1 '2='sqlErrD.2 '3='sqlErrD.3,
'\n errD.4='sqlErrD.4 '5='sqlErrD.5 '6='sqlErrD.6
endProcedure sqlMsgCa
/*--- make the text for sqlWarnings
input warn.0..warn.10 as a 11 character string ------------*/
sqlMsgWarn: procedure expose m.
parse arg w0 2 wAll
if w0 = '' & wAll = '' then
return ''
if length(wAll) \= 10 | ((w0 = '') <> (wAll = '')) then
return 'bad warn' w0':'wAll
r = ''
text =' 1=W var truncated, 1=S scrollable, 1=N nonScrollable,' ,
'2=W nulls in aggregate,' ,
'3=W more cols than vars,' ,
'3=Z more result sets than locators,' ,
'4=W no where, 4=D sensitive dynamic, 4=I insensitive,' ,
'4=S sensitive static,' ,
'5=W not valid sql, 5=1 readOnly, 5=2 readDelete,' ,
'5=3 readDeleteUpdate,' ,
'6=W day changed to month range,' ,
'7=W dec digits truncated,' ,
'8=W char substituted,' ,
'9=W arith excep in count, 9=Z multipe result sets,' ,
'10=W char conversion err in ca,'
do wx = 1 to 10
w = substr(wAll, wx, 1)
if w = ' ' then
iterate
t = wx'='w
cx = pos(' 'wx'='w' ', text)
ex = pos(',' , text, cx + 1)
if cx < 1 then
r = r wx'='w '?,'
else
r = r substr(text, cx+1, ex-cx)
end
return strip(r, 't', ',')
endProcedure sqlMsgWarn
sqlMsgSrc: procedure expose m.
parse arg src, pos, opt
if 0 then do /* old version, before and after txt */
tLe = 150
t1 = space(left(src, pos), 1)
if length(t1) > tLe then
t1 = '...'right(t1, tLe-3)
t2 = space(substr(src, pos+1), 1)
if length(t2) > tLe then
t2 = left(t2, tLe-3)'...'
res = '\nsource' t1 '<<<error>>>' t2
end
liLe = 68
liCn = 3
afLe = 25
if translate(word(src, 1)) == 'EXECSQL' then
src = substr(src, wordIndex(src, 2))
t1 = space(left(src, pos), 1)
t2 = left(' ', substr(src, pos, 1) == ' ' ,
| substr(src, pos+1, 1) == ' ') ,
|| space(substr(src, pos+1), 1)
afLe = min(afLe, length(t2))
if length(t1) + afLe > liLe * liCn then
t1 = '...'right(t1, liLe * liCn - afLe -3)
else if length(t1)+length(t2) > liLe then
t1 = left(' ', (liCn * liLe - length(t1) -afLe) // liLe)||t1
pL = length(t1) // liLe
if length(t2) <= liLe-pL then
tx = t1 || t2
else
tx = t1 || left(t2, liLe-pL-3)'...'
res = '\nsrc' strip(substr(tx, 1, liLe), 't')
do cx=1+liLe by liLe to length(tx)
res = res || '\n +' strip(substr(tx, cx, liLe), 't')
end
loc = 'pos' pos 'of' length(src)
if length(loc)+6 < pL then
return res'\n >' right('>>>'loc'>>>', pL)
else
return res'\n >' left('', pL-1)'<<<'loc'<<<'
endProcdedur sqlMsgSrc
/*--- send a command to db2 through the TSO dsn processor ------------*/
sqlDsn: procedure expose m.
parse arg st, sys, cmd, rcOk
x = outtrap('M.'st'.')
push 'END'
push cmd
address tso 'DSN SYSTEM('sys')'
rr = rc
x = outtrap(off)
if rr = 0 | rcOk = '*' | wordPos(rr, rcOk) > 0 then
return rr
fl = max(1, m.st.0 - 10)
em = 'rc' rr 'for DSN SYSTEM('sys') cmd' cmd,
'\nOuputlines' fl '-' m.st.0':'
do lx=fl to m.st.0
em = em '\n' strip(m.st.lx, 't')
end
call err em
endProcedure sqlDsn
/* copy sql end **************************************************/
/* copy csi begin ***************************************************
csi interface: see dfs managing catalogs appendix c
returncode/reason see message IDC3009I
**********************************************************************/
/*--- specify dsn mask and fields to start a csi catalog search --------
arguments:
m objectPointer
dsnMask specifies the dsns with wildcards:
% 1 character
* 0 - n character in one level
** 0 - n levels
fields a (space separated) list of field names -------------*/
csiOpen: procedure expose m.
parse arg m, dsnMask, fields
m.m.fld.0 = words(fields)
ffix = d2c(m.m.fld.0, 2)
do x=1 to m.m.fld.0
m.m.fld.x = translate(word(fields, x))
ffix = ffix || left(m.m.fld.x, 8)
end
if dsnMask \== '' & pos('*', dsnMask) < 1 then
dsnMask = dsnMask'.**'
m.m.filt = left(dsnMask, 149) ,
|| left('Y', 3) , /* resume offset 149 */
|| ffix /* csiNumEn offset 152 */
WORKLEN = 1024 * 64
m.m.work = D2C(WORKLEN,4) || COPIES('00'X,WORKLEN-4)
m.m.pos = workLen + 1
return
endProcedure csiOpen
/*--- put the next dsn into m.o and m.o.* (for other fields)
return 1 if next dsn exists 0 otherwise ------------------------*/
csiNext: procedure expose m.
parse arg m, o
usedL = C2D(SUBSTR(m.m.work,9,4)) /* GET AMOUNT OF WORK AREA USED */
px = m.m.pos
do forever
if px > usedL then do
if substr(m.m.filt, 150, 1) \== 'Y' then do
m.m.pos = px
m.o = ''
return 0
end
reason = left('', 4)
ADDRESS LINKPGM 'IGGCSI00 reason m.'m'.filt m.'m'.work'
if rc == 0 & substr(reason, 3, 2) == '0000'x then
nop
else if rc == 4 & substr(reason, 3, 2) == '0464'x then
say 'data set entry with error'
else
call err 'call csi returns' rc,
'rc' c2d(substr(reason, 4,1)),
'reason' c2d(substr(reason, 3,1)),
'module' substr(reason, 1,2)
usedL = C2D(SUBSTR(m.m.work,9,4)) /* GET WORK AREA USED */
numFD = C2D(SUBSTR(m.m.work,13,2)) /* no flds + 1 */
if numFd <> m.m.fld.0 + 1 then
call err 'csiNumFd' numFd 'not' m.m.fld.0 '+' 1
px = 15
iterate
end
eType = substr(m.m.work, px+1, 1)
m.o = strip(substr(m.m.work, px+2, 44), 't')
flag = substr(m.m.work, px, 1)
/* say 'eType' eType m.o 'flag' c2x(flag) */
if eType == '0' then do
if flag \== '00'x & flag \== '40'x then
call err 'flag' c2x(flag) 'for catalog' m.o
px = px + 50 /* length of catalog entry */
iterate
end
else do
if \ abbrev(x2b(c2x(flag)), '101') then
call err 'call csi entry flag' x2b(c2x(flag)),
'rc' c2d(substr(m.m.work, px+49,1)),
'reason' c2d(substr(m.m.work, px+48,1)),
'module' substr(m.m.work, px+46, 2),
'for entry' m.o,
'see qw IDC3009I'
py = px + 46
tl = c2d(substr(m.m.work, py, 2))
pl = py + 4
pf = py + m.m.fld.0 * 2 + 4
do fx = 1 to m.m.fld.0
fi = m.m.fld.fx
fl = c2d(substr(m.m.work, pl, 2))
m.o.fi = substr(m.m.work, pf, fl)
if fi = 'MGMTCLAS' then
m.o.fi = substr(m.o.fi, 3, c2d(left(m.o.fi ,2)))
else if wordPos(fi, 'COMUDSIZ NOBYTTRK') > 0 then
m.o.fi = c2d(m.o.fi)
pf = pf + fl
pl = pl + 2
end
if py + tl <> pf then
call err 'length mismatch for entry' m.o
m.m.pos = pf
return 1
end
end
endProcedure csiNext
/*--- if dsn is arcived return 'arcive'
if dsn is tape return 'tape'
otherwise return managment class ------------------------------*/
csiArcTape: procedure expose m.
parse arg vo, cl, dt, dsn
if vo = '' then
say err '||| no volume for dsn' dsn
else if vo = 'ARCIVE' then
res = 'arcive'
else if cl <> '' then
res = cl
else if abbrev(vo, 'SHR') then
res = 'SHR'
else
res = 'tape'
if res = 'arcive' then
return res
/*if abbrev(res, 'ar') \= abbrev(dt, '00'x) , */
if abbrev(res, 'ta') \= abbrev(c2x(left(dt, 1)), '7') ,
| (left(res, 1) >= 'A') \= abbrev(dt, '30'x) then
say '||| mismatch cl' cl 'vo' vo 'dt' c2x(dt) 'dsn' dsn
return res
endProcedure csiArcTape
/* copy csi end ******************************************************/
/* copy csm begin ******************************************************
interface to csm,
it is integrate with adrTso, eg. dsnAlloc , 'RZ3/..' uses csm
***********************************************************************/
adrCsm:
return adrTso('csmExec' arg(1), arg(2))
endProcedure adrCsm
csmCopy: procedure expose m.
parse arg csnFr, csnTo, ggRet
if dsnGetMbr(csnTo) \= '' ,
& dsnGetMbr(csnFr) <> dsnGetMbr(csnTo) then
call err 'member rename' csnFr 'to' csnTo
parse value csmSysDsn(csnFr) with sysFr '/' dsnFr
parse value csmSysDsn(csnTo) with sysTo '/' dsnTo
if sysFr = '*' & sysTo <> '*' then do
pdsTo = dsnSetMbr(dsnTo)
al = "SYSTEM("sysTo") DDNAME(COPYTo)",
"DATASET('"pdsTo"') DISP(SHR)"
alRes = dsnAlloc(systo'/'pdsTo, ,'COPYTO', '*')
if datatype(alRes, 'n') then do
/* wir müssen es selbst allozieren csmxUtil
vergisst management class ||||| */
say 'could not allocate' al
say 'trying to create'
rc = listDsi("'"dsnSetMbr(dsnFr)"' SMSINFO")
if rc = 0 then
mv = ''
else if rc = 4 & sysReason = 19 then do
mv = 'UNITCNT(30)'
say 'multi volume' mv
end
else if rc \= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
al = left(al, length(al)-4)'CAT)'
if right(sysDsSms, 7) == 'LIBRARY' ,
| abbrev(sysDsSms, 'PDS') then
al = al 'DSNTYPE(LIBRARY)'
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
al = al "DSORG("sysDSorg") MGMTCLAS("sysMgmtClass")",
"RECFM("sysREcFM") LRECL("SYSLRECL")",
"blksize("sysBLkSIZE")",
"SPACE("sysPrimary"," sysSeconds")" sysUnits mv
call adrCsm "allocate" al
end
call adrTso 'free dd(copyTo)'
end
c = "'COPY" sysFr"/''"dsnFr"'' TO" ,
sysTo"/''"dsnSetMbr(dsnTo)"'' REPLACE'"
return adrTso("exec 'CSM.RZ1.P0.EXEC(CSRXUTIL)'" c , ggRet)
return
endProcedure csmCopy
csmAlloc: procedure expose m.
parse arg dsn dd disp rest ':' nn, retRc
sys = ''
a2 = ''
parse value csmSysDsn(dsn) with sys '/' dsn
if disp = '' then
disp = 'shr'
al = "SYSTEM("sys") DDNAME("dd")"
if dsn <> '' then do
a2 = "DATASET('"dsnSetMbr(dsn)"')"
mbr = dsnGetMbr(dsn)
if mbr <> '' then
a2 = a2 'MEMBER('mbr')'
end
if abbrev(disp, 'SYSOUT(') then
a2 = a2 disp
else
a2 = a2 "DISP("disp")"
if retRc <> '' | nn = '' then do
alRc = adrCsm('allocate' al a2 rest, retRc)
if alRc <> 0 then
return alRc
return dd 'call adrTso "free dd('dd')";'
end
do retry=0 by 1
alRc = adrCsm('allocate' al a2 rest, '*')
if alRc = 0 then
return dd 'call adrTso "free dd('dd')";'
if retry > 0 | nn = '' | wordPos(disp, 'OLD SHR') < 1 then
return err('cmsAlloc rc' alRc 'for' al rest)
say 'csmAlloc rc' alRc 'for' al a2 rest '...trying to create'
nn = al 'disp(cat)' dsnCreateAtts(dsn, nn, 1)
call adrCsm 'allocate' nn
call adrTso 'free dd('dd')'
end
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
/* copy csm end********************************************************/
/* copy adrIsp begin *************************************************/
/**********************************************************************
lmd: catalog read
call sequence: lmdBegin, lmdNext*, lmdEnd
mit lmd service (mit save in file und read,
weil list zu langsam und listcat abstürzt)
1. arg (grp) als group dataset für lmd save
und dd name für file read
***********************************************************************/
lmdBegin: procedure expose m.
parse arg grp, lev
call adrIsp 'lmdinit listid(lmdId) level('lev')'
res = adrIsp('lmdlist listid(&lmdId) option(save) group('grp')', 4)
call adrIsp 'lmdfree listid(&lmdId)'
if res = 0 then do
call trc timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') shr dsn('grp'.datasets)'
end
else do
call trc 'no datasets found' timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') dummy'
end
call readDDBegin grp
return /* end lmdBegin */
lmdNext:
parse arg ggGrp, ggSt, withVolume
if \ readDD(ggGrp, ggSt) then
return 0
if withVolume \== 1 then
do ggIx=1 to value(ggSt'0')
x = value(ggSt || ggIx, word(value(ggSt || ggIx), 1))
end
return 1
endSubroutin lmdNext
lmdEnd: procedure expose m.
parse arg grp
call readDDEnd grp
call adrTso 'free dd('grp')'
return /* end lmdEnd */
lmd: procedure expose m.
parse arg lev, withVol
call lmdBegin gg1, lev
do while lmdNext(gg1, q., withVol)
do x=1 to q.0
call out q.x
end
end
call lmdEnd gg1
return
endProcedure lmd
/**********************************************************************
member list of a pds:
call sequence x=lmmBegin(dsn) lmmNext(x) * lmmEnd(x)
***********************************************************************/
lmm: procedure expose m.
parse arg dsn
id = lmmBegin(dsn)
do ix=1 by 1
m = lmmNext(id)
if m = '' then
leave
call out m
end
call lmmEnd id
return
endProcedure lmm
lmmBegin: procedure expose m.
parse arg dsn
mbr = dsnGetMbr(dsn)
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET('"pds"') ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(INPUT) "
res = lmmId
if mbr <> '' then
res = res 'pattern('mbr')'
return res
endProcedure lmmBegin
lmmEnd: procedure expose m.
parse arg lmmId opt
call adrIsp "LMMLIST DATAID("lmmId") option(free)", 8
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
return
endProcedure lmmEnd
lmmNext: procedure expose m.
parse arg lmmId opt
if adrIsp("LMMLIST DATAID("lmmid")" ,
"OPTION(LIST) MEMBER(Mbr)" opt, 4 8) = 0 then
return strip(mbr)
else
return ''
endProcedure lmmNext
lmmRm: procedure expose m.
parse arg dsn, mbrs
mbrs = dsnGetMbr(dsn) mbrs
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET("pds") ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(OUTPUT) "
err = ''
do wx=1 to words(mbrs)
m1 = word(mbrs, wx)
rr = adrIsp("lmmDel dataid("lmmId") member("m1")", 0 8 12)
if rc = 0 then
say 'removed' m1 'from' pds
else if rc = 8 then
say 'not found' m1 'in' pds
else do
err = 'error deleting' m1 'in' pds 'rc' rr strip(zerrlm)
say err
leave
end
end
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
if err <> '' then
call err err
return
endProcedure lmmRm
/*--- address ispf with error checking -------------------------------*/
adrIsp:
parse arg ggIspCmd, ggRet
address ispexec ggIspCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr ispExec rc' rc 'in' ggIspCmd':' strip(zerrlm)
endSubroutine adrIsp
/*--- address editor with error checking -----------------------------*/
adrEdit:
parse arg ggEditCmd, ggRet
address isrEdit ggEditCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr isrEdit rc' rc 'for' ggEditCmd
endSubroutine adrEdit
/* copy adrIsp end *************************************************/
/* copy adrTso begin *************************************************/
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet ---*/
adrTso:
parse arg ggTsoCmd, ggRet
address tso ggTsoCmd
if rc == 0 then return 0
else if ggRet == '*' then return rc
else if wordPos(rc, ggRet) > 0 then return rc
else
call err 'adrTso rc' rc 'for' ggTsoCmd
return /* end adrTso */
/*--- format dsn from tso format to jcl format -----------------------*/
dsn2jcl: procedure expose m.
parse upper arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
cx = pos('~', dsn)
if cx < 1 & addPrefix == 1 then
return sp'.'dsn
do while cx \== 0
le = left(dsn, cx-1)
ri = substr(dsn, cx+1)
if right(le, 1) == '.' | left(ri, 1) == '.' then
dsn = le || sp || ri
else
dsn = le || left('.', le \== '') || sp ,
|| left('.', ri \== '') || ri
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
parse arg dsn, mbr
bx = pos('(', dsn)
if bx > 0 then
dsn = strip(left(dsn, bx-1))
if mbr <> '' then
dsn = dsn'('strip(mbr)')'
return dsn
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn
lx = pos('(', dsn)
rx = pos(')', dsn, lx+1)
if lx < 1 then
return ''
else if lx < rx then
return substr(dsn, lx+1, rx-lx-1)
else
return strip(substr(dsn,lx+1))
endProcedure dsnGetMbr
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: readDDBegin, readDD*, readDDEnd
write: writeBegin, writeDD*, writeEnd
readDD returns true if data read, false at eof
***********************************************************************/
/*--- prepare reading from a DD --------------------------------------*/
readDDBegin: procedure expose m.
parse upper arg ggDD
call errAddCleanup 'call readDDEnd' ggDD', "*"'
return /* end readDDBegin */
/*--- read from DD ggDD into ggSt, return false at eof ---------------*/
readDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskr' ggDD '(stem' ggSt')', 2
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- finish reading DD ggDD ----------------------------------------*/
readDDEnd: procedure expose m.
parse upper arg ggDD, ggRet
call errRmCleanup 'call readDDEnd' ggDD', "*"'
return adrTso('execio 0 diskr' ggDD '(finis)', ggRet)
endProcedure readDDEnd
/*--- prepare writing to DD ggDD -------------------------------------*/
writeDDBegin: procedure expose m.
parse upper arg ggDD
/* ensure file is erased, if no records are written */
call adrTso 'execio' 0 'diskw' ggDD '(open)'
call errAddCleanup 'call writeDDEnd' ggDD', "*"'
return /* end writeDDBegin */
/*--- write to gg ggDD from stem ggSt, ggCnt records -----------------*/
writeDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt == '' then
ggCnt = value(ggst'0')
call adrTso 'execio' ggCnt 'diskw' ggDD '(stem' ggSt')'
return
endSubroutine writeDD
/*--- end writing to dd ggDD (close) --------------------------------*/
writeDDEnd: procedure expose m.
parse upper arg ggDD, ggRet
call errRmCleanup 'call writeDDEnd' ggDD', "*"'
return adrTso('execio 0 diskw' ggDD '(finis)', ggRet)
endProcedure writeDDEnd
/*--- readNx: read next line, using buffer ---------------------------*/
/*--- begin: allocate dsnSpec and ini ------------------------ -------*/
readNxBegin: procedure expose m.
parse arg m, m.m.dsn, m.m.dd, m.m.Cnt
if m.m.dd = '' then
m.m.dd = 'DDNX'
if m.m.cnt = '' then
m.m.cnt = 1000
m.m.cx = m.m.cnt + 999
m.m.buf0x = 0
m.m.0 = 0
call dsnAlloc 'dd('m.m.dd')' m.m.dsn
call readDDBegin m.m.dd
return m
endProcedure readDDNxBegin
/*--- return the stem of the next line, or '' at end -----------------*/
readNx: procedure expose m.
parse arg m
ix = m.m.cx + 1
m.m.cx = ix
if m.m.cx <= m.m.0 then
return m'.'ix
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 position (line number) of reader
plus le characters of the current line (default 50) ------*/
readnxPos: procedure expose m.
parse arg m, le
li = m'.'m.m.cx
li = strip(m.li, 't')
if arg() < 2 then
le = 50
if le < 1 then
li = ''
else if length(li) <= le then
li = ':' li
else
li = ':' left(li, le-3)'...'
return 'line' (m.m.buf0x + m.m.cx)li
endProcedure readnxPos
/*--- close and deallocate ------------------------------------------*/
readNxEnd: procedure expose m.
parse arg m
call readDDEnd m.m.dd
call tsoFree m.m.dd
return
endProcedure readDDNxEnd
/*--- standardise a dsn spec
word1 dsName or -
word2 dd or -
word3 disp or -
word4 to first : attributes in tso format
after first : attributes for new allocation
----------------------------------------------------------------------*/
dsnSpec: procedure expose m.
parse upper arg spec
rr = '' /* put leading - in separate words */
do sx=1 while words(rr) < 3 & wx \= ''
wx = word(spec, sx)
do while abbrev(wx, '-') & words(rr) < 3
wx = substr(wx, 2)
rr = rr '-'
end
rr = rr wx
end
spec = rr subWord(spec, sx)
na = ''
dd = ''
di = ''
if left(spec, 1) = '&' then /* external spec is handled ok */
spec = strip(substr(spec, 2))
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, '.') | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
di = w
else if w = 'CATALOG' then
di = di w
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
na = strip(substr(w, 5, length(w)-5))
else if na == '' then
na = dsn2jcl(w)
else if dd == '' then
dd = w
else if di == '' then
di = w
else
leave
end
if na == '' then
na = '-'
else if abbrev(na, "'") then
na = substr(na, 2, length(na)-2)
if dd == '' then dd = '-'
if di == '' then di = '-'
re = subword(spec, wx)
if abbrev(re, '.') then
re = substr(re, 2)
return na dd di re
endProcedure dsnSpec
/*--- alloc a dsn with dsnAlloc
if the dsn is inuse wait and retry
until either the allocation is successfull
or the timeout occurs --------------------------------------*/
dsnAllocWait: procedure expose m.
parse upper arg spec, pDi, pDD, timeOut
x = max(1, arg() - 1)
do rt=0
m.adrTsoAl.1 = ''
m.adrTsoAl.2 = ''
m.adrTsoAl.3 = ''
call outtrap m.adrTsoAl.
res = dsnAlloc(spec, pDi, pDD, '*')
call outtrap off
if \ abbrev(res, ' ') then
return res
msg = m.adrTsoAl.1'\n'm.adrTsoAl.2'\n'm.adrTsoAl.3
if rt > timeOut & timeOut \== '' then
return err('timeout allocating' spec time() '\n'msg)
if pos('DATA SET IS ALLOCATED TO ANOTHER', msg) < 1 then
return err('allocating' spec'\n'msg)
say time() 'sleep and retry alloc' spec
call sleep 1, 0
end
endProcedure dsnAllocWait
/*--- alloc a dsn or a dd
spec '-'<ddName>
datasetName? disposition? '.'? attributes? (':' newAtts)?
disp default disposition
dd default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc -----*/
dsnAlloc: procedure expose m.
parse upper arg spec, pDi, pDD, retRc
parse value dsnSpec(spec) with na dd di rest
if na = '-' then
m.dsnAlloc.dsn = ''
else
m.dsnAlloc.dsn = na
if na == '-' & dd \== '-' & di == '-' & rest = '' then
return dd
if dd == '-' & pDD \== '' then
dd = pDD
if dd == '-' then do
if symbol('m.adrTso.ddNum') = 'VAR' then
dd = m.adrTso.ddNum + 1
else
dd = 1
m.adrTso.ddNum = dd
dd = 'DD' || dd
end
if di = '-' & pDi \== '' then
di = pDi
if di = '-' then
di = 'SHR'
else if pos('(', na) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if pos('/', na) > 0 then
return csmAlloc(na dd di rest, retRc)
else
return tsoAlloc(na dd di rest, retRc)
endProcedure dsnAlloc
tsoAlloc: procedure expose m.
parse arg na dd disp rest ':' nn, retRc
c = 'alloc dd('dd')' disp
if na \== '-' then
c = c "DSN('"na"')"
else if disp = 'NEW' and nn \== '' then
c = c dsnCreateAtts(,nn)
call outtrap m.adrTsoAl.
alRc = adrTso(c rest, '*')
call outtrap off
if alRc = 0 then do
call errAddCleanup 'call tsoFree' dd', "*"'
return dd 'call tsoFree' dd';'
end
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& sysDsn("'"m.dsnAlloc.dsn"'") == 'DATASET NOT FOUND' then do
say 'tsoAlloc creating' c rest ':'nn
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na dd disp rest, retRc)
end
do ax=1 to m.adrTsoAl.0
say m.adrTsoal.ax
end
if retRc = '*' | wordPos(alRc, retRc) > 0 then
return ' ' alRc
call err 'tsoAlloc rc' alRc 'for' c rest
endProcedure tsoAlloc
tsoAtts: procedure expose m.
parse arg dsn
rc = listDsi("'"dsn"' SMSINFO")
if rc = 0 then
mv = ''
else if rc = 4 & sysReason = 19 then do
mv = 'UNITCNT(30)'
say 'multi volume' mv
end
else if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
al = 'CAT'
al = ''
if right(sysDsSms, 7) == 'LIBRARY' ,
| abbrev(sysDsSms, 'PDS') then
al = al 'DSNTYPE(LIBRARY)'
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
al = al "DSORG("sysDSorg") MGMTCLAS("sysMgmtClass")",
"DATACLAS("sysDataClass")" ,
"RECFM("translate('1 2 3', ' 'sysREcFM, ' 123')")",
"LRECL("SYSLRECL")",
"blksize("sysBLkSIZE")",
"SPACE("sysPrimary"," sysSeconds")" sysUnits mv
return al
endProcedure tsoAtts
tsoFree: procedure expose m.
parse arg dd, ggRet
call adrTso 'free dd('dd')', ggRet
call errRmCleanup 'call tsoFree' dd', "*"'
return
endProcedure tsoFree
dsnCreateAtts: procedure expose m.
parse arg dsn, atts, forCsm
forCsm = forCsm == 1
aU = ' 'translate(atts)
if abbrev(atts, ':') then do
parse var atts a1 atts
bl = 32760
rl = substr(a1, 3)
if abbrev(a1, ':F') then do
if rl = '' then
rl = 80
recfm='f b'
bl = bl - (bl // rl)
end
else do
if rl = '' then
rl = bl-4
recfm = substr(a1, 2, 1) 'b'
end
if forCsm then
atts = atts "recfm("space(recfm, 0)") lrecl("rl")",
"blkSize("bl")"
else
atts = atts "recfm("recfm") lrecl("rl") block("bl")"
end
if pos('(', dsn) > 0 & pos(' DSNTYPE(', aU) < 1 ,
& pos(' DSORG(', aU) < 1 then
atts = atts 'dsntype(library) dsorg(po)'
if pos(' MGMTCLAS(', aU) < 1 then
atts = atts 'mgmtclas(COM#A091)'
if pos(' SPACE(', aU) < 1 then
if forCsm then
atts = atts 'space(10, 1000) cylinder'
else
atts = atts 'space(10, 1000) cyl'
if dsn == '' then
return atts
return "dataset('"dsnSetMbr(dsn)"')" atts
endProcedure dsnCreateAtts
/*--- read the dataset specified in ggDsnSpec to stem ggSt -----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
interpret subword(ggAlloc, 2)
return
endSubroutine readDsn
/*--- write the dataset specified in ggDsnSpec from stem ggSt
write ggCnt records if not empty otherwise ggst0
if ggSay 1 then say ... records written to ... -------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'open finis)'
interpret subword(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
copyDSN: procedure expose m.
parse arg frSpec, toSpec, ggSay
frDD = dsnAlloc(frSpec, 'SHR', 'FRDD')
toDD = dsnAlloc(toSpec, 'OLD', 'TODD')
call readDDBegin word(frDD, 1)
call writeDDBegin word(toDD, 1)
cnt = 0
do while readDD(word(frDD, 1), r.)
call writeDD word(toDD, 1), r.
cnt = cnt + r.0
end
call readDDEnd word(frDD, 1)
call writeDDEnd word(toDD, 1)
interpret ';' subword(frDD, 2) '; ; ;' subword(toDD, 2)
if ggSay == 1 | m.debug == 1 then
say cnt 'records copied from' frSpec 'to' to toSpec
return
endSubroutine writeDsn
/* copy adrTso end ****************************************************/
/* copy j begin *******************************************************
the j framework
jReset
jOpen
jClose
jRead
jWrite
***********************************************************************/
jRead: procedure expose m.
parse arg m, var
call objMetClaM m, 'jRead'
if m.m.jReading then
interpret ggCode
else
return err('jRead('m',' var') but not opened r')
endProcedure jRead
jReadO: procedure expose m.
parse arg m
if arg() > 1 then call err '??? old interface'
call objMetClaM m, 'jReadO'
if m.m.jReading then
interpret ggCode
else
return err('jReadO('m',' var') but not opened r')
endProcedure jReadO
jWrite: procedure expose m.
parse arg m, line
call objMetClaM m, 'jWrite'
if \ m.m.jWriting then
return err('jWrite('m',' line') but not opened w')
interpret ggCode
return
endProcedure jWrite
jWriteO: procedure expose m.
parse arg m, var
call objMetClaM m, 'jWriteO'
if \ m.m.jWriting then
return err('jWriteO('m',' var') but not opened w')
interpret ggCode
return
endProcedure jWriteO
jWriteAll: procedure expose m.
parse arg m, rdr
rdr = o2file(rdr)
call objMetClaM m, 'jWriteAll'
if \ m.m.jWriting then
return err('jWriteAll('m',' rdr') but not opened w')
interpret ggCode
return
endProcedure jWriteAll
jWriteNow: procedure expose m.
parse arg m, rdr
rdr = o2file(rdr)
interpret objMet(m, 'jWriteNow')
return
endProcedure jWriteNow
jCat: procedure expose m.
parse arg opt m
if m = '' then do
m = opt
opt = m.j.cWri
end
call jOpen m, opt
do ax=2 to arg()
call jWriteAll m, arg(ax)
end
call jClose m
return m
endProcedure jCat
jWriteNowImpl: procedure expose m.
parse arg m, rdr
call jOpen rdr, m.j.cRead
do while jRead(rdr, line)
call jWrite m, m.line
end
call jClose rdr
return
endProcedure jWriteNow
jWriteNowImplO: procedure expose m.
parse arg m, rdr
call jOpen rdr, m.j.cRead
do while assNN('li', jReadO(rdr))
call jWriteO m, li
end
call jClose rdr
return
endProcedure jWriteNow
/*--- reset JRW: fail if open, initialise ---------------------------*/
jReset: procedure expose m.
parse arg m, arg, arg2, arg3
if m.m.jReading == 1 | m.m.jWriting == 1 then
return err('still open jReset('m',' arg2')') / 3
m.m.jReading = 0
m.m.jWriting = 0
m.m.jUsers = 0
interpret objMet(m, 'jReset')
return m
endProcedure jReset
jOpen: procedure expose m.
parse arg m, opt
call objMetClaM m, 'jOpen'
oUsers = m.m.jUsers
if opt = m.j.cRead then do
if m.m.jReading then
nop
else if m.m.jWriting then
return err('already opened for writing jOpen('m',' opt')')
else do
interpret ggCode
m.m.jReading = 1
end
end
else if \ abbrev('>>', opt, 1) then do
return err('bad option' opt 'in jOpen('m',' opt')')
end
else do
if m.m.jWriting then
nop
else if m.m.jReading then
return err('already opened for reading jOpen('m',' opt')')
else do
interpret ggCode
m.m.jWriting = 1
end
end
m.m.jUsers = oUsers + 1
return m
endProcedure jOpen
jClose: procedure expose m.
parse arg m
call objMetClaM m, 'jClose'
oUsers = m.m.jUsers
if oUsers = 1 then do
interpret ggCode
m.m.jReading = 0
m.m.jWriting = 0
end
else if oUsers < 1 then
call err 'jClose' m 'but already closed'
m.m.jUsers = oUsers - 1
return m
endProcedure jClose
/*--- cat the lines of the file together, with mid between lines,
fail if not all lines are strings -------------------*/
jCatLines: procedure expose m.
parse arg m, fmt
if fmt == '' then
fmt = '%+Q\s'
call jOpen m, m.j.cRead
if \ jRead(m, line) then do
call jClose m
return ''
end
res = f(fmt, m.line)
do while jRead(m, line)
res = res || f(fmt'%-Qnxt', m.line)
end
call jClose m
fEnd = 'F.FORMAT.'fmt'%-Qend'
return res || m.fEnd
endProcedure jCatLines
jCat1: procedure expose m.
parse arg v, opt
if opt == '' | abbrev(opt, '-b') then
return v
if opt == '-s' then
return strip(v)
if opt == '-c72' then
return left(v, 72)
call err "bad opt '"opt"' in jCat1("v", '"opt"')"
endProcedure jCat1
jIni: procedure expose m.
if m.j.ini == 1 then
return
m.j.ini = 1
m.j.cRead = '<'
m.j.cWri = '>'
m.j.cApp = '>>'
call oIni
am = "call err 'call of abstract method"
call classNew 'n JRW u ORun, f JREADING v, f JWRITING v', 'm',
, "new call jReset m, arg, arg2, arg3",
, "jRead" am "jRead('m',' var')'" ,
, "jReadO if \ jRead(m, 'J.GGVAR') then return '';",
"return s2o(m.j.ggVar)" ,
, "jWrite" am "jWrite('m',' line')'" ,
, "jWriteO call jWrite(m, o2string(var))" ,
, "jWriteAll call jWriteNowImpl m, rdr",
, "jWriteNow call jWriteNowImpl m, rdr",
, "jReset",
, "jOpen" am" jOpen('m',' opt')'" ,
, "jClose" ,
, "oRun call pipeWriteAll m",
, "o2String return jCatLines(m, fmt)",
, "o2File return m"
call classNew 'n JRWO u JRW', 'm',
, "jRead res = jReadO(m); if res == '' then return 0;" ,
"m.var = o2string(res); return 1" ,
, "jReadO" am "jReadO('m')'" ,
, "jWrite call jWriteO(m, s2o(var))" ,
, "jWriteO" am "jWriteO('m',' line')'",
, "jWriteAll call jWriteNowImplO m, rdr",
, "jWriteNow call jWriteNowImplO m, rdr",
am = "call err 'call errObject"
call classNew 'n JRWErr u JRW', 'm',
, "jWriteAll" er "jWriteAll 'm', rdr'",
, "jWriteNow" er "jWriteNow 'm', 'rdr'",
, "jClose" er "jClose 'm'"
call classNew 'n JSay u JRW', 'm',
, "jWrite say line" ,
, "jWriteO call classOut , var, 'outO: '",
, "jOpen if \ abbrev(opt, m.j.cWri) then",
"call err 'can only write JSay.jOpen('m',' opt')';" ,
"else m.m.jWriting = 1"
call classNew 'n JStem u JSay', 'm',
, "jReset m.m.stem = arg;",
"if \ dataType(m.arg.0, 'n') then m.arg.0 = 0" ,
, "jWrite call mAdd m.m.stem, line"
call classNew 'n JRWEof u JRW', 'm',
, "jRead drop m.var; return 0",
, "jOpen if pos('>', opt) > 0 then",
"call err 'can only read JRWEof.jOpen('m',' opt')';" ,
"else m.m.jReading = 1"
m.j.in = jOpen(oNew('JRWEof'), m.j.cRead)
call outDst
call classNew "n JBuf u JRWO, f BUF s r", "m",
, "jOpen call jBufOpen m, opt",
, "jReset call jBufReset m, arg",
, "jRead return jBufRead(m, var)",
, "jReadO return jBufReadO(m)",
, "jWrite call jBufWrite m, line",
, "jWriteO call jBufWriteO m, var"
call classNew "n JBufTxt u JBuf, f MAXL v ", "m",
, "jReset call jBufReset m, arg; m.m.maxl = 80",
, "jWriteO call jBufWrite m, o2Text(var, m.m.maxl)"
return
endProcedure jIni
in: procedure expose m.
parse arg arg
return jRead(m.j.in, arg)
endProcedur in
inO: procedure expose m.
if arg() > 0 then call err '??? old interface'
return jReadO(m.j.in)
endProcedur in
out: procedure expose m.
parse arg line
call jWrite m.j.out, line
return 0
endProcedure out
outO: procedure expose m.
parse arg arg
call jWriteO m.j.out, arg
return
endProcedure outO
/*--- jBuf: buffer read or write (supports datataypes) ---------------*/
jBuf: procedure expose m.
m = oNew('JBuf') /* calls jBufReset */
do ax=1 to arg()
m.m.buf.ax = arg(ax)
end
m.m.buf.0 = ax-1
m.m.allV = 1
return m
endProcedure jBuf
/*--- jBuf: buffer read or write (supports datataypes) ---------------*/
jBufTxt: procedure expose m.
m = oNew('JBufTxt') /* calls jBufReset */
do ax=1 to arg()
m.m.buf.ax = arg(ax)
end
m.m.buf.0 = ax-1
m.m.allV = 1
return m
endProcedure jBufTxt
jBufReset: procedure expose m.
parse arg m
m.m.stem = m'.BUF'
do ax=1 to arg() - 1
m.m.buf.ax = arg(ax+1)
end
m.m.buf.0 = ax-1
m.m.allV = 1
return m
endProcedure jBufReset
jBufOpen: procedure expose m.
parse arg m, opt
if opt == m.j.cRead then do
m.m.readIx = 0
m.m.jReading = 1
return m
end
if opt == m.j.cWri then do
m.m.buf.0 = 0
m.m.allV = 1
end
else if opt \== m.j.cApp then
call err 'jBufOpen('m',' opt') with bad opt'
m.m.jWriting = 1
return m
endProcedure jBufOpen
jBufWrite: procedure expose m.
parse arg m, line
if m.m.allV then
call mAdd m'.BUF', line
else
call mAdd m'.BUF', s2o(line)
return
endProcedure jBufWrite
jBufWriteStem: procedure expose m.
parse arg m, st
ax = m.m.buf.0
if m.m.allV then do
do sx=1 to m.st.0
ax = ax + 1
m.m.buf.ax = m.st.sx
end
end
else do
do sx=1 to m.st.0
ax = ax + 1
m.m.buf.ax = o2String(m.st.sx)
end
end
m.m.buf.0 = ax
return m
endProcedure jBufWrite
jBufWriteO: procedure expose m.
parse arg m, ref
if m.m.allV then do
cl = objClass(ref)
if cl = m.class.classV then do
call mAdd m'.BUF', m.ref
return
end
if cl == m.class.classW then do
call mAdd m'.BUF', substr(ref, 2)
return
end
m.m.allV = 0
do ax=1 to m.m.buf.0
m.m.buf.ax = s2o(m.m.buf.ax)
end
end
call mAdd m'.BUF', ref
return
endProcedure jBufWriteO
jBufReadO: procedure expose m.
parse arg m
nx = m.m.readIx + 1
if nx > m.m.buf.0 then
return ''
m.m.readIx = nx
if m.m.allV then
return s2o(m.m.buf.nx)
else
return m.m.buf.nx
endProcedure jBufReadO
jBufRead: procedure expose m.
parse arg m, var
nx = m.m.readIx + 1
if nx > m.m.buf.0 then
return 0
m.m.readIx = nx
if m.m.allV then
m.var = m.m.buf.nx
else
m.var = o2String(m'.BUF.'nx)
return 1
endProcedure jBufRead
jBufTxtWriteO: procedure expose m.
parse arg m, ref
if m.m.allV \== 1 then
call err '1 \== allV' m.m.allV 'in jBufTxtWriteO('m',' ref')'
cl = objClass(ref, '?')
if cl = m.class.classV then
call mAdd m'.BUF', m.ref
else if cl == m.class.classW then
call mAdd m'.BUF', substr(ref, 2)
else if ref == '' then
call mAdd m'.BUF', '@ null object'
else if cl == '?' then
call mAdd m'.BUF', '@'ref 'class=???'
else do
l = '@'ref 'class='className(cl)
ff = cl'.FLDS'
do fx=1 to m.ff.0 while length(l) < m.m.maxl + 3
if m.ff.fx == '' then
l = l', .='m.ref
else do
f1 = substr(m.ff.fx, 2)
l = l',' f1'='m.ref.f1
end
end
if length(l) > m.m.maxl then
l = left(l, m.m.maxl-3)'...'
call mAdd m'.BUF', l
end
return
endProcedure jBufTxtWriteO
/* copy j end *********************************************************/
/* copy o begin ******************************************************
an object has a class which describes fields and methods
an object has fields (e.g. m.o.fld1)
an object may call it's methods (dynamic binding)
***********************************************************************/
oIni: procedure expose m.
if m.o.ini = 1 then
return
m.o.ini = 1
call classIni
call oAdd1Method m.class.classV, 'o2String return m.m'
m.class.escW = '!'
call oAdd1Method m.class.classW, 'o2String return substr(m, 2)'
or = classNew('n ORun u',
, 'm oRun call err "call of abstract method oRun"',
, 'm o2File return oRun2File(m)',
, 'm o2String return jCatLines(oRun2File(m), fmt)')
/* oRunner does not work yet ||||| */
rc = classNew('n* ORun u ORun, m oRun call oClassAdded arg(2)')
call oAddMethod rc'.OMET', rc
call classAddedRegister oMutate(mNew(), rc)
return
endProcedure oIni
/*--- when notified about a new class cl, build the redundancies ----*/
oClassAdded: procedure expose m.
parse arg cl
m.class.o2c.cl = m.class.class
call oAddMethod cl'.OMET', cl
new = "m.class.o2c.m =" cl
if m.cl.flds.0 > 0 | m.cl.stms.0 > 0 then
new = new"; call oClear m, '"cl"'"
new = new";" classMet(cl, 'new', '')
if cl == m.class.class then
call mAlias 'CLASS', cl
else /* object adresses */
call mNewArea cl, 'O.'substr(cl,7), new
if m.cl \== 'u' | m.cl.name == '' then
return
call mAlias cl, m.cl.name
new = 'new'
m.cl.oMet.new = ''
co = '' /* build code for copy */
do fx=1 to m.cl.flds.0
nm = m.cl.flds.fx
if translate(nm) == nm & \ abbrev(nm, 'GG') ,
& pos('.M.', nm'.') < 1 & pos('.T.', nm'.') < 1 then
co = co'm.t'nm '= m.m'nm';'
else
co = co 'f='quote(substr(nm, 2))';m.t.f = m.m.f;'
end
do fx=1 to m.cl.stms.0
nm = m.cl.stms.fx
sc = m.cl.stms.fx.class
if nm == ''then
co = co "m.t.0=m.m.0;" ,
"do sx=1 to m.m.0;" ,
"call oClaCopy '"sc"',m'.'sx, t'.'sx; end;"
else
co = co "st='"substr(nm, 2)"';m.t.st.0=m.m.st.0;",
"do sx=1 to m.m.st.0;",
"call oClaCopy '"sc"',m'.'st'.'sx, t'.'st'.'sx; end;"
end
p = cl'.OMET.oCopy'
if symbol('m.p') \== VAR then
m.p = co
return
endProcedure oClassAdded
/*--- add the methods of class cl to the methodtable mt -------------*/
oAddMethod: procedure expose m.
parse arg mt, cl
if pos(m.cl, 'frsv') > 0 then
return
if m.cl = 'm' then do
nm = m.cl.name
m.mt.nm = m.cl.met
return
end
/* if m.cl.class \== '' then
call oAddMethod mt, m.cl.class
*/ do x=1 to m.cl.0
call oAddMethod mt, m.cl.x
end
return
endProcedure oAddMethod
/* add 1 method to a completed class and its subclasses -------------*/
oAdd1Method: procedure expose m.
parse arg clNm, met code
cl = classAdd1Method(clNm, met code)
m.cl.omet.met = code
call oAdd1MethodSubs cl, met code
return cl
endProcedure oAdd1Method
/* add 1 method code to OMET of all subclasses of cl -------------*/
oAdd1MethodSubs: procedure expose m.
parse arg cl, met code
do sx=1 to m.cl.sub.0
sc = m.cl.sub.sx
if pos(m.sc, 'nvw') > 0 then do
do mx=1 to m.sc.0
ms = m.sc.mx
if m.ms == 'm' & m.ms.name == met then
call err 'method' med 'already in' sc
end
m.sc.omet.met = code
end
call oAdd1MethodSubs sc, met code
end
return cl
endProcedure oAdd1MethodSubs
/*--- create an an object of the class className
mutate it to class but DO NOT call it's new method ----------*/
oBasicNew: procedure expose m.
parse arg cl
return oMutate(mBasicNew(cl), cl)
/*--- create an an object of the class className
and call it's new method ------------------------------------*/
oNew: procedure expose m.
signal labelMNew /* work is done there | ???? remove */
/*--- return the class of object obj --------------------------------*/
objClass: procedure expose m.
parse arg obj
if symbol('m.class.o2c.obj') == 'VAR' then
return m.class.o2c.obj
if abbrev(obj, m.class.escW) then
return m.class.classW
if abbrev(obj, 'CLASS.CAST.') then
return substr(obj, 12, pos(':', obj, 12)-12)
if arg() >= 2 then
return arg(2)
return err('objClass no class found for object' obj)
endProcedure objClass
oKindOf: procedure expose m.
parse arg obj, sup
cl = objClass(obj, '')
if cl == '' then
return 0
return classInheritsOf(cl, class4name(sup))
endProcedure oKindOf
classInheritsOf: procedure expose m.
parse arg cl, sup /* wkTst optimierung in classAdded */
if cl == sup then
return 1
do while m.cl \== 'n' & m.cl \== 'u'
if m.cl.class == '' then
return 0
cl = m.cl.class
end
do cx=1 to m.cl.0
d = m.cl.cx
if m.d == 'u' then
if classInheritsOf(d, sup) then
return 1
end
return 0
endProcedure classInheritsOf
classSetMet: procedure expose m.
parse arg na, me, code
if symbol('m.class.n2c.na') \== 'VAR' then
call err 'no class' na 'in classMet('na',' me')'
cl = m.class.n2c.na
if symbol('m.cl.oMet.me') \== 'VAR' then
call err 'no method in classMet('na',' me')'
m.cl.oMet.me = code
return cl
endProcedure classSetMet
/*--- return the code of method me of the class with name na --------*/
classMet: procedure expose m.
parse arg na, me
if symbol('m.class.n2c.na') \== 'VAR' then
call err 'no class' na 'in classMet('na',' me')'
cl = m.class.n2c.na
if symbol('m.cl.oMet.me') == 'VAR' then
return m.cl.oMet.me
if arg() >= 3 then
return arg(3)
call err 'no method in classMet('na',' me')'
endProcedure classMethod
/*--- set m, ggClass, ggCode to the address, class and code
of method me of object m ------------------------------------*/
objMetClaM: procedure expose m. m ggClass ggCode
parse arg m, me
if symbol('m.class.o2c.m') == 'VAR' then
ggClass = m.class.o2c.m
else if abbrev(m, 'CLASS.CAST.') then
parse var m 'CLASS.CAST.' ggClass ':' m
else
return err('no class found for object' m)
if symbol('m.ggClass.oMet.me') == 'VAR' then
ggCode = m.ggClass.oMet.me
else
call err 'no method' me 'in class' className(ggClass),
'of object' m
return
endProcedure objMetClaM
/*--- return the code of method me of object obj --------------------*/
objMet: procedure expose m.
parse arg obj, me
/* handle the easy and frequent case directly */
if symbol('m.class.o2c.obj') == 'VAR' then
c = m.class.o2c.obj
else if abbrev(obj, m.class.escW) then
c = m.class.classW
else do
call objMetClaM obj, me
return 'M="'m'";'ggCode
end
if symbol('m.c.oMet.me') == 'VAR' then
return m.c.oMet.me
return err('no method' me 'in class' className(c) 'of object' obj)
endProcedure objMet
/*--- return the stem of fieldnames of object m ---------------------*/
oFlds: procedure expose m.
parse arg m
return objClass(m)'.FLDS'
endProcedure oFlds
/*--- return the contents of field f navigation along path ----*/
oGet: procedure expose m.
parse arg obj, path, clazz
nullNew = 0
ret = oAccPath(obj, path, clazz)
if ret == 1 then
ret = oAccStr(m, cl)
if ret == 1 then
return str
return err(ret 'in oGet('obj',' path')')
endProcedure oGet
oAccStr: procedure expose m. str
parse arg m, cl
if cl == m.class.classV then
str = m.m
else if m.cl.valueCl == '' then
return 'no value @' m 'class' className(cl)
else if m.m == '' then
return 'null @' m 'class' className(cl)
else if abbrev(m, m.class.escW) then
str = substr(m ,2)
else
str = o2String(m.m)
return 1
endProcedure oAccStr
oGetO: procedure expose m.
parse arg obj, path, opt, clazz
nullNew = pos('n', opt) > 0
ret = oAccPath(obj, path, clazz)
if ret == 1 then
ret = oAccO(m, cl, opt)
if ret == 1 then
return ref
else
return err(ret 'in oGetO('obj',' path')')
endProcedure oGetO
oAccO: procedure expose m. ref
parse arg m, cl, opt
if cl == m.class.classV then do
ref = s2o(m.m)
end
else if m.cl \== 'r' then do
ref = m
end
else if m.m == '' then do
if opt == '-b' then do
m.m = jBuf()
end
else if opt == '-n' then do
rsn = oRefSetNew(m, cl)
if rsn \==1 then
return rsn
end
ref = m.m
end
else if objClass(m.m, 0) \== 0 then do
ref = m.m
end
else do
return 'no class for' m.m '@' m 'class' cl
end
return 1
endProcedure oAccO
oPut: procedure expose m.
parse arg obj, path, str
nullNew = 1
res = oAccPath(obj, path)
if res == 1 then
res = ocPut(m, cl, str)
if res == 1 then
return str
return err(res 'in oPut('obj',' path',' str')')
endProceudre oPut
ocPut: procedure expose m.
parse arg m, cl, str
if m.cl.valueCl == m.class.classV then
m.m = str
else if m.cl.valueCl \== '' then
m.m = s2o(str)
else
return 'no value @' m 'class' className(cl)
return 1
endProcedure ocPut
oPutO: procedure expose m.
parse arg obj, path, ref
nullNew = 1
res = oAccPath(obj, path)
if res == 1 then
res = ocPutO(m, cl, ref)
if res == 1 then
return ref
return err(ret 'in oPut('obj',' path',' ref')')
endProcedure oPutO
ocPutO: procedure expose m.
parse arg m, cl, ref
if m.cl.valueCl == m.class.classV then
m.m = o2string(ref)
else if m.cl.valueCl \== '' then
m.m = ref
else if m.cl.stemCl \== '' then
return 'implement put to stem'
else
return 'no value @' m 'class' className(cl)
return 1
endProcedure ocPutO
oClear: procedure expose m.
parse arg obj, cl
if cl == '' then
cl = objClass(obj)
do fx=1 to m.cl.flds.0
f1 = m.cl.flds.fx
o1 = obj || f1
if f1 == '' then
c1 = cl
else do
c1 = substr(f1, 2)
c1 = m.cl.f2c.c1
end
if c1 == m.class.classW then
m.o1 = m.class.escW
else
m.o1 = ''
end
do sx=1 to m.cl.stms.0
f1 = obj || m.cl.stms.sx
m.f1.0 = 0
end
return obj
endProcedure oClear
oAccPath: procedure expose m. m cl nullNew
parse arg m, pa, cl
if cl == '' & m \== '' then do
cl = objClass(m)
end
if pa == '' then
return 1
if abbrev(pa, m.class.cRef) ,
| (\ m.cl.hasFlds & abbrev(pa, m.class.cNav)) then do
if pa == m.class.cRef & m.cl.valueCl == m.class.classV then do
cl = m.class.classV
return 1
end
if (m.cl.valueCl == '' | m.cl.valueCl == m.class.classV) ,
& m.cl \== 'r' then
return 'no reference @' m 'class' cl
if m.m = '' then do
if \ nullNew then
return 'null @' m 'class' className(cl)
rsn = oRefSetNew(m, cl)
if rsn \== 1 then
return rsn
end
return oAccPath(m.m, substr(pa, 2))
end
if pos(left(pa, 1), m.class.cPath) > 0 then
return oAccPath(m, substr(pa, 2), cl)
px = verify(pa, m.class.cPath, 'm')
if px < 1 then
px = length(pa)+1
fn = left(pa, px-1)
pa = substr(pa, px)
if symbol('m.cl.f2c.fn') == 'VAR' then
return oAccPath(m'.'fn, pa, m.cl.f2c.fn)
if m.cl.stemCl=='' | fn=='' | verify(fn, '0123456789','n')>0 then
return 'no field' fn '@' m 'class' className(cl)
if fn == 0 then
return oAccPath(m'.0', pa, m.class.classV)
if abbrev(fn, 0) | verify(m.m.0, '0123456789', 'n') > 0,
| fn > m.m.0 then
return 'bad stem index' fn'>'m.m.0 '@' m 'class' className(cl)
return oAccPath(m'.'fn, pa, m.cl.stemCl)
endProcedure oAccPath
oRefSetNew: procedure expose m.
parse arg m, cl
cr = m.cl.valueCl
if m.cr.class = '' then
return 'no class for null @' m 'class' className(cl)
if m.cr.class = m.class.classW then
m.m = o2s()
else if m.cr \== 'r' then
return 'class' className(cl) 'not ref'
else
m.m = mNew(m.cr.class)
return 1
endProcedure oRefSetNew
/*--- mutate object m to the class named name -----------------------*/
oMutate: procedure expose m.
parse arg m, name
m.class.o2c.m = class4Name(name)
return m
endProcedure oMutate
/*--- return object obj cast'd to class named cl --------------------*/
oCast: procedure expose m.
parse arg obj, cl
if abbrev(obj, 'CLASS.CAST.') then
obj = substr(obj, 1 + pos(':', obj, 12))
return 'CLASS.CAST.'class4Name(cl)':'obj
endProcedure oCast
/*--- copy object m of class c to t ---------------------------------*/
oClaCopy: procedure expose m.
parse arg ggCla, m, t
if t == '' then do
if ggCla == m.class.classW then
return m
t = mBasicNew(ggCla)
end
else if ggCla == m.class.classW then do
m.t = o2String(m)
m.class.o2c.t = m.class.classV
return t
end
ggCode = ggCla'.OMET.oCopy'
interpret m.ggCode
m.class.o2c.t = ggCla
return t
endProcedure oClaCopy
/*--- copy object m to t --------------------------------------------*/
oCopy: procedure expose m.
parse arg m, t
return oClaCopy(objClass(m), m, t)
endProcedure oCopy
/*--- copy object to a newly created object -------------------------*/
oCopyNew: procedure expose m.
parse arg m
if symbol('m.class.o2c.m') == 'VAR' then
return oCopy(m, mBasicNew(m.class.o2c.m))
return oCopy(m, mBasicNew(m.class.classV))
endProcedure oCopyNew
/*--- return a new instance of a subclass of Run
with code code in method oRun -------------------------------*/
oRunner: procedure expose m.
if arg() >= 1 then
r = oNew(classNew('n* ORun u ORun, m oRun' arg(1)))
else
r = oNew(classNew('n| ORun u ORun'))
return r
endProcedure oRunner
/*--- set code for runner -------------------------------------------*/
oRunnerCode: procedure expose m.
parse arg r, code
call classSetMet objClass(r), 'oRun', code
return r
endProcedure oRunnerCode
/*--- run method oRun of object m -----------------------------------*/
oRun: procedure expose m.
parse arg m, arg, arg2, arg3
interpret objMet(m, 'oRun')
return
endProcedure oRun
/*--- run method oRun and return output in new JBuf ------------------*/
oRun2File: procedure expose m.
parse arg rn
b = jBuf()
call pipeBeLa '>' b
call oRun rn
call pipeEnd
return b
endProcedure oRun2File
/*--- cast the object to a file -------------------------------------*/
o2File: procedure expose m.
parse arg m
interpret objMet(m, 'o2File')
call err 'o2file did not return'
endProcedure o2File
/*--- cast the object to a String -----------------------------------*/
o2String: procedure expose m.
parse arg m, fmt
if opt == '' then
opt = '-b '
interpret objMet(m, 'o2String')
return err('o2String did not return')
endProcedure o2String
/*--- return true if object is kind of String------------------------*/
oStrOrObj: procedure expose m. ggStr ggObj ggCla
parse arg ggObj
ggCla = objClass(ggObj, '')
if ggCla == '' then do
ggStr = ggObj
ggObj = ''
return 1
end
else if wordPos(ggCla, m.class.classV m.class.classW) > 0 then do
ggStr = o2String(ggObj)
ggObj = ''
return 1
end
else do
ggStr = ''
return 0
end
endProcedure oStrOrObj
/*--- return true if object is kind of String ----- ???? -------------*/
oStrOrFile: procedure expose m. ggStr ggObj ggCla
parse arg m
if oStrOrObj(m) then
return 1
ggObj = o2File(ggObj)
return 0
endProcedure oStrOrFile
/*--- return a short string representation of an object -------------*/
o2Text: procedure expose m.
parse arg m, maxL
if m == '' then
return '@ null object'
if maxL == '' then
maxL = 80
cl = objClass(m, '?')
if cl = m.class.classV then
l = m.m
else if cl == m.class.classW then
l = substr(m, 2)
else if cl == '?' then
l = '@'m 'class=???'
else do
l = '@'m 'class='className(cl)
ff = cl'.FLDS'
do fx=1 to m.ff.0 while length(l) < maxL + 3
if m.ff.fx == '' then
l = l', .='m.m
else do
f1 = substr(m.ff.fx, 2)
l = l',' f1'='m.m.f1
end
end
end
if length(l) <= maxL then
return l
return left(l, maxL-3)'...'
endProcedure o2Text
/*--- cast a String to an object -----------------------------------*/
s2o: procedure expose m.
parse arg str
return m.class.escW || str
return r
endProcedure s2o
oIfStr: procedure expose m.
parse arg m
if length(m) > 200 then
return m
cl = objClass(m, '')
if cl = '' then
return m
else if cl = m.class.classV then
return = m.m
else if cl == m.class.classW then
return = substr(m, 2)
else if arg() >= 2 then
return arg(2)
else
call err m 'of class' className(cl) 'not kind of string'
endProcedure oIfStr
/* copy o end *******************************************************/
/* copy class begin **************************************************
a class has fields and methods,
the class module handles only the metadata,
object handling (instanciation, methodcalls etc.) is in O
classes are represented by a metadata tree,
its nodes of class class have diffenrent types:
class subTypes (implemented as choices)
'u' = union: NAME -> name of class if <> '',
stem -> references component classes
'f' = field: NAME -> fieldName (x.name),
CLASSS -> reference to class of fieldValue
's' = stem: class -> ref to class at each stem element
'c' = choice: NAME -> selection value,
CLASS -> ref to class of choice
'm' = method: NAME -> methodName,
MET -> rexxCode
'r' = reference CLASS -> ref to type at reference
special classes
'v' = Value String Value
'w' = ValueAsA StringValue packed into an adress (prefix escW)
'o' = AnyClass any class with dynamic classLookup on object
formal definition, see classIni
class expression (ce) allow the following syntax
ce = className | classAdr | 'n'('?','*','|')? name union | union
| 'f' name ce | 's' ce | 'c' name ce | 'm' name code | r ce?
union = 'u' (ce (',' ce)*)?
the modifiers of 'n' means
none: create new class, fail if name already defined
'?': create new class or return old of that name
'*': use an exisiting class of that definition
or create new class with a unique name
'|': create a new class with a unique name
'm' extends to then end of the ce (line)
'u' allows several components, in classNew also multiple args
Achtung, aber NICHT rekursiv|
***********************************************************************/
classIni: procedure expose m.
if m.class.ini == 1 then
return
m.class.ini = 1
call mapIni
call mNewArea 'CLASS', 'CLASS'
call mapReset 'CLASS.N2C' /* name to class */
/* to notify other modules (e.g. O) on every new named class */
m.class.addedSeq.0 = 0
m.class.addedListeners.0 = 0
m.class.classV = classBasicNew('u', 'v')
m.class.classW = classBasicNew('u', 'w')
m.class.classO = classBasicNew('u', 'o')
cr = mIterBegin('CLASS')
do while assNN('cr', mIter(cr))
call classAddedNotify cr
end
m.class.class = classNew('n class u v',
, 'c u u f NAME v, s r class',
, 'c f u f NAME v, f CLASS r class',
, 'c s f CLASS r class' ,
, 'c c u f NAME v, f CLASS r class',
, 'c m u f NAME v, f MET v' ,
, 'c r f CLASS r class' )
m.class.cNav = '.'
m.class.cRef = '|'
m.class.cDot = '%'
m.class.cPath = m.class.cNav || m.class.cRef || m.class.cDot
m.class.classR = classNew('r')
return
endProcedure classIni
/*--- return the name of a class if it exists otherwise the class ---*/
className: procedure expose m.
parse arg cl
if m.cl = 'u' & m.cl.name \= '' then
return m.cl.name
else
return cl
endProcedure class4Name
/*--- return class of given name or class ---------------------------*/
class4Name: procedure expose m.
parse arg nm
if symbol('m.class.n2c.nm') == 'VAR' then
return m.class.n2c.nm
if arg() > 1 then
return arg(2)
call err 'no class' nm
endProcedure class4Name
classBasicNew: procedure expose m.
parse arg ty, nm, cl, nmTy
n = mNew('CLASS')
m.n = ty
m.n.name = nm
m.n.nameComp = nm
if ty == 'u' & nm \== '' then do
if pos(nmTy, '*|') > 0 then do
m.n.name = nm || substr(n, 1+lastPos('.', n))
if nmTy == '*' then
m.n.nameComp = nm'*'
else
m.n.nameComp = m.n.name
end
call mapAdd class.n2c, m.n.name, n
end
call mapAdd class.n2c, n, n
m.n.class = ''
m.n.met = ''
m.n.0 = 0
m.n.sub.0 = 0
m.n.super.0 = 0
if length(ty) \== 1 | pos(ty, 'ufscrm') < 1 then
call err 'bad type' ty': classBasicNew('ty',' nm',' cl')'
else if nm == '' & pos(ty, 'fm') > 0 then
call err 'empty name: classBasicNew('ty',' nm',' cl')'
else if nm \== '' & ty \== 'c' ,
& ( verify(nm, '0123456789') < 1 ,
| verify(nm, ' .*|@', 'm') > 0 ) then
call err 'bad name' nm': classBasicNew('ty',' nm',' cl')'
else if nm \= '' & pos(ty, 'rs') > 0 then
call err 'name for type' ty': classBasicNew('ty',' nm',' cl')'
else if pos(ty, 'fcrs') > 0 then do
if cl \== '' then
m.n.class = mapGet(class.n2c, cl)
else if ty == 'r' then
m.n.class = m.class.classO
/* else say 'cl leer' ty nm nmTy ???????*/
end
else if ty == 'm' then
m.n.met = cl
else if cl \== '' then
call err 'class for type' ty': classBasicNew('ty',' nm',' cl')'
return n
endProcedure classBasicNew
classNew: procedure expose m.
parse arg clEx 1 ty rest
if abbrev(ty, 'n') then do
if wordPos(ty, 'n n? n* n|') < 1 then
call err 'bad type' ty': classNew('clEx')'
nmTy = right(ty, 1)
parse var rest nm ty rest
if ty \== 'u' then
call err 'class name' nm 'without u: classNew('clEx')'
if nmTy == 'n' then do
if mapHasKey(class.n2c, nm) then
call err 'class' nm 'already defined: classNew('clEx')'
end
else if nmTy == '?' then do
if mapHasKey(class.n2c, nm) then
return mapGet(class.n2c, nm)
end
else if nmTy == '*' then do
if arg() \== 1 then
call err 'arg()='arg() 'for n* : classNew('clEx')'
if mapHasKey(class.n2c, clEx) then
return mapGet(class.n2c, clEx)
end
n = classBasicNew('u', nm, , nmTy)
end
else do
nmTy = ''
if arg() \== 1 then
call err 'arg()='arg() 'without name: classNew('clEx')'
if mapHasKey(class.n2c, clEx) then
return mapGet(class.n2c, clEx)
if length(ty) <> 1 | pos(ty, 'ufscmr') < 1 then
call err 'bad type' ty': classNew('clEx')'
nm = ''
if pos(ty, 'usr') < 1 then
parse var rest nm rest
if ty = 'u' then do
n = classBasicNew(ty)
end
else if ty = 'm' then do
n = classBasicNew(ty, nm, rest)
rest = ''
end
else do
parse var rest t1 rest
if wordPos(t1, 'u f s c m r') > 0 then do
n = classBasicNew(ty, nm)
m.n.class = classNew(t1 rest)
rest = ''
end
else do
n = classBasicNew(ty, nm, t1)
end
end
end
if ty \== 'u' then do
if rest \== '' then
call err 'rest' rest 'but end of classExp expected:' clEx
end
else do
lx = 0
do while lx < length(rest)
cx = pos(',', rest, lx+1)
if cx <= lx | word(substr(rest, lx+1), 1) == 'm' then
cx = length(rest)+1
a = mAdd(n, classNew(strip(substr(rest, lx+1, cx-lx-1))))
lx=cx
end
pref = ''
do ax=2 to arg()
if length(arg(ax)) == 1 & arg(ax) \== ' ' then
pref = arg(ax)' '
else
call mAdd n, classNew(pref || arg(ax))
end
end
cr = mIterBegin('CLASS')
do while assNN('cr', mIter(cr)) & \ classEqual(n, cr)
end
isNew = cr == n
if \ isNew then do
if mapRemove(class.n2c, n) \== n then
call err 'mapRemove('n') mismatch'
if m.n == 'u' & m.n.name \== '' then
if mapRemove(class.n2c, m.n.name) \== n then
call err 'mapRemove('m.n.name') mismatch'
call mFree n
n = cr
end
if nmTy == '' | nmTy == '*' then
call mapAdd class.n2c, clEx, n
if isNew then
call classAddedNotify n
return n
endProcedure classNew
classAdd1Method: procedure expose m.
parse arg clNm, met code
cl = class4Name(clNm)
if pos(m.cl, 'uvw') < 1 then
call err 'class not nvw but' m.cl,
'in classAdd1Method('clNm',' met code')'
do sx = 1 to m.cl.0
su = m.cl.sx
if m.cl.sx = 'm' & m.cl.name == met then
call err 'met' met 'already in' clNm
end
call mAdd cl, classNew('m' met code)
return cl
endProcedure classAdd1Method
/*--- register a listener for newly defined classes
and call it for all already defined classes -----------------*/
classAddedRegister: procedure expose m.
parse arg li
call mAdd 'CLASS.ADDEDLISTENERS', li
do cx = 1 to m.class.addedSeq.0
call oRun li, m.class.addedSeq.cx
end
return
endProcedure classAddedRegister
/*--- to notify all listeners about a newly defined classes --------*/
classAddedNotify: procedure expose m.
parse arg cl
call mAdd 'CLASS.ADDEDSEQ', cl
if m.cl == 'u' then
call classSuperSub cl
m.cl.flds.0 = 0
m.cl.stms.0 = 0
m.cl.stemCl = ''
m.cl.valueCl = ''
call classAddFields cl, cl
m.cl.hasFlds = m.cl.flds.0 > 1 ,
| (m.cl.flds.0 == 1 & m.cl.flds.1 \== '') | m.cl.stms.0 > 0
do lx = 1 to m.class.addedListeners.0
call oRun m.class.addedListeners.lx, cl
end
return
endProcedure classAddedNotify
/*--- add supper and sub links for class cl -------------------------*/
classSuperSub: procedure expose m.
parse arg cl
do ux=1 to m.cl.0
u1 = m.cl.ux
if m.u1 == 'u' then do
if mPos(cl'.SUPER', u1) > 0 then
call err u1 'is already in' cl'.SUPER.'sx ,
|| ': classSuperSub('cl')'
call mAdd cl'.SUPER', u1
if mPos(cl'.SUB', cl) > 0 then
call err cl 'is already in' u1'.SUB.'sx ,
|| ': classSuperSub('cl')'
call mAdd u1'.SUB', cl
end
end
return
endProcedure classSuperSub
/*--- add the the fields of class cl to stem f ----------------------*/
classAddFields: procedure expose m.
parse arg f, cl, nm
n1 = substr(nm, 1+abbrev(nm, '.') )
if symbol('m.f.f2c.n1') \== 'VAR' then
m.f.f2c.n1 = cl
/* else if cl == m.f.f2c.n1 then
return 0 */
if cl == m.class.classV | cl == m.class.classW | m.cl=='r' then do
if nm == '' then do
if m.f.valueCl \== '' then
return err('value mistmatch')
m.f.valueCl = cl
end
if nm == '' then do
call mMove f'.FLDS', 1, 2
m.f.flds.1 = ''
end
else do
call mAdd f'.FLDS', nm
end
return 0
end
if m.cl = 's' then do
if m.cl.class == '' then
call err 'stem null class'
a1 = mAdd(f'.STMS', nm)
m.a1.class = m.cl.class
if nm == '' then
m.f.stemCl = m.cl.class
return 0
end
if m.cl = 'f' then
return classAddFields(f, m.cl.class, nm'.'m.cl.name)
if m.cl.class \== '' then
return classAddFields(f, m.cl.class, nm)
do tx=1 to m.cl.0
call classAddFields f, m.cl.tx, nm
end
return 0
endProcedure classAddFields
/*--- return true iff the two classes are equal -------------------*/
classEqual: procedure expose m.
parse arg l, r
if m.l \== m.r | m.l.nameComp \== m.r.nameComp ,
| m.l.class \== m.r.class | m.l.0 \== m.r.0 then
return 0
if m.l.met \== m.r.met then
return 0
do sx=1 to m.l.0
if m.l.sx \== m.r.sx then
return 0
end
return 1
endProcedure classEqual
/*--- print object ---------------------------------------------------*/
objOut: procedure expose m.
parse arg m, pr, p1
c = objClass(m, '')
if c == '' then
call out p1 'no class for' m
else if c == m.class.classV then
call out p1 || m.m
else if c == m.class.classW then
call out p1 || o2String(m)
else
call classOutDone c, m, pr, p1
return
endProcedure objOut
/*--- recursively output (with out:) the object a with class t -------*/
classOut: procedure expose m.
parse arg t, a, pr, p1
return classOutDone(if(t=='',m.class.classO, t), a, pr, p1)
endProcedure classOut
/*--- ouput object a with class t and stopper done ------------------*/
classOutDone: procedure expose m. done.
parse arg t, a, pr, p1
if p1 == '' then
p1 = pr
if right(p1, 1) \== ' ' then
p1 = p1' '
if done.ini \== 1 then do
done.ini = 1
t = class4Name(t, t)
p1 = p1'@'a' '
end
if done.t.a == 1 then
return out(p1'done :'className(t) '@'a)
done.t.a = 1
if t = m.class.classO then do
if a == '' then
return out(p1'obj null')
t = objClass(a, '')
if t = '' then
return out(p1'obj has no class @'m.a)
else
return classOutDone(t, a, pr, p1'isA')
end
if t == m.class.classV then
return out(p1'=' m.a)
if t == m.class.classW == 'w' then
return out(p1'}' substr(a, 2))
if m.t == 'f' then
return classOutDone(m.t.class, a'.'m.t.name, pr, p1'.'m.t.name)
if m.t == 'r' then do
if m.a == '' then
return out(p1'refTo :'className(m.t.class) '@null@')
else
return classOutDone(m.t.class, m.a, pr,
, p1'refTo @'m.a)
end
if m.t = 'u' then do
t1 = m.t.1
vv = m.t.0 > 0 & m.t.1 == m.class.classV
call out p1 || if(m.t.name == '', 'union', ':'m.t.name) ,
|| copies(' =' m.a, vv)
do ux=1+vv to m.t.0
call classOutDone m.t.ux, a, pr' '
end
return 0
end
if m.t = 's' then do
call out p1'stem' m.a.0
do ux=1 to m.a.0
call classOutDone m.t.class, a'.'ux, pr' ', pr' .'ux
end
return 0
end
if m.t = 'c' then do
if m.t.name = m.a then
call classOutDone m.t.class, a, pr, p1'choice' m.a
return 0
end
if m.t = 'm' then
return 0
return err('bad class type' m.t)
endProcedure classOutDone
/* copy class end ***************************************************/
/* copy mapExp begin **************************************************/
mapVia: procedure expose m.
parse arg a, ky
sx = pos('|', ky)
if sx < 1 then
return mapGet(a, ky)
via = mapGet(a, left(ky, sx-1))
do while sx <= length(ky)
fx = sx+1
sx = pos('|', ky, fx)
if sx < 1 then
sx = length(ky) + 1
if sx = fx then do
if symbol('m.via') \== 'VAR' then
call err 'missing m.'via 'at' sx 'in mapVia('a',' ky')'
via = m.via
end
else do
f = substr(ky, fx, sx - fx)
if symbol('m.via.f') \== 'VAR' then
call err 'missing m.'via'.'f ,
'at' sx 'in mapVia('a',' ky')'
via = m.via.f
end
end
return via
endProcedure mapVia
mapExpAt: procedure expose m.
parse arg a, src, sx
m.map.ExpAt = 0
cx = pos('$', src, sx)
if cx < 1 then
return substr(src, sx)
res = substr(src, sx, cx-sx)
do forever
if substr(src, cx+1, 1) = '{' then do
ex = pos('}', src, cx+2)
if ex < 1 then
call err 'missing } after' substr(src, cx) 'in' src
res = res || mapVia(a, strip(substr(src, cx+2, ex-cx-2)))
ex = ex + 1
end
else do
ex = verify(src, m.mAlfDot, 'n', cx+1)
if ex < 1 then
return res || mapVia(a, substr(src, cx+1))
if ex = cx+1 then do
m.map.ExpAt = cx
return res
end
res = res || mapVia(a, substr(src, cx+1, ex-cx-1))
end
cx = pos('$', src, ex)
if cx < 1 then
return res || substr(src, ex)
res = res || substr(src, ex, cx-ex)
end
endProcedure mapExpAt
mapExp: procedure expose m.
parse arg a, src
res = mapExpAt(a, src, 1)
if m.map.ExpAt \== 0 then
call err 'mapExp stopped at' substr(src, map.ExpAt) 'in' src
return res
endProcedure mapExp
mapExpAllAt: procedure expose m.
parse arg a, dst, src, sx, cx
do while sx <= m.src.0
li = mapExpAt(a, m.src.sx, cx)
dx = m.map.ExpAt
if (cx=1 & dx = 0) | li \= '' then
call mAdd dst, li
if dx = 0 then do
cx = 1
sx = sx+1
end
else do
return sx dx
end
end
return ''
endProcedure mapExpAllAt
mapExpAll: procedure expose m.
parse arg a, dst, src
sto = mapExpAllAt(a, dst, src, 1, 1)
if sto == '' then
return
lx = word(sto, 1)
call err 'mapExpAll stopped at' sto':' m.src.lx
endProcedure mapExpAll
/* copy mapExp end ****************************************************/
/* copy map begin ******************************************************
a map stores values at keys
it may also maintain a list of keys
the basic ideas are similar to the java Interface java.util.Map
contrary to stems we also handle keys longer then 250 bytes
***********************************************************************/
/*--- initialize the module ------------------------------------------*/
mapIni: procedure expose m.
if m.map.ini = 1 then
return
m.map.ini = 1
call mIni
m.map.0 = 0
m.map.inlineSearch = 1
call mapReset map.inlineName, map.inline
return
endProcedure mapIni
mapInline: procedure expose m.
parse arg pName, opt
if mapHasKey(map.inlineName, pName) then do
im = mapGet(map.inlineName, pName)
if pos('l', opt) < 1 & symbol('m.im.0') \== 'VAR' then do
m.im.0 = m.im.lEnd - m.im.lBegin - 1
do ix=1 to m.im.0
m.im.ix = strip(sourceline(ix+m.im.lBegin), 't')
end
end
return im
end
name = '/'
do lx = m.map.inlineSearch to sourceline()
if \ abbrev(sourceline(lx), '$') then
iterate
li = sourceline(lx)
s1 = pos('/', li)+ 1
if s1 < 3 | s1 > 4 then
iterate
s2 = pos('/', li, s1)
if s2 <= s1 then
iterate
if s1 == 3 then do
if name \== substr(li, s1, s2-s1) then
iterate
im = 'MAP.INLINE.' || (m.map.inline.0+1)
call mapAdd map.inlineName, name, im
m.im.lBegin = lBeg
m.im.lEnd = lx
m.im.mark = mrk
if name == pName then do
m.map.inlineSearch = lx+1
return mapInline(pName)
end
name = '/'
end
else if \ mapHasKey(map.inlineName,
, substr(li, s1, s2-s1)) then do
lBeg = lx
mrk = substr(li, 2, s1-3)
name = substr(li, s1, s2-s1)
end
else do
name = '/'
end
end
if pos('r', opt) > 0 then
return ''
return err('no inline data /'pName'/ found')
endProcedure mapInline
/*--- create a new map ----------------------------------------------*/
mapNew: procedure expose m.
parse arg opt
m.map.0 = m.map.0 + 1
return mapReset('MAP.'m.map.0 , opt)
endProcedure mapNew
/*--- make an empty map, if opt <> '' maintain stem of keys
('K' in map.keys, '=' in a else in opt) --------------*/
mapReset: procedure expose m.
parse arg a, opt
if symbol('m.map.keys.a') == 'VAR' then
call mapClear a
if opt = '=' then
st = a
else if translate(opt) = 'K' then
st = 'MAP.KEYS.'a
else
st = opt
m.map.keys.a = st
if st \== '' then
m.st.0 = 0
return a
endProcedure
/*--- add a new key value pair to the map ----------------------------*/
mapAdd: procedure expose m.
parse arg a, ky, val
vv = mapValAdr(a, ky, 'a')
m.vv = val
return val
endProcedure mapAdd
/*--- change the value at a key or add key value ---------------------*/
mapPut: procedure expose m.
parse arg a, ky, val
vv = mapValAdr(a, ky, 'p')
m.vv = val
return val
endProcedure mapPut
/*--- return 1 if key ky exists in map a, 0 otherwise ----------------*/
mapHasKey: procedure expose m.
parse arg a, ky
return mapValAdr(a, ky) \== ''
endProcedure mapHasKey
/*--- return the value of key ky in map a if it exists,
else if called with a third argument return third argument
else issue an error ----------------------------------------*/
mapGet: procedure expose m.
parse arg a, ky
vv = mapValAdr(a, ky)
if vv \== '' then
return m.vv
else if arg() > 2 then
return arg(3)
else
return err('missing key in mapGet('a',' ky')')
endProcedure mapGet
/*--- return a stem of all keys --------------------------------------*/
mapKeys: procedure expose m.
parse arg a
if m.map.keys.a == '' then
call err 'mapKeys('a') with no keys'
return m.map.keys.a
endProcedure mapKeys
/*--- remove a key from the map, do nothing if it is missing ---------*/
mapRemove: procedure expose m.
parse arg a, ky
vv = mapValAdr(a, ky)
if vv == '' then
return ''
if m.map.keys.a \== '' then do
trace ?R /* not tested yet ???wkTest */
k = m.map.keys.a
mx = m.k.0
do i=1 to mx
if m.k.i == ky then do
m.k.i = m.k.mx
m.k.0 = mx - 1
return
end
end
end
val = m.vv
drop m.a.ky
return val
endProcedure mapRemove
/*--- remove all entries ---------------------------------------------*/
mapClear: procedure expose m.
parse arg a
st = mapKeys(a)
liLe = 243 - length(a)
do kx=1 to m.st.0
ky = m.st.kx
drop m.st.kx
if length(ky) <= liLe then do
drop m.a.ky
end
else do
adr = mapValAdr(a, ky)
if adr \== '' then do
ha = left(adr, lastPos('.', adr) - 3)
do i = 1 to m.ha.k.0
drop m.ha.k.i m.ha.v.i
end
drop m.ha.k.0
end
end
end
m.st.0 = 0
return a
endProcedure mapClear
/*--- return the value pointer for a key, '' if non existing
with fun = 'a' add a key, with 'p' put a key ------------*/
mapValAdr: procedure expose m.
parse arg a, ky, fun
if length(ky) + length(a) <= 243 then do
res = a'.'ky
if symbol('m.res') == 'VAR' then do
if fun == 'a' then
call err 'duplicate key' ky 'in map' a
return res
end
else if fun == '' then
return ''
end
else do
len = 243 - length(a)
q = len % 4
ha = a'.'left(ky, len - 2 * q) || substr(ky,
, (length(ky)-len) % 2 + 2 * q, q) || right(ky, q)
if symbol('M.ha.k.0') == 'VAR' then do
do i=1 to m.ha.k.0
if m.ha.k.i == ky then do
if fun == 'a' then
call err 'duplicate key' ky ,
'map' a 'hash' ha'.K.'i
return ha'.V.'i
end
end
end
else do
i = 1
end
if fun == '' then
return ''
if i > 9 then
call err 'overflow long key' y 'in map' a 'hash' ha'.K.'i
m.ha.k.0 = i
m.ha.k.i = ky
res = ha'.V.'i
end
if m.map.keys.a \== '' then
call mAdd m.map.Keys.a, ky
m.res = ''
return res
endProcedure mapValAdr
/* copy map end *******************************************************/
/* copy m begin ********************************************************
we use variables as follows
m. stem m: all global data and object data that must survive
a procedure call (m for memory in Memoria of B5000)
m.<mbr>.** to avoid conflicts: every rexx Module (copy) should
only allocate addresses m.<mbr>.** with <mbr> the name of
the rexx module
we pass parameters around (e.g. a=address, m=memory, st=stem)
and the called function may use m.a or m.a.subField etc.
gg*: local variable in subroutines without procedure
everything else: temporary data within procedure
every subroutine is declared as procedure expose m.
(also if no m. variable is used, because e.g. of error handling)
the few subroutines that cannot use procedure, should use only
variables starting with gg
***********************************************************************/
/*---make an area -----*/
mNewArea: procedure expose m.
parse arg nm, adr, newCd, freeCd
m.m.area.0 = m.m.area.0 + 1
a = 'M.AREA.'m.m.area.0
if adr == '=' then
adr = nm
else if adr == '' then
adr = 'M.'m.m.area.0
if symbol('m.m.n2a.adr') == 'VAR' then
call err 'adr' adr 'for area' nm 'already used'
m.m.n2a.adr = a
call mAlias adr, nm
m.m.p2a.adr = a
m.a.0 = 0
m.a.free.0 = 0
m.a.address = adr
m.a.newCode = newCd
m.a.freeCode = freeCd
return nm
endProcedure mNewArea
mAlias: procedure expose m.
parse arg oldNa, newNa
if symbol('m.m.n2a.oldNa') \== 'VAR' then
call err 'area' oldNa 'does not exist'
if oldNa == newNa then
return
if symbol('m.m.n2a.newNa') == 'VAR' then
call err 'newName' newNa 'for old' oldNa 'already used'
m.m.n2a.newNa = m.m.n2a.oldNa
return
endProcedure mAlias
mBasicNew: procedure expose m. ggArea
parse arg name
if symbol('m.m.n2a.name') \== 'VAR' then
call err 'area' name 'does not exists'
ggArea = m.m.n2a.name
if m.ggArea.free.0 > 0 then do
fx = m.ggArea.free.0
m.ggArea.free.0 = fx-1
m = m.ggArea.free.fx
end
else do
m.ggArea.0 = m.ggArea.0 + 1
m = m.ggArea.address'.'m.ggArea.0
end
return m
endProcedure mBasicNew
mNew: procedure expose m.
labelMNew:
parse arg name, arg, arg2, arg3
m = mBasicNew(name)
interpret m.ggArea.newCode
return m
endProcedure mNew
mReset: procedure expose m.
parse arg a, name
ggArea = m.m.n2a.name
m = a
interpret m.ggArea.newCode
return m
endProcedure mReset
mFree: procedure expose m.
parse arg m
p = 'M.P2A.'left(m, lastPos('.', m)-1)
area = m.p
if m.area.freeCode \== '' then
interpret m.area.freeCode
fx = m.area.free.0 + 1
m.area.free.0 = fx
m.area.free.fx = m
return
endProcedure mFree
/*--- iterate over all allocate elements of an area ------------------*/
mIterBegin: procedure expose m.
parse arg nm
a = m.m.n2a.nm
return m.a.address'.0'
endProcedure mIterBegin
mIter: procedure expose m.
parse arg cur
if cur == '' then
return ''
lx = lastPos('.', cur)
p = 'M.P2A.'left(cur, lx-1)
a = m.p
ix = substr(cur, lx+1)
do ix=ix+1 to m.a.0
n = m.a.address'.'ix
do fx=1 to m.a.free.0 while m.a.free \== n
end
if fx > m.a.free.0 then
return n
end
return ''
endProcedure mIter
/*--- cut stem a to length len ---------------------------------------*/
mCut: procedure expose m.
parse arg a, len
m.a.0 = len
return a
endProcedure mCut
/*--- add one or several arguments to stem m.a -----------------------*/
mAdd: procedure expose m.
parse arg a
ix = m.a.0
do ax = 2 to arg()
ix = ix + 1
m.a.ix = arg(ax)
end
m.a.0 = ix
return a'.'ix
endProcedure mAdd
/*--- pop last element from stem m.a ---------------------------------*/
mPop: procedure expose m.
parse arg a
ix = m.a.0
if ix < 1 then
call err 'pop from empty stem' a
m.a.0 = ix-1
return m.a.ix
endProcedure mPop
/*--- add to m.dst.* a (sub)sequence of m.src.* ----------------------*/
mAddSt: procedure expose m.
parse arg dst, src
dx = m.dst.0
do sx = 1 to m.src.0
dx = dx + 1
m.dst.dx = m.src.sx
end
m.dst.0 = dx
return
endProcedure mAddSt
/*--- find position of first occurrence of ele in stem m,
return 0 if nonemove a part of a stem -----------------------*/
mPos: procedure expose m.
parse arg m, ele, sx
if sx == '' then
sx = 1
do x=sx to m.m.0
if m.m.x = ele then
return x
end
return 0
endProcedure mPos
/*--- move a part of a stem ------------------------------------------*/
mMove: procedure expose m.
parse arg m, sx, dx
if dx < sx then do
y = dx
do x=sx to m.m.0
m.m.y = m.m.x
y = y + 1
end
end
else if dx > sx then do
y = m.m.0 + dx - sx
do x=m.m.0 by -1 to sx
m.m.y = m.m.x
y = y - 1
end
end
m.m.0 = m.m.0 + dx - sx
return
endProcedure mMove
/*--- insert a stem into another ------------------------------------*/
mInsert: procedure expose m.
parse arg m, tx, st
call mMove m, tx, tx+m.st.0
do sx=1 to m.st.0
dx = tx-1+sx
m.m.dx = m.st.sx
end
return
endProcedure mInsert
/*--- strip all elements of a stem -----------------------------------*/
mStrip: procedure expose m.
parse arg st, opt
if opt == '' then
opt = 'b'
do x=1 to m.st.0
m.st.x = strip(m.st.x, opt)
end
return st
endProcedure mStrip
/* cat the lines of a stem, possibly repeated --------------------------
args: stem, fmt see fGen: -------------------------------------*/
mCat: procedure expose m.
parse arg st, fmt
if m.st.0 < 1 then
return ''
res = f(fmt, m.st.1)
do sx=2 to m.st.0
res = res || fPlus(fmt 'nxt', m.st.sx)
end
return res || fFld(fmt 'end')
endProcedure mCat
f: procedure expose m.
parse arg ggFmt, ggA1, ggA2
if symbol('M.F.FORMAT.ggFmt') == 'VAR' then
interpret M.F.FORMAT.ggFmt
else
interpret fGen(ggFmt)
endProcedure f
fPlus: procedure expose m.
parse arg ggFmt, ggA1, ggA2
interpret fFld(ggFmt)
endProcedure fPlus
fFld: procedure expose m.
parse arg ff
px = lastPos(' ', ff)
fld = substr(ff, px+1)
fmt = left(ff, px-1)
ff = 'F.FORMAT.'fmt'%-Q'fld
if symbol('M.ff') == 'VAR' then
return m.ff
call fGen fmt
if symbol('M.ff') == 'VAR' then
return m.ff
call err 'field' fld 'not in format' fmt
endProcedure fFld
/*--------------------------------------------------------------------
fGen: Format generator should be compatible with fPrint|
<<<< + extension of fPrint, - in fPrint but not implemented
+ \s a single space
+ \n a newLine
+ \% \@ \\ the escaped char
('@' argN? '.'? field)?'%' flags? width? ('.' precision)? specifier
specifier: is the most significant one and defines the type
- c Character a
- C Cut %-nC = left(v,n), %nC = right(v,n) %n.mC = substr(m, n)
- d or i Signed decimal integer
- e Scientific notation (mantissa/exponent) using e character 3.9265e+2
- E Scientific notation (mantissa/exponent) using E character 3.9265E+2
- f Decimal floating point
- g Use the shorter of %e or %f
- G Use the shorter of %E or %f
- o Unsigned octal 610
- S Strip(..., both)
- u Unsigned decimal integer
- x Unsigned hexadecimal integer
- X Unsigned hexadecimal integer (capital letters)
- p Pointer address
- n Nothing printed. The argument must be a pointer to a signed int, wh
+ % A % followed by another % character will write % to stdout. %
Flags:
- - Left-justify within the given field width; Right justification is
- + Forces to precede the result with a plus or minus sign (+ or -)
- (space) If no sign is going to be written, a blank space is inserte
- # Used with o, x or X specifiers the value is preceeded with 0, 0x
force decimalpoint ...
- 0 Left-pads the number with zeroes (0) instead of spaces, where pad
+ = reuse previous input argument
length not implemented
----------------------------------------------------------------------*/
fGen: procedure expose m.
parse arg aS
ft.src = aS
ft.pos = 1
ex = 0
ax = 0
qX = ''
cd = ''
do fx=1
ftc.fx = fText()
an = ''
af = ''
if fLit('@') \== '' then do
an = fVerify('0123456789', 'n')
if an == '' then
an = 1
call fLit '.'
af = fText()
end
fta.fx = ''
if fLit('%') == '' then do
if ft.pos > length(ft.src) then
leave
call err 'missing % at' substr(aS, ft.pos) 'in format' aS
end
flags = fVerify('-+', 'n')
len = fVerify('0123456789', 'n')
prec = ''
if fLit('.') \== '' then do
if len == '' then
call err 'empty len in' substr(aS,ft.pos) 'in format' aS
prec = fVerify('0123456789', 'n')
end
sp = fChar(1)
if sp \== 'Q' then do
if an \== '' then
ax = an
else
ax = ax + 1
if ax < 3 then
aa = 'ggA'ax
else
aa = 'arg(' || (ax+1) || ')'
if af \== '' then do
if \ abbrev(aa, 'ggA') then
call err 'implement ggA'ax
if verify(af, m.mAlfUC'0123456789.') < 1,
& pos('.GG', '.'af) < 1 then do
aa = 'm.'aa'.'af
end
else do
cd = fGenRexxAdd(cd, '; ggF'fx '=' quote(af))
aa = 'm.'aa'.ggF'fx
end
end
end
if sp = 'C' then do
if prec \== '' then
fta.fx = 'substr('aa',' prec',' len')'
else if pos('-', flags) > 0 then
fta.fx = 'left('aa',' len')'
else
fta.fx = 'left('aa',' len')'
end
else if sp = 'Q' then do
qX = qX fx
fta.fx = 'Q?'flags
end
else if sp == 's' then
fta.fx = aa
else if sp = 'S' then
fta.fx = 'strip('aa')'
else
call err 'bad specifier' sp 'at' ft.pos 'in format' aS
end
if qX == '' then
cd = fGenRexx(cd, fx)
else
cd = fGenQRexx(cd, fx, qX)
m.f.format.aS = cd
say '???' aS '==>' cd
return cd
endProcedure fGen
fChar: procedure expose m. ft.
parse arg len
ox = ft.pos
if len > length(ft.src) + 1 - ox then
len = length(ft.src) + 1 - ox
ft.pos = ox+len
return substr(ft.src, ox, len)
endProcedure fChar
fLit: procedure expose m. ft.
do ax=1 to arg()
if abbrev(substr(ft.src, ft.pos), arg(ax)) then do
ft.pos = ft.pos + length(arg(ax))
return arg(ax)
end
end
return ''
endProcedure fLit
fVerify: procedure expose m. ft.
parse arg set, isMa
ox = ft.pos
nx = verify(ft.src, set, isMa, ox)
if nx < ft.pos then
ft.pos = length(ft.src) + 1
else
ft.pos = nx
return substr(ft.src, ox, ft.pos-ox)
endProcedure fVerify
fText: procedure expose m. ft.
res = ''
do forever
res = res || fVerify('\@%', 'm')
if ft.pos > length(ft.src) then
return res
if substr(ft.src, ft.pos, 1) \== '\' then
return res
c1 = substr(ft.src, ft.pos+1, 1)
if length(ft.src) = ft.pos | pos(c1, 's\@%') < 1 then do
res = res'\'
ft.pos = ft.pos + 1
end
else do
res = res || translate(c1, ' ', 's')
ft.pos = ft.pos + 2
end
end
endProcedure fText
fgenQRexx: procedure expose m. ft. fta. ftc.
parse arg c0, fx, qx qr
if qx == '' | qr \== '' then
call err 'multiple qx' qx' in format' ft.src
if fta.qX \== 'Q?+' then
call err 'bad q in format' ft.src
if fx \= qX+1 then
call err 'q not last in format' ft.src
if qx = 1 then do
ftc.3 = ftc.2
ftc.2 = ''
fta.2 = fta.1
fta.1 = 'arg(2)'
qx = 2
fx = 3
end
fEnd = ft.src'%-Qend'
m.f.format.fEnd = ftc.qx
cd = fgenRexx(c0, qx-1)
ftc.1 = ftc.qx || ftc.fx || ftc.1
fNxt = ft.src'%-Qnxt'
m.f.format.fNxt = fgenRexx(c0, qx-1)
say '???'fNxt'='m.f.format.fNxt',' fEnd'='m.f.format.fEnd
return cd
endProcedure fGenQRexx
fgenRexx: procedure expose m. ft. fta. ftc.
parse arg cd, fTo
do fx=1 to fTo
if ftc.fx \== '' then
cd = fGenRexxAdd(cd, quote(ftc.fx))
if fta.fx \== '' then
cd = fGenRexxAdd(cd, fta.fx)
end
if cd = '' then
return "return ''"
else if abbrev(cd, ';') then
return substr(cd, 2)'; return r'
else
return "return" cd
endProcedure fGenRexx
fGenRexxAdd: procedure expose m. cnst ax
parse arg one, two
if one == '' then
if abbrev(two, ';') then
return ";r=''"two";"
else
return two
if right(one, 1) == ';' then
if abbrev(two, ';') then
return one substr(two, 2)
else
return one 'r = r ||' two
else
if \ abbrev(two, ';') then
return one '||' two
else if abbrev(one, ';') then
return one two';'
else
return ';r='one two';'
endProcedure fGenRexxAdd
mIni: procedure expose m.
if m.m.ini = 1 then
return
m.m.ini = 1
m.mAlfLC = 'abcdefghijklmnopqrstuvwxyz'
m.mAlfUC = translate(m.mAlfLC)
m.mAlfa = m.mAlfLC || m.mAlfUC
m.mAlfNum = m.mAlfa || '0123456789'
m.mAlfDot = m.mAlfNum || '.'
m.m.area.0 = 0
call mNewArea
return
endProcedure mIni
/* copy m end *********************************************************/
/* copy err begin ******************************************************
messages, errorhandling,help
***********************************************************************/
errIni: procedure expose m.
if m.err.ini == 1 then
return
call outIni
m.err.ini = 1
m.err.handler = ''
m.err.cleanup = ';'
m.err.opt = ''
return
endProcedure errIni
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err.opt, m.err.handler
if pos('I', translate(m.err.opt)) > 0 then
if errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
call adrIsp 'control errors return'
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
call errIni
drop err handler cleanup opt call return
if ggOpt == '' & m.err.handler \== '' then do
if 1 then do /* no detection of recursive err call loop
--> will anyway fail by stack overflow */
interpret m.err.handler
end
else do
/* avoid recursive err call loop */
drop call return
if symbol('m.err.call') \== 'VAR' then
m.err.call = 1
else
m.err.call = m.err.call + 1
if m.err.call > 10 then do
say 'errHandler loop:' m.err.handler
end
else do
m.err.return = 1
call errInterpret m.err.handler
m.err.call = m.err.call - 1
if m.err.return then
return result
end
end
end
call outDst
call errSay ggTxt, 'e'
call errCleanup
if ggOpt == '' then
ggOpt = m.err.opt
ggOpt = translate(ggOpt)
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 then do
call errSay 'divide by zero to show stackHistory', 'e'
x = 1 / 0
end
call errSay 'exit(12)', 'e'
exit errSetRc(12)
endSubroutine err
/*--- error routine: user message cleanup exit -----------------------*/
errEx:
parse arg ggTxt
call errIni
call outDst
call errSay ggTxt
call errCleanup
exit 8
endProcedure errEx
errAddCleanup: procedure expose m.
parse arg code
if m.err.ini \== 1 then
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
if m.err.ini \== 1 then
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
cl = m.err.cleanup
if cl = ';' then
return
m.err.cleanup = ';'
say 'err cleanup begin' cl
call errInterpret cl
say 'err cleanup end' cl
return
endProcedure errCleanup
errInterpret: procedure expose m.
parse arg code
interpret code
m.err.return = 0
return
endProcedure errInterpret
/*--- assert that the passed rexx expression evaluates to true -------*/
assert:
interpret 'assertRes =' arg(1)
if \ assertRes then
call err 'assert failed' arg(1)':' arg(2)
return
endProcedure assert
/*--- output an errorMessage msg with pref pref
split message in lines at '/n' ---------------------------*/
errSay: procedure expose m.
parse arg msg, pref
parse source . . ggS3 . /* current rexx */
if pref == 'e' then
msg = 'fatal error in' ggS3':' msg
else if pref == 'w' then
msg = 'warning in' ggS3':' msg
else if pref \== '' then
msg = pref':' msg
return outNl(msg)
endProcedure errSay
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg, op
call errSay msg, 'e'
call help
call err msg, op
endProcedure errHelp
/*--- return the Operating System we are running on: TSO or LINUX ---*/
errOS: procedure expose m.
parse source os .
return os
endProcedure errOS
/*--- set rc for ispf: -------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared varible 3IspfRc
back as return code
----------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- output a trace message if m.tr is set -----------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
call out 'debug' msg
return
endProcedure debug
/*--- display the first comment block of the source as help ----------*/
help: procedure expose m.
parse source . . s3 .
call out right(' help for rexx' s3, 79, '*')
do ax=1 to arg()
say ' ' arg(ax)
end
do lx=1 by 1
if pos('/*', sourceLine(lx)) > 0 then
leave
else if lx > 10 then do
call out '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
call out li
end
call out right(' end help for rexx' s3, 79, '*')
return 4
endProcedure help
/*--- output all lines (separated by '\n') of all args --------------*/
outNl: procedure expose m.
do ax=1 to max(1, arg())
msg = arg(ax)
sx = 0
bx = -1
do lx=1 until bx >= length(msg)
ex = pos('\n', msg, bx+2)
if ex < 1 then
ex = length(msg)+1
call out substr(msg, bx+2, ex-bx-2)
bx = ex
end
end
return 0
endProcedure outNl
/* copy err end *****************************************************/
/* copy ut begin *****************************************************/
/*--- if function warning all3 arguments get evaluated|
e.g if(x=0, 'infinity', 1/0) will fail| -----------*/
if: procedure expose m.
parse arg co, ifTrue, ifFalse
if co then
return ifTrue
else
return ifFalse
endProcedure if
/*--- embedded ASSignement:
assign the second argument to the variable with name in first arg
and return the value assigned ----------------------------------*/
ass:
call value arg(1), arg(2)
return arg(2)
/*--- embedded ASSignement only if NotNull:
assign the second argument to the variable with name in first arg
if the second arg is not null, return new value ---------------*/
assIf:
if arg(2) == '' then
return value(arg(1))
call value arg(1), arg(2)
return arg(2)
/*--- return first nonNull argument ---------------------------------*/
nn:
if arg(1) \== '' then
return arg(1)
if arg(2) \== '' then
return arg(2)
call err 'nn() both args empty'
/*--- embedded ASSignement return NotNull:
assign the second argument to the variable with name in first arg
and return 1 if value not null, 0 if null ----------------------*/
assNN:
call value arg(1), arg(2)
return arg(2) \== ''
/*--- return current time and cpu usage ------------------------------*/
timing: procedure expose m.
return return time() 'ela='time('E') 'cpu='sysvar('syscpu'),
'su='sysvar('syssrv')
timingTest: procedure expose m.
say 'begin' timing() sysvar('sysnode')
do 30000000
end
say 'end ' timing()
return
/*--- sleep several seconds ------------------------------------------*/
sleep: procedure expose m.
parse arg secs, sayIt
if sayit <> 0 then
say 'sleeping' secs 'secs' time()
CALL SYSCALLS 'ON'
ADDRESS SYSCALL "sleep" secs
CALL SYSCALLS 'OFF'
if sayit <> 0 then
say 'slept' secs 'secs' time()
return
endProcedure sleep
/*--- elongate inp with spaces up to given len -----------------------*/
elong: procedure expose m.
parse arg inp, len
if length(inp) >= len then
return inp
return left(inp, len)
endProcedure elong
/*--- quote string txt using quoteChar qu ("""" ==> ") ---------------*/
quote: procedure expose m.
parse arg txt, qu
if qu = '' then
qu = '"'
res = qu
ix = 1
do forever
qx = pos(qu, txt, ix)
if qx = 0 then
return res || substr(txt, ix) || qu
res = res || substr(txt, ix, qx-ix) || qu || qu
ix = qx + length(qu)
end
endProcedure quote
/*--- return the count of occurrences of needle in heyStack ----------*/
posCount: procedure expose m.
parse arg needle, hayStack, start, fin
if start = '' then
start = 1
if fin = '' then
fin = length(hayStack) + 1 - length(needle)
do cnt = 0 by 1
start = pos(needle, haystack, start)
if start < 1 | start > fin then
return cnt
start = start + length(needle)
end
endProcedure posCount
repAll: procedure expose m.
parse arg src, w, new
res = ''
cx = 1
do forever
nx = pos(w, src, cx)
if nx < 1 then
return res || substr(src, cx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAll
repAllWords: procedure expose m.
parse arg src, w, new
res = ''
wx = 0
cx = 1
do forever
wx = wordPos(w, src, wx+1)
if wx < 1 then
return res || substr(src, cx)
nx = wordindex(src, wx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAllWords
/* copy ut end ********************************************************/