zOs/REXX/EXDB2LOQ
/* REXX
!!____________________________________________________________________
!!
!! EXDB2LOG
!! --------
!! read mastlog output and insert the messages into tadm6* tables
!!
!! PARMS EXDB2LOG <PARM1>
!! PARM1 = DB2 SUBSYSTEM
!!
!! LOCATION DSN.DB2.EXEC ab 4.0
!! TSO.rz?.P0.USER.EXEC bis 3.1
!!
!! HISTORY:
!! 2.10.2015 V4.1 for timeout also use DSNT500I and store
!! these even without deadlock/timeout
!! 20.10.2014 V4.0 logE2 => logEx
!! 06.10.2014 V4.0 direkt aus Beta/eJes Extract DSNs lesen
!! member/Datum aus IAT6140 usw.
!! keine doppelte Ausgabe von Beta/eJes Logs
!! 09.04.2014 V3.1 Ergebnis zusätzlich ins DSN
!! 24.09.2012 V3.0 rewrite masterlog
!! 18.04.2012 V2.2 rz8 und rzz integriert
!! 17.04.2012 V2.1 truncate collids longer 18
!! 28.03.2008 V2.0 ABNORMAL EOT (G.KERN,A914227)
!! 27.03.2008 V1.1 UNCOMMITED UOW (G.KERN,A914227)
!! 27.03.2008 V1.2 CHECKPOINTS (G.KERN,A914227)
!! 27.03.2008 V1.3 LOCK ESCALATION (G.KERN,A914227)
!! 30.01.2008 V1.0 GRUNDVERSION (G.KERN,A914227)
!!
!!_____________________________________________________________________
*/
m.debug = 0
m.tstRZ4 = 1
m.insertLocal = 1
m.writeABLF = 1
m.wkTest = 0
m.acTest = 0
call errReset 'h'
PARSE UPPER arg SSID rest
say "exDb2Log("ssid rest") version v4.1 vom 2.10.15"
if ssid == 1 then
return doFun1()
else if ssid == 2 then
return doFun2(rest)
else if ssid == 3 then
return doFun3()
else if 0 then
return workOld(ssid)
else do
o.1 = date('s') time() sysVar(sysNode) mvsvar('symdef', 'jobname') ,
'exDb2Log workOld deActivated'
call writeDsn 'mod dsn.ablf.logDeImp ::f', o., 1
say 'exDb2Log workOld deActivated'
return 0
end
endMainCode
/*-------------- alte Verarbeitung -----------------------------------*/
workOld:
parse arg ssid
call ini 0
/*_____________________________________________________________________
!!
!! VARIABLEN INITIALISIEREN
!!_____________________________________________________________________
*/
m.tadmDbSy = ''
m.lastDeadlock = ''
m.lastTimeout = ''
m.tadmCreator = ''
/*_____________________________________________________________________
!!
!! HAUPTPROGRAMM
!!_____________________________________________________________________
*/
SAY "DB2 SUBSYSTEM = "SSID
CALL OWNER_SSID_ZUWEISEN ssid /* ZUWEISEN OWNER & SSID FÜR SQL */
CALL sqlConnect ssid /* DB2 SUBSYSTEM VERBINDEN */
CALL readMstrLog /* INPUT-DS lesen und analysieren */
CALL sqlDisconnect /* DISCONNECT DB2 SUBSYSTEM */
if m.insertLocal then do
CALL sqlConnect m.tadmDbSy /* DB2 SUBSYSTEM VERBINDEN */
CALL GET_MAX_WERT_TIMEOUT /* MAX TIMEOUT vON TABELLE LESEN */
CALL GET_MAX_WERT_DEADLOCK /* MAX DEADLOCK VON TABELLE LESEN */
CALL GET_MAX_WERT_uncommittedUOW /* MAX uncommittedUOW */
CALL GET_MAX_WERT_CHECKPNT /* MAX CHECKPNT VON TABELLE Lesen */
CALL GET_MAX_WERT_LOCKESCA /* MAX LOCKESCA VON TABELLE Lesen */
CALL GET_MAX_WERT_EOT /* MAX EOT EINTRAG VON TABELLE LESEN */
CALL INSERT_TADM60A1 /* deadlocks und timeouts */
CALL INSERT_TADM63A1 /* uncommitted UOW */
CALL INSERT_TADM64A1 /* LOCK ESCALATION */
CALL INSERT_TADM65A1 /* abnormal eot */
CALL sqlDisconnect /* DISCONNECT DB2 SUBSYSTEM */
end
if m.writeABLF then /* write dsn für ABLF */
/* call writeAblfAll 'DSN.ABLF.LOGEX.'ssid */
call writeAblfAll 'A540769.LOGEX.ABLF.'ssid
return 0
endSubroutine workOld
/*--- write timestamp to dd parmNew ----------------------------------*/
doFun1: procedure expose m.
parse arg betaExt .
call ini 1
call readDD parmOld, i., '*'
call tsoClose parmOld
ix = i.0
say 'parmOld' ix strip(i.ix, 't')
w1 = word(i.ix, 1)
if i.0 = 0 then
old = '2014-01-01-00.00.00'
else if translate(w1, '999999999', '012345678') ,
\== '9999-99-99-99.99.99' then
call err 'bad to tst in parmOld 1:' i.ix
else if substr(w1, 15, 2) >= 15 then
old = overlay(right(substr(w1, 15, 2)-15, 2,0), w1, 15)
else if substr(w1, 12, 2) >= 1 then
old = overlay(right(substr(w1, 12, 2)-1, 2,0) ,
|| '.'right(substr(w1, 15, 2)+45, 2,0), w1, 12)
else
old = left(w1, 11)'00.00.00'
new = translate('1234-56-78', date('s'), '12345678') ,
|| '-'translate(time(), '.', ':')
if new <= old then
call err 'new' new '<=' old 'old'
o.1 = new old
call writeDD parmNew, o., 1
call tsoClose parmNew
say 'parmNew' strip(o.1, 't')
if substr(old, 6, 2) > 2 then
betaS = overlay(right(substr(old, 6, 2)-2, 2,0), old, 6)
else
betaS = overlay(left(old, 4)-1,
|| '-'right(substr(old, 6, 2)+10, 2,0), old, 1)
if substr(betaS, 9, 2) > 28 then
betaS = overlay(28, betaS, 9)
betaS = translate('78.56.1234', left(betaS, 10), '1234-56-78')
say 'betaStart' betaS 'betaExt' betaExt
o.1 = 'REPORT'
o.2 = ' SDATE('betaS')'
o.3 = ' STIME(00:00:00)'
o.4 = ' PDATE(TODAY)'
o.5 = ' PTIME(23:59:59)'
o.6 = ' JOBNAME(D***MSTR)'
call writeDD betaRePa, o., 6
call tsoClose betaRePa
a.1 = ' 00:00:00 ' /* idiotisches Rexx stuerzt ab auf leerem
konatiniertem Dataset | */
call writeDD 'betaExt', a., 1
call tsoClose 'betaExt'
call writeDD 'eJesExt', a., 1
call tsoClose 'eJesExt'
say 'written idiotic dummy row on betaExt and eJesExt'
call eJesJobExtDD 'D%%%MSTR', 'JESMSGLG'
return 0
endProcedure doFun1
/*--- select jobs from betaRep ---------------------------------------*/
doFun2: procedure expose m.
parse arg betaExt .
call ini 1
say 'fun2' betaExt
call parmNewRead
new = m.parm_new
old = m.parm_old
call readDD betaRep, b., '*'
call tsoClose betaRep
say 'dd betaRep' b.0 'lines'
do bx=1 to b.0
if substr(b.bx, 2, 8) == 'BETA 92 ' then do
bx = bx + 1
if substr(b.bx, 2, 17) == 'JOBNAME JES-ID ' then
leave
end
if pos('NO JOBS MATCHED SELECTION', b.bx) > 0 then do
say 'no jobs in Beta report:' b.bx
return 4
end
end
if bx > b.0 then
call err 'no title found in betaRep'
say b.bx
cJ = 2
cI = 11
cE = pos(' END DATE ', b.bx)
eE = cE + 10
cF = pos(' END TIME ', b.bx) + 1
eF = cF+8
m.o.0 = 0
if cE < 20 | cF < 20 then
call err 'bad end time/date in beta title' b.bx
cS = pos(' SUB DATE ', b.bx)
eS = cS + 10
cT = pos(' SUB TIME ', b.bx) + 1
eT = cT+8
m.o.0 = 0
m.f.0 = 0
if cS < 20 | cT < 20 then
call err 'bad end time/date in beta title' b.bx
jx = 0
jy = 0
do bx=bx to b.0
if substr(b.bx, 2, 8) == 'BETA 92 ' ,
| abbrev(substr(b.bx, 2), '-----') ,
| abbrev(substr(b.bx, 2), '=====') ,
| substr(b.bx, 2, 17) == 'JOBNAME JES-ID ' ,
| abbrev(substr(b.bx, 2), 'PROGRAM B92BFJBR ') then
iterate
if pos(' JOB(S) MATCHED SELECTI', b.bx) > 0 then do
jz = word(substr(b.bx, 2), 1)
iterate
end
say b.bx
parse var b.bx 2 vJ 10 11 vI 19 ,
=(cS) vS =(eS) =(cT) vT =(eT) ,
=(cE) vE =(eE) =(cF) vF =(eF)
if translate(vE, '999999999', '012345678') \== '99.99.9999' then
call err 'bad end date' vE 'in line' bx':' b.bx
if translate(vF, '999999999', '012345678') \= '99:99:99' then
call err 'bad end time' vF 'in line' bx':' b.bx
vG = translate('1234-56-78', vE, '78.56.1234') ,
|| '-'translate(vF, '.', ':')
jx = jx + 1
if vG << old then
iterate
jy = jy + 1
say ' selected' vJ vI', ended' vG '>>=' old 'old'
call mAdd f, 'BFIND' ,
, ' SDATE('vS')' ,
, ' STIME('vT')' ,
, ' PDATE('vS')' ,
, ' PTIME('vT')' ,
, ' JOBNAME('strip(vJ)')' ,
, ' JOBID('strip(vI)')' ,
, ' DDNAME1(JESMSGLG)' ,
, ' OPERATOR(OR)' ,
, ' OPTIONS(FIRST)' ,
, ' SCOPE(BOTH)' ,
, ' MESSAGE(LONG)' ,
, ' RELOAD(YES)' ,
, ' MIXEDMODE(NO)' ,
, ' SLINE(0)' ,
, ' PLINE(0)' ,
, ' STRING1(DATE)'
call mAdd o, 'PRINT' ,
, ' SDATE('vS')' ,
, ' STIME('vT')' ,
, ' PDATE('vS')' ,
, ' PTIME('vT')' ,
, ' MASK(MM/DD/YY)' ,
, ' AUTOSEL(NO)' ,
, ' JOBNAME('strip(vJ)')' ,
, ' JOBID('strip(vI)')' ,
, ' DDNAME1(JESMSGLG)' ,
, ' MESSAGE(LONG)' ,
, ' SCOPE(BOTH)' ,
, ' DISPOSITION(MOD)' ,
, ' DATASET('betaExt')'
end
if jx <> jz then
call err jx 'jobs read not' jz 'as beta says'
say jy 'jobs selected from' jz 'in list'
call writeDD betaExPa, 'M.O.'
call tsoClose betaExPa
call writeDD betaFiPa, 'M.F.'
call tsoClose betaFiPa
return 4 * (jy = 0)
endProcedure doFun2
/*--- read concatenated master logs and write load files -------------*/
doFun3: procedure expose m.
call ini 1
call parmNewRead
call readMstrLog
call writeAblfAll 'A540769.LOGEX.ABLF'
/* call writeAblfAll 'DSN.ABLF.LOGEX.'sysvar(sysnode) */
return 0
endProcedure doFun3
/*--- read parmNew, extract new and old timestamp --------------------*/
parmNewRead: procedure expose m.
call readDD parmNew, n., '*'
call tsoClose parmNew
parse var n.1 new old .
say 'parmNew' new old
if n.0 < 1 then
call err 'empty parmNew'
else if translate(new, '999999999', '012345678') ,
\== '9999-99-99-99.99.99' then
call err 'bad new in parmNew:' new
else if translate(old, '999999999', '012345678') ,
\== '9999-99-99-99.99.99' then
call err 'bad old in parmNew:' old
else if new <= old then
call err 'new <= old' new old
m.parm_new = new
m.parm_old = old
return
endProcedure parmNewRead
/*_____________________________________________________________________
!!
!! OWNER UND SSID FÜR SQL ABFRAGE ZUWEISEN
!!_____________________________________________________________________
*/
OWNER_SSID_ZUWEISEN: procedure expose m.
parse arg ssid
IF m.debug THEN SAY "ENTER PROCEDURE OWNER_SSID_ZUWEISEN..." ssid
SELECT
WHEN SSID = 'DBTF' THEN info = 'DTF OA1T DBTF'
WHEN SSID = 'DBOC' THEN info = 'DOC OA1T DBTF'
WHEN SSID = 'DVTB' THEN info = 'DTB OA1T DBTF'
WHEN SSID = 'DP2G' THEN info = 'DP2 OA1P DP2G' /* rz2 */
WHEN SSID = 'DBOF' THEN info = 'DOF OA1P DP2G'
WHEN SSID = 'DVBP' THEN info = 'DBP OA1P DP2G'
WHEN SSID = 'DC0G' THEN info = 'DC0 OA1P DC0G' /* rz8 */
WHEN SSID = 'DCVG' THEN info = 'DCV OA1P DCVG'
WHEN SSID = 'DD0G' THEN info = 'DD0 OA1P DD0G'
WHEN SSID = 'DDVG' THEN info = 'DDV OA1P DDVG'
WHEN SSID = 'DX0G' THEN info = 'DX0 OA1P DX0G'
WHEN SSID = 'DP8G' THEN info = 'DP8 OA1P DP8G'
WHEN SSID = 'DE0G' THEN info = 'DE0 OA1P DE0G' /* rzz */
WHEN SSID = 'DEVG' THEN info = 'DEV OA1P DEVG'
OTHERWISE call err "bad ssid = '"ssid"'"
END
parse var info m.db2Member3 m.tadmCreator m.tadmDbSy .
if m.wkTest then do
m.tadmCreator = A540769
m.tadmDbSy = 'DBAF'
if ssid = 'DVBP' then ssid = 'DBTF'
say '?????? wktest run' m.tadmDbSy
end
if m.acTest then do
m.tadmCreator = A754048
m.tadmDbSy = 'DE0G'
if ssid = '' then ssid = 'DE0G'
say '?????? actest run' m.tadmDbSy
end
say ' ssid' ssid 'member' m.db2Member3'?',
'to' m.tadmDbSy':'m.tadmCreator'.TADM6*A1'
IF m.debug THEN SAY "LEAVE PROCEDURE OWNER_SSID_ZUWEISEN..."
RETURN
/*_____________________________________________________________________
!!
!! MAX TIMEOUT WERT VON TADM60A1 LESEN
!!_____________________________________________________________________
*/
GET_MAX_WERT_TIMEOUT: procedure expose m.
IF m.debug THEN SAY "ENTER PROCEDURE GET_MAX_WERT_TIMEOUT..."
SQLMAX= "SELECT ",
" MAX(TIMESTAMP) ",
" FROM "m.tadmCreator".TADM60A1 ",
" WHERE SSID LIKE '"m.db2Member3"%'",
" AND EVENT_TYPE = 'T' "
SQLTEXT = SQLMAX
ADDRESS DSNREXX "EXECSQL DECLARE C3 CURSOR FOR S3"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL PREPARE S3 FROM :SQLMAX"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL OPEN C3"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL FETCH C3 INTO :m.lastTimeout :SQL_IND"
IF SQLCODE <> 0 THEN CALL SQLCA
SAY " MAX TIMEOUT TIMESTAMP FOR" SSID "IS:" m.lastTimeout
ADDRESS DSNREXX "EXECSQL CLOSE C3"
IF m.debug THEN SAY "LEAVE PROCEDURE GET_MAX_WERT_TIMEOUT..."
RETURN
/*_____________________________________________________________________
!!
!! MAX DEADLOCK WERT VON TADM60A1 LESEN
!!_____________________________________________________________________
*/
GET_MAX_WERT_DEADLOCK: procedure expose m.
IF m.debug THEN SAY "ENTER PROCEDURE GET_MAX_WERT_DEADLOCK..."
SQLMAX= "SELECT ",
" MAX(TIMESTAMP) ",
" FROM "m.tadmCreator".TADM60A1 ",
" WHERE SSID LIKE '"m.db2Member3"%'",
" AND EVENT_TYPE = 'D' "
SQLTEXT = SQLMAX
ADDRESS DSNREXX "EXECSQL DECLARE C2 CURSOR FOR S2"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL PREPARE S2 FROM :SQLMAX"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL OPEN C2"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL FETCH C2 INTO :m.lastDeadlock :SQL_IND"
IF SQLCODE <> 0 THEN CALL SQLCA
SAY " MAX DEADLOCK TIMESTAMP FOR" SSID "IS:" m.lastDeadlock
ADDRESS DSNREXX "EXECSQL CLOSE C2"
IF m.debug THEN SAY "LEAVE PROCEDURE GET_MAX_WERT_DEADLOCK..."
RETURN
/*_____________________________________________________________________
!!
!! MAX uncommittedUOW WERT VON TADM63A1 LESEN
!!_____________________________________________________________________
*/
GET_MAX_WERT_uncommittedUOW:
IF m.debug THEN SAY "ENTER PROCEDURE GET_MAX_WERT_uncommittedUOW..."
SQLMAX= "SELECT ",
" MAX(TIMESTAMP) ",
" FROM "m.tadmCreator".TADM63A1 ",
" WHERE SSID LIKE '"m.db2Member3"%'",
" AND EVENT_TYPE = 'U' "
SQLTEXT = SQLMAX_DEADLOCK
ADDRESS DSNREXX "EXECSQL DECLARE C7 CURSOR FOR S7"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL PREPARE S7 FROM :SQLMAX"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL OPEN C7"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL FETCH C7 INTO :m.lastUOW :SQL_IND"
IF SQLCODE <> 0 THEN CALL SQLCA
SAY " MAX UNCOMMITTED UOW TIMESTAMP FOR" SSID "IS:" m.lastUOW
ADDRESS DSNREXX "EXECSQL CLOSE C7"
IF m.debug THEN SAY "LEAVE PROCEDURE GET_MAX_WERT_uncommittedUOW..."
RETURN
/*_____________________________________________________________________
!!
!! MAX CHECKPNT WERT VON TADM63A1 LESEN
!!_____________________________________________________________________
*/
GET_MAX_WERT_CHECKPNT:
IF m.debug THEN SAY "ENTER PROCEDURE GET_MAX_WERT_CHECKPNT..."
SQLMAX= "SELECT ",
" MAX(TIMESTAMP) ",
" FROM "m.tadmCreator".TADM63A1 ",
" WHERE SSID LIKE '"m.db2Member3"%'",
" AND EVENT_TYPE = 'C' "
SQLTEXT = SQLMAX_DEADLOCK
ADDRESS DSNREXX "EXECSQL DECLARE C9 CURSOR FOR S9"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL PREPARE S9 FROM :SQLMAX"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL OPEN C9"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL FETCH C9 INTO :m.lastCheckp :SQL_IND"
IF SQLCODE <> 0 THEN CALL SQLCA
SAY " MAX CHECKPOINT TIMESTAMP FOR" SSID "IS:" m.lastCheckp
ADDRESS DSNREXX "EXECSQL CLOSE C9"
IF m.debug THEN SAY "LEAVE PROCEDURE GET_MAX_WERT_CHECKPNT..."
RETURN
/*_____________________________________________________________________
!!
!! MAX LOCKESCA WERT VON TADM64A1 LESEN
!!_____________________________________________________________________
*/
GET_MAX_WERT_LOCKESCA:
IF m.debug THEN SAY "ENTER PROCEDURE GET_MAX_WERT_LOCKESCA..."
SQLMAX= "SELECT ",
" MAX(TIMESTAMP) ",
" FROM "m.tadmCreator".TADM64A1 ",
" WHERE SSID LIKE '"m.db2Member3"%'",
" AND EVENT_TYPE = 'E' "
SQLTEXT = SQLMAX_DEADLOCK
ADDRESS DSNREXX "EXECSQL DECLARE C10 CURSOR FOR S10"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL PREPARE S10 FROM :SQLMAX"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL OPEN C10"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL FETCH C10 INTO :m.lastLockesc :SQL_IND"
IF SQLCODE <> 0 THEN CALL SQLCA
SAY " MAX LOCK ESCALATION TIMESTAMP FOR" SSID "IS:" m.lastLockesc
ADDRESS DSNREXX "EXECSQL CLOSE C10"
IF m.debug THEN SAY "LEAVE PROCEDURE GET_MAX_WERT_LOCKESCA..."
RETURN
/*_____________________________________________________________________
!!
!! MAX EOT WERT VON TADM65A1 LESEN
!!_____________________________________________________________________
*/
GET_MAX_WERT_EOT:
IF m.debug THEN SAY "ENTER PROCEDURE GET_MAX_WERT_EOT..."
SQLMAX= "SELECT ",
" MAX(TIMESTAMP) ",
" FROM "m.tadmCreator".TADM65A1 ",
" WHERE SSID LIKE '"m.db2Member3"%'",
" AND EVENT_TYPE = 'A' "
SQLTEXT = SQLMAX_DEADLOCK
ADDRESS DSNREXX "EXECSQL DECLARE C12 CURSOR FOR S12"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL PREPARE S12 FROM :SQLMAX"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL OPEN C12"
IF SQLCODE <> 0 THEN CALL SQLCA
ADDRESS DSNREXX "EXECSQL FETCH C12 INTO :m.lastReadEot :SQL_IND"
IF SQLCODE <> 0 THEN CALL SQLCA
SAY " MAX ABNORMAL EOT TIMESTAMP FOR" SSID "IS:" m.lastReadEot
ADDRESS DSNREXX "EXECSQL CLOSE C12"
IF m.debug THEN SAY "LEAVE PROCEDURE GET_MAX_WERT_EOT..."
RETURN
/*_____________________________________________________________________
!!
!! read the whole master log
!! and analyse each interesting msg
!!_____________________________________________________________________
*/
readMstrLog:
call logMsgBegin rd
lx = 0
bx = 0
do forever
li = readNx(rd)
if li = '' then do
say lx 'lines' bx 'bytes' readNxPos(rd)
call readNxEnd rd
exit
end
lx = lx + 1
bx = bx + length(m.li)
end
m.to.0 = 0
m.uow.0 = 0
m.LoEs.0 = 0
m.ReEot.0 = 0
do mx=1
mid = logMsg(rd)
/* say mx mid m.rd.cc.0 readNxPos(rd) ????? */
if mid == '' then do
if m.info.jobKey \== '' then
call sayJobEnd info
say 'readMstrLog end:' readNxPos(rd)
call readNxEnd rd
return
end
else if m.info.tst <<= m.info.doneUntil then
nop /* already done yesterday or eJes <-> beta92 */
else if mid == 'DSNT375I' then
call anaTimeoutDeadlock rd, info, 'D'
else if mid == 'DSNT376I' then
call anaTimeoutDeadlock rd, info, 'T'
else if mid == 'DSNT500I' | mid == 'DSNT501I' then
call anaResourceNotAvailable rd, info, mid
else if mid == 'DSNJ031I' then
call anaUncommittedUOW rd, info, 'U'
else if mid == 'DSNR035I' then
call anaUncommittedUOW rd, info, 'C'
else if mid == 'DSNI031I' then
call anaLockEscalation rd, info, 'E'
else if mid == 'DSN3201I' then
call anaReadEot rd, info, 'A'
end
endProcedure readMstrLog
/*_____________________________________________________________________
!!
!! if this is not a dsn message return ''
!! otherwise, check it, collect infos into info and return id
!!_____________________________________________________________________
*/
logMsgBegin: procedure expose m.
parse arg rd
call readNxBegin rd, '-', 'DDIN1'
do until m.li <> ' 00:00:00' & m.li <> ''
li = readNx(rd)
end
m.info.doneUntil = m.parm_old
m.info.head = left('? ^ # no no', 300, '}')
m.info.jobKey = ''
m.mOld = ''
m.rd.curIsMsg = 1
m.cLogMsg = 0
m.cCont = 0
m.cContCx = 0
return
endProcedure logMsgBegin
logMsg: procedure expose m.
parse arg rd
m.cLogMsg = m.cLogMsg+1
li = readNxCur(rd)
if li == '' then
return ''
line = m.li
if substr(line, 1, 20) == ' IAT6140 JOB ORIGIN ' then do
m.rd.jes2 = 0
return logMstr(rd, line)
end
else if substr(strip(line), 1, 39) ,
== 'J E S 2 J O B L O G -- S Y S T E M ' then do
m.rd.jes2 = 1
m.info.j2Id = ''
return logMstr(rd, line)
end
if m.rd.jes2 then do
if translate(substr(line, 1, 9), '999999999', '012345678') ,
\== '99.99.99 ' then do
if line = '------ JES2 JOB STATISTICS ------' then do
m.info.mid = '----stat'
do cx=1 until li == '' | substr(m.li, 13, 1) = ' ' ,
| substr(m.li, 14, 1) <> ' ' ,
| substr(m.li, 15, 1) = ' '
m.rd.cc.cx = m.li
li = readNx(rd)
end
m.rd.cc.0 = cx
return m.info.mid
end
else
call err 'bad time in jes2 line' readNxPos(rd)
end
m.info.time = word(line, 1)
w2 = word(line, 2)
if w2 \== m.info.j2Id then do
if m.info.j2Id \== '' then
call err 'jes2 id mismach' m.info.j2Id ,
'<>' readNxPos(rd)
else if length(w2) <> 8 then
call err 'bad jes2 id' w2 'in' readNxPos(rd)
else
m.info.j2Id = w2
end
if substr(line, 18, 1) \== ' ' then
call err 'bad jes2 line' readNxPos(rd)
else if substr(line, 18, 6) == ' ---- ' then do
if word(line, 8) \== '----' then
call err 'bad jes2 ---- line' readNxPos(r)
call anaCurDate info, subword(substr(line, 24), 2, 3)
m.info.mid = '----date'
end
else do
m.info.mid = word(line, 3)
end
m.info.tst = m.info.date'-'m.info.time
call logMsgContJes2 rd, line
return m.info.mid
end
else do
if translate(substr(line, 1, 10), '999999999', '012345678') ,
\== ' 99:99:99 ' then
call err 'bad time in jes3 line' readNxPos(rd)
m.info.time = word(line, 1)
m.info.head = left(line, 9) /* no space in empty line | */
if substr(line, 10, 14) == ' ---- IAT6853 ' then do
if substr(line, 24, 20) \== 'THE CURRENT DATE IS ' then
call err 'bad IAT6853' readNxPos(rd)
call anaCurDate info, subword(substr(line, 44), 2, 3)
m.info.mid = 'IAT6853'
end
else do
m.info.mid = word(line, 2)
end
m.info.tst = m.info.date'-'translate(m.info.time, '.', ':')
call logMsgContJes3 rd, line
return m.info.mid
end
endProcedure logMsg
logMsgContJes2: procedure expose m.
parse arg rd, line
m.cCont = m.cCont + 1
if translate(right(line, 5), 000000000,123456789)== ' 000' then do
mSeq = right(line, 3)
aSeq = left(' 'mSeq, 19)
m.mOld = mSeq subWord(m.mOld, 1, 49)
m.rd.cc.1 = substr(line, 19, length(line)-23)
end
else do
mSeq = ''
aSeq = left('', 19 ,'?')
m.rd.cc.1 = substr(line, 19)
end
cx = 1
do forever
li = readNx(rd)
if li == '' then
leave
/* else if left(m.li, 19) = ' 'mSeq then do */
else if abbrev(m.li, aSeq) then do
cx = cx + 1
m.rd.cc.cx = substr(m.li, 19)
end
else if translate(left(m.li, 19), 000000000, 123456789) ,
= ' 000' then do
/* ???? ix = wordPos(substr(m.li, 4, 3), m.mOld)
if symbol('m.igno.ix') == 'VAR' then
m.igno.ix = m.igno.ix + 1
else
m.igno.ix = 1
if ix < 1 then
say 'ignoring after' m.info.mid'#'mSeq readNxPos(rd)
*/ end
else
leave
end
m.rd.cc.0 = cx
m.cContCx = m.cContCx + cx
return li
endProcedure logMsgContJes2
logMsgContJes3: procedure expose m.
parse arg rd, line
m.cCont = m.cCont + 1
m.rd.cc.1 = substr(line, 10)
cx = 1
do forever
li = readNx(rd)
if li == '' then
leave
if \ abbrev(m.li, m.info.head) then do
if translate(substr(m.li, 2, 9), '999999999', '012345678') ,
\== '99:99:99 ' then
leave
if translate(substr(m.info.head 2, 9) ,
, '999999999', '012345678') \== '99:99:99 ' then
leave
ds =((( substr(m.li, 2, 2) * 60) ,
+ substr(m.li, 5, 2) * 60) ,
+ substr(m.li, 8, 2)) ,
-((( substr(m.info.head, 2, 2) * 60) ,
+ substr(m.info.head, 5, 2) * 60) ,
+ substr(m.info.head, 8, 2))
if ds < 0 | ds > 3 then
leave
end
if substr(m.li, 10, 14) == ' ---- IAT6853 ' then
leave
vx = verify(m.li, ' ', 'N', 10)
if vx = 11 | vx = 12 then do
w2 = word(m.li, 2)
if (length(w2) == 7 | length(w2) == 8) ,
& verify(w2, m.ut_alfUCNum) = 0 then
if wordPos(left(w2, 3), 'IAT ACF DSN IEF IXL') > 0 then
leave
end
cx = cx + 1
m.rd.cc.cx = substr(m.li, 10)
end
m.rd.cc.0 = cx
m.cContCx = m.cContCx + cx
return li
endProcedure logMsgContJes3
/* ???????????????????????????????
logMsgCont: procedure expose m.
parse arg rd
if \ m.rd.jes2 then do
if m.rd.isMsgStart then do
m.rd.isMsgStart = 0
li = readNxCur(rd)
return substr(m.li, 12)
end
li = readNx(rd)
if li == '' then
return ''
else do
call err 'implement'
end
endProcedure logMsgCont
if \ abbrev(mid, 'DSN') | wordIndex(line, 2) <> 12 ,
| length(mid) > 8 then do
if mid = '----' then
if word(line, 3) = 'IAT6853' then
call anaCurDate info, line
if translate(substr(line, 1, 10), '999999999', '012345678') ,
\== ' 99:99:99 ' then
return ''
if m.rd.curIsMsg then
li = readNx(rd)
else
li = readNxCur(rd)
do while li <> ''
line = m.li
if substr(line, 2, 18) \== 'IAT6140 JOB ORIGIN' then
??????????? */
finishJob: procedure expose m.
parse arg rd
if m.info.jobKey == '' then
return
jKy = m.info.jobKey
p = readNxPos(rd)
p = left(p, pos(':', p)-1)
if m.rd.jes2 then
j = 'jes2'
else
j = 'jes2'
say j m.info.job jKy 'to' m.info.tst p
ii = ''
/* do ix=0 to 99
if symbol('m.igno.ix') == 'VAR' then
ii = ii ix'='m.igno.ix
end
say ii */
say 'logMsg='m.cLogMsg 'cont='m.cCont 'contCx='m.cContCx
jKy = m.info.jobKey
jEnd = m.info.tst
if symbol('m.jobK2E.jKy') <> 'VAR' | jEnd >> m.jobK2E.jKy then
m.jobK2E.jKy = jEnd
m.info.jobKey = ''
return
endProcedure finishJob
logMstr: procedure expose m.
parse arg rd, line
call finishJob rd
m.info.dateTst = ''
do until m.li <> ''
li = readNx(rd)
end
do lx=1 to 50
mid = logMsg(rd)
if mid = '' then do
say 'eof in start of mstrLog' line
say ' @' readNxPos(rd)
return ''
end
if mid == 'IEF403I' then do
j1 = word(m.rd.cc.1, 2)
s1 = word(m.rd.cc.1, words(m.rd.cc.1))
end
else if mid == 'DSNY024I'then do
m2 = substr(word(m.rd.cc.1, 2), 2)
leave
end
else if abbrev(mid, 'DSN') then do
call err 'unexpected dsn' readNxPos(rd)
end
end
if lx > 50 then
call err 'mstr begin' readNxPos(rd)
if s1 == '' then
call err 'IEF403I not found' readNxPos(rd)
if m2 == '' then
call err 'DSNY024I not found' readNxPos(rd)
if j1 <> m2'MSTR' then
call err 'dbMember' m2 '<> job' j1
m.info.dbMb = m2
m.info.dbSys = iiMbr2DbSys(m2)
m.info.job = j1
m.info.sys = s1
m.info.wxTime = 1
m.info.cxTime = 2
if m.info.dateTst == '' then
call err 'no date' readNxPos(rd)
jKy = m2 m.info.dateTst
if symbol('m.jobK2E.jKy') <> 'VAR' then
m.jobK2E.jKy = ''
else
say 'job' j1 jKy ,
'already done until' m.jobK2E.jKy
m.info.jobKey = jKy
if m.parm_old << m.jobK2E.jKy then
m.info.doneUntil = m.jobK2E.jKy
else
m.info.doneUntil = m.parm_old
return mid
isDsnMsg: procedure expose m.
parse arg line, info
if m.modeNew? then do
if translate(substr(line, 2, 9), '999999999', '012345678') ,
\== '99:99:99 ' then do
if substr(line, 1, 20) == ' IAT6140 JOB ORIGIN ' then do
m.rd.jes2 = 0
call err 'bad line' line
s1 = ''
m2 = ''
if m.info.jobKey \== '' then do
call sayJobEnd info
jKy = m.info.jobKey
jEnd = m.info.tst
if symbol('m.jobK2E.jKy') <> 'VAR' ,
| jEnd >> m.jobK2E.jKy then
m.jobK2E.jKy = jEnd
m.info.jobKey = ''
end
m.info.dateTst = ''
do lx=1 to 50
ln = readNx(rd)
if ln = '' then do
say 'eof in start of mstrLog' line
say ' @' readNxPos(rd)
return ''
end
if translate(substr(m.ln, 2, 9), '999999999',
, '012345678') \== '99:99:99 ' then do
say 'bad start of mstrLog after' line
say ' @' readNxPos(rd)
return isDsnMsg(m.ln, info)
end
if word(m.ln, 2) == 'IEF403I' then do
j1 = word(m.ln, 3)
s1 = word(m.ln, words(m.ln))
end
else do
d2 = isDsnMsg(m.ln, info)
if d2 = 'DSNY024I' then do
m2 = substr(word(m.ln, 3), 2)
leave
end
else if d2 \== '' then
call err 'unexpected dsn' readNxPos(rd)
end
end
if lx > 50 then
call err 'mstr begin' readNxPos(rd)
if s1 == '' then
call err 'IEF403I not found' readNxPos(rd)
if m2 == '' then
call err 'DSNY024I not found' readNxPos(rd)
if j1 <> m2'MSTR' then
call err 'dbMember' m2 '<> job' j1
m.info.dbMb = m2
m.info.dbSys = iiMbr2DbSys(m2)
m.info.job = j1
m.info.sys = s1
m.info.wxTime = 1
m.info.cxTime = 2
if m.info.dateTst == '' then
call err 'no date' readNxPos(rd)
jKy = m2 m.info.dateTst
if symbol('m.jobK2E.jKy') <> 'VAR' then
m.jobK2E.jKy = ''
else
say 'job' j1 jKy ,
'already done until' m.jobK2E.jKy
m.info.jobKey = jKy
if m.parm_old << m.jobK2E.jKy then
m.info.doneUntil = m.jobK2E.jKy
else
m.info.doneUntil = m.parm_old
return ''
end
mid = word(line, 2)
m.info.time = word(line, 1)
m.info.head = left(line, 9) /* no space in empty line | */
if \ abbrev(mid, 'DSN') | wordIndex(line, 2) <> 12 ,
| length(mid) > 8 then do
if mid = '----' then
if word(line, 3) = 'IAT6853' then
call anaCurDate info, line
return ''
end
end
else do
mid = word(line, 4)
parse var line m.info.dbMb m.info.date m.info.time .
m.info.dbSys = iiMbr2DbSys(m.info.dbMb)
if \ abbrev(mid, 'DSN') | wordIndex(line, 4) <> 29 ,
| length(mid) > 8 then do
if mid = '----' then
if word(line, 5) = 'IAT6853' then
call anaCurDate info, substr(line,18), word(line,2)
m.info.wxTime = 3
m.info.cxTime = 19
return ''
end
m.info.head = left(line,27)
end
/* diese Prüfung ist falsch, manche displays zeigen --------------
Infos aus anderen membern an, z.B. -dis indoubt ......
aMbr = word(line, 5)
if abbrev(aMbr, '-') then
if '-'m.info.dbMb \== aMbr then
call err 'dbMember mismatch:' m.info.dbMb ,
'<>' readNxPos(rd) -----------------------------*/
m.info.tst = m.info.date'-'translate(m.info.time, '.', ':')
return mid
endProcedure isDsnMsg
sayJobEnd: procedure expose m.
parse arg info
jKy = m.info.jobKey
p = readNxPos(rd)
p = left(p, pos(':', p)-1)
say 'job' m.info.job jKy 'to' m.info.tst p
return
endProcedure say JobEnd
/*_____________________________________________________________________
!!
!! analyse current date in iat6853 message
!! and check that it equals the header
!!_____________________________________________________________________
*/
anaCurDate: procedure expose m.
parse arg info, d1, compD
d2 = word(d1, 1) ,
translate(left(word(d1, 2), 1)),
|| translate(substr(word(d1, 2), 2),
, m.ut_AlfLC, m.ut_AlfUC) ,
word(d1, 3)
do while abbrev(d2, 0) /* date does not accept leading zeroes ||||| */
d2 = substr(d2, 2)
end
d3 = date('s', d2)
m.info.date = translate('1234-56-78', d3, '12345678')
m.info.dateTst = m.info.date'-'translate(m.info.time,'.',':')
if compD \== '' then
if m.info.date <> compD then
call err 'date mismatch' compD '<>' d3 readNxPos(rd)
return
endProcedure anaCurDate
/*____________________________________________________________________
!!
!! analye msg: DSN3201I event type A - ABNORMAL EOT AUS INPUT-DS LESEN
!!____________________________________________________________________
*/
anaReadEot: procedure expose m.
parse arg rd, info, pEvTy
m.ReEot.0 = m.ReEot.0 +1
ux = 'REEOT.'m.ReEot.0 /*zähler */
m.ux.A = pEvty
m.ux.tst = m.info.tst
m.ux.dbMb = m.info.dbMb
m.ux.dbSys = m.info.dbSys
m.ux.corr = ''
m.ux.Jobname = ''
m.ux.conn = ''
m.ux.AuthID = '' /* AuthID = User column in db2 Table */
m.ux.AsID = ''
m.ux.tcb = ''
do lx = 1 to m.rd.cc.0
cx = pos(' CORRELATION-ID=', m.rd.cc.lx)
jx = pos(' JOBNAME=', m.rd.cc.lx)
if cx > 0 then do
if jx < cx then
m.ux.corr = cut18(strip(substr(m.rd.cc.lx,cx+16)))
else
m.ux.corr = cut18(strip(substr(m.rd.cc.lx,cx+16,
, jx-cx-16)))
end
if jx > 0 then
m.ux.Jobname = cut18(word(strip(substr(m.rd.cc.lx,jx+9)),1))
cx = pos(' CONNECTION-ID=', m.rd.cc.lx)
if cx > 0 then do
m.ux.conn = cut18(word(substr(m.rd.cc.lx,cx+15), 1))
end
cx = pos(' USER=', m.rd.cc.lx)
if cx > 0 then do
m.ux.AuthID = word(substr(m.rd.cc.lx,cx+6), 1)
end
cx = pos(' ASID=', m.rd.cc.lx)
if cx > 0 then
m.ux.AsID = word(substr(m.rd.cc.lx,cx+6), 1)
cx = pos(' TCB=', m.rd.cc.lx)
if cx > 0 then
m.ux.tcb = strip(substr(m.rd.cc.lx,cx+5))
/* if m.ux.tcb <> '' then
leave ????? */
end
return
endProcedure anaReadEot
/*____________________________________________________________________
!!
!! analye msg: DSNI031I event type E - LOCK ESCALATION
!!____________________________________________________________________
*/
anaLockEscalation: procedure expose m.
parse arg rd, info, pEvTy
m.LoEs.0 = m.LoEs.0 +1
ux = 'LOES.'m.LoEs.0 /*zähler */
m.ux.E = pEvty
m.ux.tst = m.info.tst
m.ux.dbMb = m.info.dbMb
m.ux.dbSys = m.info.dbSys
m.ux.plan = ''
m.ux.package = ''
m.ux.CollID = ''
m.ux.corr = ''
m.ux.conn = ''
m.ux.resource = ''
m.ux.LckSt = ''
m.ux.Statement = ''
do lx=1 to m.rd.cc.0
cx = pos(' RESOURCE NAME = ', m.rd.cc.lx)
if cx > 0 then
m.ux.resource = strip(word(m.rd.cc.lx, 4))
cx = pos(' LOCK STATE = ', m.rd.cc.lx)
if cx > 0 then
m.ux.LckSt = strip(word(m.rd.cc.lx, 4))
cx = pos(' PLAN NAME : PACKAGE NAME = ',m.rd.cc.lx)
if cx > 0 then do
PlanPack = substr(m.rd.cc.lx,cx+28)
cx = pos(':',planpack)
m.ux.plan = strip(left(planPack, cx-1))
m.ux.package = cut18(strip(substr(planPack,cx+1)))
end
cx = pos(' COLLECTION-ID = ', m.rd.cc.lx)
if cx > 0 then
m.ux.CollID = cut18(strip(substr(m.rd.cc.lx,cx+17)))
cx = pos(' STATEMENT NUMBER = ', m.rd.cc.lx)
if cx > 0 then
m.ux.Statement= strip(substr(m.rd.cc.lx,cx+20))
cx = pos(' CORRELATION-ID = ', m.rd.cc.lx)
if cx > 0 then
m.ux.corr = cut18(strip(substr(m.rd.cc.lx,cx+18)))
cx = pos(' CONNECTION-ID = ', m.rd.cc.lx)
if cx > 0 then
m.ux.conn = cut18(strip(substr(m.rd.cc.lx,cx+17)))
/* if m.ux.conn <> '' then
leave ???????? */
end
return
endProcedure anaLockEscalation
sayObj: procedure expose m.
parse arg ff, o
say o':' cl
do fx=1 to m.ff.0
f1 = m.ff.fx
say left(f1, 20) m.o.f1
end
return
endProcedure sayObj
/*____________________________________________________________________
!!
!! analye uncommit UOW msg: DSNJ031I / event type U and C
!!____________________________________________________________________
*/
anaUncommittedUOW: procedure expose m.
parse arg rd, info, pEvTy
m.uow.0 = m.uow.0 +1
ux = 'UOW.'m.uow.0 /* zähler */
m.ux.UC = pEvty
m.ux.tst = m.info.tst
m.ux.dbMb = m.info.dbMb
m.ux.dbSys = m.info.dbSys
m.ux.logRecs = ''
m.ux.corr = ''
m.ux.conn = ''
m.ux.plan = ''
m.ux.authid = ''
do lx = 1 to m.rd.cc.0
cx = pos(' CHECKPOINTS -', m.rd.cc.lx) /* for checkP */
if cx > 0 then
m.ux.logRecs = strip(word(m.rd.cc.lx, 2))
cx = pos(' LOG RECORDS -', m.rd.cc.lx) /* for UOW */
if cx > 0 then
m.ux.logRecs = strip(word(m.rd.cc.lx, 3))
cx = pos(' CORRELATION NAME =', m.rd.cc.lx)
if cx > 0 then
m.ux.corr = cut18(word(substr(m.rd.cc.lx,cx+19),1))
cx = pos(' CONNECTION ID =', m.rd.cc.lx)
if cx > 0 then
m.ux.conn = cut18(strip(substr(m.rd.cc.lx,cx+17)))
cx = pos(' PLAN NAME =', m.rd.cc.lx)
if cx > 0 then
m.ux.plan = strip(substr(m.rd.cc.lx,cx+13))
cx = pos(' AUTHID =', m.rd.cc.lx)
if cx > 0 then
m.ux.authid = strip(substr(m.rd.cc.lx,cx+9))
/* if m.ux.authid <> '' then
leave ???????????? */
end
return
endProcedure anaUncommittedUOW
/*____________________________________________________________________
!!
!! analye timeout, deadlock msg: DSNT375I, DSNT376I
!!____________________________________________________________________
*/
anaTimeoutDeadlock: procedure expose m.
parse arg rd, info, pEvTy
totx = newTimeout(info, pEvTy)
vs = 'V'
do lx=1 to m.rd.cc.0
if pos(' ONE HOLDER ', m.rd.cc.lx) > 0 then do
if pEvTy <> 'T' then
call err 'holder for evTy' pEvTy':'m.rd.cc.lx ,
readNxPos(r)
else if vs <> 'V' then
call err 'several holders:'m.rd.cc.lx readNxPos(r)
else
vs = 'H'
end
if pos(' IS DEADLOCKED ', m.rd.cc.lx) > 0 then do
if pEvTy <> 'D' then
call err 'is deadLocked for evTy' ,
pEvTy':'m.rd.cc.lx readNxPos(r)
else if vs <> 'V' then
call err 'several is deadLocked:'m.rd.cc.lx readNxPos(r)
else
vs = 'H'
end
cx = pos(' PLAN=', m.rd.cc.lx)
if cx > 0 then
m.toTx.vs.plan = word(substr(m.rd.cc.lx, cx+6,8), 1)
cx = pos(' CORRELATION-ID=', m.rd.cc.lx)
if cx > 0 then
m.toTx.vs.corr = cut18(strip(substr(m.rd.cc.lx, cx+16)))
cx = pos(' CONNECTION-ID=', m.rd.cc.lx)
if cx > 0 then
m.toTx.vs.conn = cut18(strip(substr(m.rd.cc.lx, cx+15)))
cx = pos(' ON MEMBER ', m.rd.cc.lx)
if cx > 0 then do
if vs <> 'H' then
call err 'on member in vs' vs':'m.rd.cc.lx readNxPos(rd)
else
m.toTx.vs.dbMb = word(substr(m.rd.cc.lx, cx+11, 8), 1)
end
end
return
endProcedure anaTimeOut
/*____________________________________________________________________
!!
!! make and initialise a new timeout/deadlock row
!!____________________________________________________________________
*/
newTimeout: procedure expose m.
parse arg info, pEvTy
m.to.0 = m.to.0 + 1
toTx = 'TO.'m.to.0
call clearFlds totx, ffTimeO
m.toTx.tst = m.info.tst
m.toTx.evTy = pEvTy
m.toTx.v.dbMb = m.info.dbMb
m.toTx.dbSys = m.info.dbSys
return toTx
endProcedure newTimeout
/*____________________________________________________________________
!!
!! analyse resourceNotAvailable msg DSNT501I and DSNT500I
!!____________________________________________________________________
*/
anaResourceNotAvailable: procedure expose m.
parse arg rd, info, mid
tCor = ''
tCon = ''
tRea = ''
tTyp = ''
tNam = ''
do lx = 1 to m.rd.cc.0 /* loop line of dsnt501i */
cx = pos(' CORRELATION-ID=', m.rd.cc.lx)
if cx > 0 then
tCor = word(substr(m.rd.cc.lx,cx+16),1)
cx = pos(' CONNECTION-ID=', m.rd.cc.lx)
if cx > 0 then
tCon = strip(substr(m.rd.cc.lx,cx+15))
cx = pos(' REASON ', m.rd.cc.lx)
if cx > 0 then
tRea = word(substr(m.rd.cc.lx,cx+8,20),1)
cx = pos(' TYPE ', m.rd.cc.lx)
if cx > 0 then
tTyp = word(substr(m.rd.cc.lx,cx+6,20),1)
cx = pos(' NAME ', m.rd.cc.lx)
if cx > 0 then
tNam = strip(substr(m.rd.cc.lx,cx+6))
end /* loop line of dsnt501i */
/* search preceeding timeOut/deadLock*/
if tCor = '' | tCon = '' then do
tx = m.to.0
if m.to.tx.name \== '' then
tx = -1
end
else do
mb = m.info.dbMb
tsN = m.info.tst
numeric digits 20
tsB = timeDays2Tst(timestamp2Days(tsN) - 30/86400)
numeric digits 9
do tx=m.to.0 to 1 by -1
if m.to.tx.v.dbMb <> mb ,
| m.to.tx.tst >> tsN | m.to.tx.tst << tsB then
tx = -1
else if m.to.tx.v.corr == tCor & m.to.tx.v.conn == tCon ,
& m.to.tx.name == '' then
leave
end
end
if tx > 0 then do
toTx = 'TO.'tx /* resource an timeout/deadlock anhängen */
end
else do /* new feature: store these also
evType depending on reason, but some have several */
if wordPos(tRea, '00C200FA 00C20031 00C900C0 00E70010') >0 then
toTx = newTimeout(info, 'T')
else
toTx = newTimeout(info, '')
m.toTx.v.corr = tCor
m.toTx.v.conn = tCon
end
m.toTx.type = tTyp
m.toTx.name = space(tNam, 1)
m.toTx.reason = tRea
if tTyp <> '' then
call resourceType info, toTx'.'type, toTx'.'name
return
endProcedure anaResourceNotAvailable
/*____________________________________________________________________
!!
!! give the name of the resourcetype and dbid/obid
!!____________________________________________________________________
*/
resourceType: procedure expose m.
parse arg info, tp, nm
cd = m.tp
if symbol('m.resourceType.cd') <> 'VAR' then do
say '<'cd'>' c2x(cd)
say readNxPos(rd)
call err 'unknown resource type' cd
end
m.tp = m.resourceType.cd
parms = m.resourceTypeParms.cd
names = m.nm
if pos('DI.OI', parms) > 0 then do /* find dbid and obid */
px = 0
nx = 0
do until px = 0
py = pos('.', parms, px + 1)
ny = pos('.', names, nx + 1)
if (py=0) <> (ny=0) then
call err 'resource parms' parms 'mismatch name' names
if py = 0 then do
p1 = substr(parms, px+1)
n1 = substr(names, nx+1)
end
else do
p1 = substr(parms, px+1, py-px-1)
n1 = substr(names, nx+1, ny-nx-1)
end
n.p1 = n1
px = py
nx = ny
end
/* dbid und obid uebersetzen */
m.nm = strip(getDbidObid(m.info.dbSys, n.di, n.oi) names)
end
return cd
endProcedure resourceType
ini: procedure expose m.
parse arg m.modeNew
call resourceTypeIni
call sqlIni
call errAddCleanup "if m.sql_dbSys <> '' then do;" ,
"say 'rollback';call sqlExec Rollback; call sqlDisconnect; end"
if m.modeNew then
f1 = 'TST DBSYS'
else
f1 = 'TST'
call iniFlds ffTimeO, f1 'V.DBMB EVTY V.PLAN V.CORR V.CONN' ,
'H.PLAN H.CORR H.CONN' ,
'REASON TYPE NAME'
call iniFlds ffUow, f1 'DBMB UC PLAN CORR CONN AUTHID LOGRECS'
call iniFlds ffLockE, f1 'DBMB E PLAN PACKAGE COLLID' ,
'CORR CONN RESOURCE LCKST STATEMENT'
call iniFlds ffEOT, f1 'DBMB A CORR JOBNAME CONN AUTHID ASID TCB'
return
endProcedure ini
iniFlds: procedure expose m.
parse arg ff, flds
do fx=1 to words(flds)
m.ff.fx = word(flds, fx)
end
m.ff.0 = words(flds)
return
endProcedure iniFlds
clearFlds: procedure expose m.
parse arg o, ff
do fx=1 to m.ff.0
f1 = m.ff.fx
m.o.f1 = ''
end
return o
endProcedure clearlds
resourceTypeIni: procedure expose m.
/* the old definitions for backward compability */
call rtDef '00000100', 'DB'
call rtDef '00000200', 'TS'
call rtDef '00000201', 'IX-SPACE'
call rtDef '00000202', 'TS'
call rtDef '00000210', 'PARTITION'
call rtDef '00000220', 'DATASET'
call rtDef '00000230', 'TEMP FILE'
call rtDef '00000300', 'TEMP FILE'
call rtDef '00000300', 'PAGE'
call rtDef '00000301', 'IX-MINIPAGE'
call rtDef '00000302', 'TS-PAGE'
call rtDef '00000303', 'IX-PAGE'
call rtDef '00000304', 'TS-RID'
call rtDef '00000D01', 'DBID/OBID'
call rtDef '00000800', 'PLAN'
call rtDef '00000801', 'PACKAGE'
call rtDef '00002000', 'TS CS-CLAIM CLASS'
call rtDef '00002001', 'TS RR-CLAIM CLASS'
call rtDef '00002002', 'TS WRITE-CLAIM CLASS'
call rtDef '00002003', 'IX CS-CLAIM CLASS'
call rtDef '00002004', 'IX RR-CLAIM CLASS'
call rtDef '00002005', 'IX WRITE-CLAIM CLASS'
call rtDef '00002006', 'TS PART CS-CLAIM CLASS'
call rtDef '00002007', 'TS PART RR-CLAIM CLASS'
call rtDef '00002008', 'TS PART WRITE-CLAIM CLASS'
call rtDef '00002009', 'IX PART CS-CLAIM CLASS'
call rtDef '00002010', 'IX PART RR-CLAIM CLASS'
call rtDef '00002011', 'IX PART WRITE-CLAIM CLASS'
/* the complete Db2V10 resource type table */
call rtDef '00000100', 'Database', 'DB'
call rtDef '00000200', 'Table space', 'DB.SP'
call rtDef '00000201', 'Index space', 'DB.SP'
call rtDef '00000202', 'Table space RD.DB.TS'
call rtDef '00000205', 'Compression Dictionary', 'DB.SP'
call rtDef '00000210', 'Partition', 'DB.SP.PT'
call rtDef '00000220', 'Data set', 'DSN'
call rtDef '00000230', 'Temporary file', 'SZ'
call rtDef '00000240', 'Database procedure', 'DBP'
call rtDef '00000300', 'Page', 'DB.SP.PG'
call rtDef '00000301', 'Index minipage', 'DB.SP.PG.MP'
call rtDef '00000302', 'Table space page', 'DB.SP.PG'
call rtDef '00000303', 'Index space page', 'DB.SP.PG'
call rtDef '00000304', 'Table space RID', 'DB.SP.RID'
call rtDef '00000305', 'Index access/table space RID', 'DB.SP.RID'
call rtDef '00000306', 'Index access/table space page', 'DB.SP.PG'
call rtDef '00000307', 'Index space EOF', 'DB.SP.01'
call rtDef '00000400', 'ICF catalog', 'IC'
call rtDef '00000401', 'Authorization function'
call rtDef '00000402', 'Security Server',
, 'SAF/RACF return/reason codes'
call rtDef '00000500', 'Storage group', 'SG'
call rtDef '00000602', 'EDM DBD Space'
call rtDef '00000603', 'EDM DYNAMIC STATEMENT Space'
call rtDef '00000604', 'EDM skeleton storage'
call rtDef '00000605', 'EDM above-the-bar storage'
call rtDef '00000606', 'EDM below-the-bar storage'
call rtDef '00000700', 'Buffer pool space', 'BP'
call rtDef '00000701', 'Group buffer pool', 'GBP'
call rtDef '00000800', 'Plan', 'PL'
call rtDef '00000801', 'Package', 'COLLECTION.PACKAGE.CONTOKEN'
call rtDef '00000802', 'BINDLOCK01 through BINDLOCK20',
, 'BINDLOCK01 through BINDLOCK20'
call rtDef '00000900', '32KB data area'
call rtDef '00000901', 'Sort storage'
call rtDef '00000903', 'Hash anchor', 'DB.SP.PG.AI'
call rtDef '00000904', 'RIDLIST storage'
call rtDef '00000905', 'IRLM storage'
call rtDef '00000906', 'DB2', 'MEMBER'
call rtDef '00000907', 'LOB storage'
call rtDef '00000908', 'Basic Floating Point Extensions Facility'
call rtDef '00000909', 'Extended Time-of-Day (TOD) Clock'
call rtDef '0000090A', 'XML storage'
call rtDef '00000A00', 'Table', 'RD.CR.TB'
call rtDef '00000A10', 'Alias', 'RELDEP.OWNER.ALIAS.RD.CR.AL'
call rtDef '00000A11', 'Distinct type', 'SC.DT'
call rtDef '00000A12', 'User-defined function', 'SC.SN'
call rtDef '00000A13', 'Stored procedure', 'SC.SN'
call rtDef '00000A14', 'Sequence'
call rtDef '00000A16', 'Role'
call rtDef '00000A17', 'Trigger'
call rtDef '00000B00', 'View', 'RD.CR.VW'
call rtDef '00000C00', 'Index', 'RD.CR.IX'
call rtDef '00000C01', 'Index', 'CR.IX'
call rtDef '00000D00', 'DBID/OBID', 'RD.DI.OI'
call rtDef '00000D01', 'DBID/OBID', 'DI.OI'
call rtDef '00000D02', 'OBID', 'OI'
call rtDef '00000E00', 'SU limit exceeded', 'CN'
call rtDef '00000F00', 'Auxiliary column',
,'DI.OI.ROWID.COLN or DI.OI.DOCID.COLN'
call rtDef '00000F01', 'LOB lock', 'DIX.PIX.ROWID.VRSN'
call rtDef '00000F81', 'XML lock', 'DIX.PIX.DOCID'
call rtDef '00001000', 'DDF', 'LOCATION or SUBSYSTEM ID'
call rtDef '00001001', 'System conversation',
, 'LU.MODE.RTNCD.FDBK2.RCPRI.RCSEC.SENSE'
call rtDef '00001002', 'Agent conversation',
, 'LU.MODE.RTNCD.FDBK2.RCPRI.RCSEC.SENSE'
call rtDef '00001003', 'CNOS processing',
, 'LU.MODE.RTNCD.FDBK2.RCPRI.RCSEC.SENSE'
call rtDef '00001004', 'CDB (Communication database)',
, 'LOCATION.AUTHORIZATIONID.PL'
call rtDef '00001005', 'DB access agent', 'LOCATION'
call rtDef '00001007', 'TCP/IP domain name', 'LINKNAME.DOMAIN.ERRNO'
call rtDef '00001008', 'TCP/IP service name', 'LOCATION.SERVICE.ERRNO'
call rtDef '00001080', 'ACCEL', 'SERVER.DOMAIN'
call rtDef '00001102', 'Bootstrap data set (BSDS)', 'MEMBER'
call rtDef '00002000', 'Table space CS-claim class', 'DB.SP'
call rtDef '00002001', 'Table space RR-claim class', 'DB.SP'
call rtDef '00002002', 'Table space write-claim class', 'DB.SP'
call rtDef '00002003', 'Index space CS-claim class', 'DB.SP'
call rtDef '00002004', 'Index space RR-claim class', 'DB.SP'
call rtDef '00002005', 'Index space write-claim class', 'DB.SP'
call rtDef '00002006', 'Table space partition CS-claim class',
, 'DB.SP.PT'
call rtDef '00002007', 'Table space partition RR-claim class',
, 'DB.SP.PT'
call rtDef '00002008', 'Table space partition write-claim class',
, 'DB.SP.PT'
call rtDef '00002009', 'Index space partition CS-claim class',
, 'DB.SP.PT'
call rtDef '00002010', 'Index space partition RR-claim class',
, 'DB.SP.PT'
call rtDef '00002011', 'Index space partition Write-claim class',
, 'DB.SP.PT'
call rtDef '00002100', 'Table space DBET entry', 'DB.SP'
call rtDef '00002101', 'Index space DBET entry', 'DB.SP'
call rtDef '00002102', 'Table space partition DBET entry', 'DB.SP.PT'
call rtDef '00002103', 'Index space partition DBET entry', 'DB.SP.PT'
call rtDef '00002104', 'DBET hash chain lock timeout',
, 'INTERNAL LOCK NN'
call rtDef '00002105', 'Logical partition DBET entry', 'DB.SP.PT'
call rtDef '00002200', 'Routine Parameter Storage', 'DBP'
call rtDef '00002201', 'm.debug Agent Storage', 'DBP'
call rtDef '00002300', 'ICSF encryption and decryption facilities'
call rtDef '00003000', 'Code (release maintenance_level or system' ,
'parameter)', 'REL,APAR,ZPARM'
call rtDef '00003002', 'Number of Stored Procedures'
call rtDef '00003072', 'Index'
call rtDef '00003073', 'Index'
call rtDef '00003328', 'Release dependency'
call rtDef '00003329', 'DBID/OBID', 'DI.OI'
call rtDef '00003330', 'OBID limit exceeded'
call rtDef '00003840', 'LOB column'
call rtDef '00004000', 'Profile exception threshold exceeded',
, 'PID.PTYPE.PNAME'
return
endProcedure resourceTypeIni
rtDef: procedure expose m.
parse arg cd, nm, pa
if symbol('m.resourceType.cd') <> 'VAR' then
m.resourceType.cd = nm
m.resourceTypeParms.cd = pa
return
endProcedure rtDef
getDbidObid: procedure expose m.
parse arg dbSys, dbid, obid
SQL_DBID = STRIP(dbid,L,0)
SQL_OBID = STRIP(obid,L,0)
if symbol('m.id2n.dbSys.dbidObid.dbid.obid') == 'VAR' then
/* haben es schon mal gefunden*/
return m.id2n.dbSys.dbidObid.dbid.obid
/* select from catalog */
/* from sysTables */
if dbSys \== m.sql_dbSys then do
if m.sql_dbSys \== '' then
call sqlDisconnect
if m.tstRZ4 then
if sysvar(sysNode) = 'RZ4' ,
& wordPos(dbSys, 'DP4G DBOL') < 1 then
return ''
call sqlConnect dbSys
end
res = sql2One("SELECT ",
" STRIP(CREATOR,B)!!'.'!!STRIP(NAME,B) ",
" FROm SYSIBM.SYSTABLES ",
" WHERE DBID = " SQL_DBID ,
" AND OBID = " SQL_OBID ,
, , ':m.qq.rNm :SQL_IND', , ' ')
if res == '' then
res = sql2One("SELECT ",
" STRIP(DBNAME,B)!!'.'!!STRIP(NAME,B) ",
" FROM SYSIBM.SYSTABLESPACE ",
" WHERE DBID = " SQL_DBID ,
" AND OBID = " SQL_OBID ,
, , ':m.qq.rNm :SQL_IND', , ' ')
if res == '' then
res = sql2One( "SELECT ",
" STRIP(CREATOR,B)!!'.'!!STRIP(NAME,B) ",
" FROM SYSIBM.SYSINDEXES ",
" WHERE DBID = " SQL_DBID ,
" AND OBID = " SQL_OBID ,
, , ':m.qq.rNm :SQL_IND', , ' ')
m.dbidObid.dbid.obid = res
return m.dbidObid.dbid.obid
endProcedure getDbidObid
/*_________________________________________________________________________
!!
!! INSERT IN DB2 TABELLE TADM60A1
!!_________________________________________________________________________
*/
INSERT_TADM60A1: procedure expose m. dsnRZ4.
IF m.debug THEN SAY "ENTER PROCEDURE INSERT_TADM60A1..."
cIns = 0
cDead = 0
cTime = 0
say ' ' time() 'begin insert into tadm60a1'
call sqlUpdPrep 7,
, "INSERT INTO "m.tadmCreator".TADM60A1 (" ,
"TIMESTAMP, ssid, event_type," ,
"VICTIM_PLAN, VICTIM_CORR_ID, VICTIM_COnn_ID," ,
"SOURCE_PLAN, SOURCE_CORR_ID, SOURCE_COnn_ID," ,
"REASON_CODE, type, name )" ,
"VALUES (?,?,?,?,?,?,?,?,?,?,?,?)"
do tx=1 to m.to.0
/*______________________________________________________________________
row überspringen falls alt
*/
if (m.to.tx.evTy == 'D' & m.to.tx.tst <= m.lastDeadlock ) ,
|(m.to.tx.evTy == 'T' & m.to.tx.tst <= m.lastTimeout ) then
iterate
call sqlUpdArgs 7,
, m.to.tx.tst, m.to.tx.v.dbMb, m.to.tx.evTy,
, m.to.tx.v.plan, m.to.tx.v.corr, m.to.tx.v.conn,
, m.to.tx.h.plan, m.to.tx.h.corr, m.to.tx.h.conn,
, m.to.tx.reason, m.to.tx.type, m.to.tx.name
cIns = cIns + 1
cDead = cDead + (m.to.tx.evTy == 'D')
cTime = cTime + (m.to.tx.evTy == 'T')
end
call sqlCommit
say ' ' time() cIns 'inserted into tadm60a1,' ,
cDead 'deadlocks and' cTime 'timeouts'
IF m.debug THEN SAY "LEAVE PROCEDURE INSERT_TADM60A1..."
RETURN;
/*_________________________________________________________________________
!!
!! INSERT IN DB2 TABELLE TADM63A1
!!_________________________________________________________________________
*/
INSERT_TADM63A1: procedure expose m. dsnRZ4.
IF m.debug THEN SAY "ENTER PROCEDURE INSERT_TADM63A1..."
say ' ' time() 'begin insert into tadm63a1'
call sqlUpdPrep 7,
, "INSERT INTO "m.tadmCreator".TADM63A1 (" ,
"TIMESTAMP," ,
"SSID," ,
"EVENT_TYPE," ,
"PLAN_NAME," ,
"CORRID_ID," ,
"CONN_ID," ,
"AUTHID," ,
"LOGREC)" ,
"VALUES (?,?,?,?,?,?,?,?)"
cIns = 0
cUOW = 0
cCHK = 0
do tx=1 to m.uow.0
ux = 'UOW.'tx
if m.ux.UC == 'U' & m.ux.tst <= m.lastUOW then
iterate
if m.ux.UC == 'C' & m.ux.tst <= m.lastCheckp then
iterate
cIns = cIns + 1
cUOW = cUOW + (m.ux.UC == 'U')
cCHK = cCHK + (m.ux.UC == 'C')
call sqlUpdArgs 7,
,m.ux.tst,
,m.ux.dbMb,
,m.ux.UC,
,m.ux.plan,
,m.ux.corr,
,m.ux.conn,
,m.ux.authid,
,m.ux.logRecs
end
call sqlCommit
say ' ' time() cIns 'inserted into tadm63a1,' ,
cUOW 'uncommitedUOW and' cCHK 'checkpoints'
IF m.debug THEN SAY "LEAVE PROCEDURE INSERT_TADM63A1..."
RETURN;
/*_________________________________________________________________________
!!
!! INSERT IN DB2 TABELLE TADM64A1
!!_________________________________________________________________________
*/
INSERT_TADM64A1: procedure expose m. dsnRZ4.
IF m.debug THEN SAY "ENTER PROCEDURE INSERT_TADM64A1..."
say ' ' time() 'begin insert into tadm64a1'
call sqlUpdPrep 10,
, "INSERT INTO "m.tadmCreator".TADM64A1 (" ,
"TIMESTAMP," ,
"SSID," ,
"EVENT_TYPE," ,
"PLAN_NAME," ,
"PACKAGE_NAME," ,
"COLLECTION_ID," ,
"CORRID_ID," ,
"CONN_ID," ,
"RESOURCE," ,
"LOCK_STATE," ,
"STATEMENT)" ,
"VALUES (?,?,?,?,?,?,?,?,?,?,?)"
cIns=0
do tx=1 to m.LoEs.0
ux = 'LOES.'tx
if m.ux.tst <= m.lastLockesc then
iterate
cIns = cIns + 1
call sqlUpdArgs 10,
,m.ux.tst,
,m.ux.dbMb,
,m.ux.E,
,m.ux.plan,
,m.ux.package,
,m.ux.CollID,
,m.ux.corr,
,m.ux.conn,
,m.ux.resource,
,m.ux.LckSt,
,m.ux.Statement
end
call sqlCommit
say ' ' time() cIns 'inserted into tadm64a1,' ' LOCK ESCALATION'
IF m.debug THEN SAY "LEAVE PROCEDURE INSERT_TADM64A1..."
RETURN;
/*_________________________________________________________________________
!!
!! INSERT IN DB2 TABELLE TADM65A1
!!_________________________________________________________________________
*/
INSERT_TADM65A1: procedure expose m. dsnRZ4.
IF m.debug THEN SAY "ENTER PROCEDURE INSERT_TADM65A1..."
say ' ' time() 'begin insert into tadm65a1'
call sqlUpdPrep 10,
, "INSERT INTO "m.tadmCreator".TADM65A1 (" ,
"TIMESTAMP," ,
"SSID," ,
"EVENT_TYPE," ,
"CORRID_ID," ,
"JOBNAME," ,
"CONN_ID," ,
"AUTHID," ,
"ASID," ,
"TCB)" ,
"VALUES (?,?,?,?,?,?,?,?,?)"
cIns=0
do tx=1 to m.ReEot.0
ux = 'REEOT.'tx
if m.ux.tst <= m.lastReadEot then
iterate
cIns = cIns + 1
call sqlUpdArgs 10,
,m.ux.tst,
,m.ux.dbMb,
,m.ux.A,
,m.ux.corr,
,m.ux.Jobname,
,m.ux.conn,
,m.ux.AuthID,
,m.ux.AsID,
,m.ux.tcb
end
call sqlCommit
say ' ' time() cIns 'inserted into tadm65a1,' ' ABNORMAL EOT'
IF m.debug THEN SAY "LEAVE PROCEDURE INSERT_TADM65A1..."
RETURN;
/*-- quote text t with apostrophs (sql string)
truncate if longer then 18 characters ---------------------------*/
cut18: procedure expose m.
parse arg t
if length(t) <= 18 then
return t
else
return left(space(t, 1), 18)
endProcedur cut18
/*----------------------------------------------------------------*/
/*--------- AUSGEBEN VON SQL-FEHLERBESCHREIBUNG SQLCA ------------*/
/*----------------------------------------------------------------*/
SQLCA:
IF m.debug THEN SAY "ENTER PROCEDURE SQLCA..."
parse ARG msg
ggSqlStmt = sqlText
call err msg sqlMsg()
csv4obj: procedure expose m.
parse arg o, ff, hasNull, oNull
res = ''
do fx=1 to m.ff.0
of1 = o || left('.', m.ff.fx \== '') || 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
/*_____________________________________________________________________
!!
!! DSN erstellen für RZ4
!!_____________________________________________________________________
*/
writeAblfAll: procedure expose m.
parse arg pre
call writeAblf to, fftimeO, pre'.TADM60A1'
call writeAblf uow, ffUow, pre'.TADM63A1'
call writeAblf Loes, ffLockE, pre'.TADM64A1'
call writeAblf ReEot, ffEOT, pre'.TADM65A1'
return 0
endProcedure writeAblfAll
writeAblf: procedure expose m.
parse arg st, ff, dsn
/*______________________________________________________________________
!!
!!new dsn write
!!______________________________________________________________________
*/
do sx=1 to m.st.0
o.sx = csv4obj(st'.'sx, ff, 0)
end
dsn=dsn'.D'date('j')'.T'translate(124578, time(), 12345678)
call writeDsn dsn '::v300', 'O.', m.st.0, 1
return
endProcedure writeAblf
newDSN: procedure expose dsnRZ4.
/*
dsnRZ4.1='DSN.ABLF.LOGEX.DE0G.TADM60A1'
dsnRZ4.2='DSN.ABLF.LOGEX.DE0G.TADM63A1'
dsnRZ4.3='DSN.ABLF.LOGEX.DE0G.TADM64A1'
dsnRZ4.4='DSN.ABLF.LOGEX.DE0G.TADM65A1'
address tso
do i=2 to 4
ok#dsn=SYSDSN("'"dsnRZ4.i"'")
IF ok#dsn = 'OK' then do
SAY 'DSN EXISTS WIRD GELÖSCHT'OK#DSN' = 'dsnRZ4.i
"DELETE '"dsnRZ4.i"'"
if RC>0 then say 'DSN konnte nicht gelöscht werden'
END
/*ok#dsn=SYSDSN("'"dsnRZ4.i"'")
*/ y=0
do until (fb=0 | y>2 )
"ALLOC DDNAME(DDN"i") DSN('"dsnRZ4.i"') new lrecl(160) recfm(f b)"
fb=rc;y=y+1
if fb>0 then do
"FREE DDNAME(DDN"i")"
end
end
end
*/
return
/*--- 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
/* copy eJes begin ***************************************************/
eJesJobExtDD: procedure expose m.
parse arg jMask, dd
call eJesInit jMask
call eJesExec '* st', job_
say 'jMask='jMask':' job_lines 'jobs'
do jx=1 to job_lines
call eJesExec "0 locate" jx, job_
cc = eJesExec("* :s", ds_, 4 8)
if cc <> 0 then do
if ds_msgShort = 'Job no longer found' then
say 'job' job_jobName.jx 'no longer found'
else
call eJesErr ds_, ':s' job_jobName.jx, cc
iterate
end
say 'job' jx job_jobName'('job_jobId'):' ds_lines 'datasets'
cc = eJesExec("0 f" dd" 3 10", ds_, 4 8)
if cc <> 0 | ds_tcdata.ds__ddName <> dd then do
if ds_msgShort = 'String not found' then
say 'dd' dd 'not found' ds_tcdata.ds__ddName
else
call eJesErr ds_, 'dd' ds_tcdata.ds__ddName,
'<> searched' dd, cc
end
else do
say 'dd='dd 'step='ds_tcdata.ds__sName ,
'recs='ds_tcdata.ds__records
call eJesExec "0 :e", ex_
say strip(ex_msg.0 ex_msg.1) '==> dd eJesExt'
end
call eJesExec "0 end", ds_
end
call eJesTerm
return
endProcedure
eJesExec:
parse arg ggS1 ggStmt, ggPrf, ggRet
if ggPrf == '' then
ggCC =eJesRexx("execApi" ggS1" '"ggStmt"'")
else
ggCC =eJesRexx("execApi" ggS1" '"ggStmt"' (prefix" ggPrf)
if ggCC <> 0 & wordPos(ggCC, ggRet) < 1 then
call eJesErr ggPrf, ggStmt, ggCC
return ggCC
endProcedure eJesExec
eJesInit: procedure expose m.
parse arg ggPref
ggCC =eJesRexx('initApi')
if ggCC <> 0 & eJes_MsgShort <> 'SAF security disabled' then
call eJesErr eJes_, 'initApi', ggCC
call eJesExec "0 pReset"
call eJesExec "0 owner=" /* sonst gibts nur meine */
call eJesExec "0 maskChar *%" /* default ist space */
if ggPref \== '' then
call eJesExec "0 jName="ggPref
return
endProcedure eJesInit
eJesTerm: procedure expose m.
cc =eJesRexx('termApi')
if cc <> 0 then
call err 'termApi CC='cc eJes_msgShort
return
endProcedur eJesTerm
eJesErr:
parse arg ggPrf, ggMsg, ggEE
if ggPrf == '' then
ggPrf = 'EJES_'
call eJesScreen ggPrf, 'eJesErr CC='ggEE ggMsg
ggMsg = strip(ggMsg 'cc='ggEE ,
'msg.0='value(ggPrf'Msg.0') 'prefix='ggPrf) ,
|| '\n 'strip(value(ggPrf'MsgShort'))
if datatype(value(ggPrf'Msg.0'), 'n') then
do ggX=1 to value(ggPrf'Msg.0')
ggMsg = ggMsg'\n 'strip(value(ggPrf'Msg.ggX'))
end
call eJesTerm
call err 'eJes' ggMsg
endProcedure eJesErr
eJesMsg:
parse arg ggPrf, ggMsg
say strip(ggMsg value(ggPrf'MsgShort'),
'msg.0='value(ggPrf'Msg.0') 'prefix='ggPrf)
if datatype(value(ggPrf'Msg.0'), 'n') then
do ggX=1 to value(ggPrf'Msg.0')
say 'msg.'ggX'='value(ggPrf'Msg.ggX')
end
return
endProcedure eJesMsg
eJesScreen:
parse arg ggPrf, ggMsg
call eJesMsg ggPrf, ggMsg
say left('eJes screen fun='value(ggPrf'FunName') ,
value(ggPrf'FunType') 'Image.0='value(ggPrf'scrImage.0') ,
, 78, '-')
if datatype(value(ggPrf'scrImage.0'), 'n') then
do ggX=1 to value(ggPrf'scrImage.0')
if value(ggPrf'scrImage.ggX') <> '' then
say strip(value(ggPrf'scrImage.ggX'), 't')
end
return
endProcedure eJesScreen
/* copy eJes end ***************************************************/
/* copy ii begin ********* Installation Info *************************/
iiini: procedure expose m.
if m.ii_ini == 1 then
return
m.ii_ini = 1
m.ii_rz = ''
m.ii.rzC = ''
i = 'RZ1 1 S1 DBTF T DTF DVTB V DTB DBOC C DOC' ,
'RZ2 2 S2 DBOF F DOF DVBP P DBP DP2G Q DP2' ,
'RR2 R R2 DBOF F DOF DVBP P DBP DP2G Q DP2' ,
'RQ2 Q Q2 DBOF F DOF DVBP P DBP DP2G Q DP2' ,
'RZ4 4 S4 DBOL O DOL DP4G U DP4' ,
'RZX X X2 DE0G E DE0 DEVG M DEV DPXG I DPX DX0G X DX0' ,
'RZY Y Y2 DE0G E DE0 DEVG M DEV DPYG Y DPY' ,
'RZZ Z Z2 DE0G E DE0 DEVG M DEV DPZG N DPZ'
m.ii_rz = ''
m.ii_rzC = ''
do wx=1 by 3 to words(i)
parse value subWord(i, wx, 3) with w1 w2 w3
if abbrev(w1, 'R') & length(w1) == 3 then do
rz = w1
m.ii_DbSys.rz = ''
m.ii_rz = strip(m.ii_rz rz)
m.ii_rzC = m.ii_rzC || w2
call iiA1 ii_sys2rz, w3, rz
call iiA1 ii_rz2c, rz, w2
end
else if abbrev(w1, 'D') & length(w1) == 4 then do
m.ii_DbSys.rz = strip(m.ii_DbSys.rz w1)
call iiA1 ii_db2c, w1, w2
call iiA1 ii_mbr2db, w3, w1
call iiA1 ii_db2Elar, w1, wordPos(w1, 'DVTB DVBP DEVG')>0
end
else
call err 'bad w1' w1 w2 w3
end
return
endProcedure iiIni
iiA1: procedure expose m.
parse arg st, key ,val
if symbol('m.st.key') \== 'VAR' then
m.st.key = val
else if m.st.key \== val then
call err 'already <> defined' st'.'key'='m.st.key 'val='val
return
endProcedure iiA1
iiMbr2DbSys: procedure expose m.
parse upper arg mbr
return iiLazy(ii_mbr2db, left(mbr, 3), 'member')
iiRz2C: procedure expose m.
parse upper arg rz
return iiLazy(ii_rz2c, rz, 'rz')
iiRz2Dsn: procedure expose m.
parse upper arg rz
return overlay('Z', rz, 2)
iiDBSys2C: procedure expose m.
parse upper arg db
return iiLazy(ii_db2c, db, 'dbSys')
iiSys2RZ: procedure expose m.
parse upper arg sys
return iiLazy(ii_sys2rz, left(sys, 2), 'sys')
iiLazy: procedure expose m.
parse arg st, key, txt
if symbol('m.st.key') == 'VAR' then
return m.st.key
if m.ii_ini == 1 then
return err('no' txt'='key 'in ii' st)
call iiIni
return iiLazy(st, key, txt)
endProcedure iiRz2C
iiRzDbSysBegin:procedure expose m.
parse arg m
call iiIni
m.m.rx = 1
m.m.dx = 0
return
endProcedure iiRzDbSysBegin
iiRzDbSys:procedure expose m.
parse arg m
do forever
rz = word(m.ii_rz, m.m.rx)
if rz == '' then do
call vPut 'rz', ''
call vPut 'dbSys', ''
return 0
end
m.m.dx = m.m.dx+1
db = word(m.ii_dbSys.rz, m.m.dx)
if db == '' then do
m.m.rx = m.m.rx + 1
m.m.dx = 0
iterate
end
call vPut 'rz', rz
call vPut 'rzC', iiRz2C(rz)
call vPut 'rzD', iiRz2Dsn(rz)
call vPut 'dbSys', db
call vPut 'dbSysC', iidbSys2C(db)
call vPut 'dbSysElar', iiLazy(ii_db2Elar, db)
return 1
end
endProcedure iiRzDbSys
/* copy ii end ********* Installation Info *************************/
/* 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 -------------------*/
sqlQueryPrep: 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 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
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'
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
/*-- 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
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 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
/*--- timestamp to days since 1.1.0001 ------------------------------*/
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')
ret = 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)
return ret
/*--- 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 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
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
bef0 = m.m.0
if \ readDD(m.m.dd, 'M.'m'.', m.m.cnt) then do
say 'atEnd????' m bef0 m.m.cx m.m.0 m.m.buf0x
say m bef0 m.m.cx m.m.0 m.m.buf0x
return ''
end
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
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 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(1, 50) 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 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_alfUCNum = m.ut_alfUC || m.ut_digits
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 ********************************************************/
/* 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 out begin ******************************************************
out interface simple with say only
***********************************************************************/
/*--- output a message to the current destination -------------------*/
out: procedure expose m.
parse arg msg
say msg
endProcedure out
/* copy out end *****************************************************/