zOs/REXX.O08/RLRSN
/*rexx*/
/******************************************************************/
/* LRSN */
/* */
/* 1 FUNCTION Translate Timestamp <-> LRSN (Todclock) */
/* */
/* 2 SUMMARY */
/* TYPE Rexx TSO/ISPF */
/* HISTORY: */
/* 09.11.2006 V1.0 base version (M.Streit,KITD2) */
/* 01.11.2007 V1.1 added uniq (W.Keller,KIUT23) */
/* */
/* Call: tso lrsn (TSO.RZ1.P0.USER.EXEC) */
/* */
/* 3 USAGE rexx lrsn start-procedure */
/* rexx rlrsn programm */
/* panel plrsn Mainpanel */
/* table tlrsn ISPF table */
/* */
/******************************************************************/
debug = 0 /* 0 oder 1 */
numeric digits 32
/* Check if LogMode 4 used */
lines=SYSVAR(SYSLTERM)
cols =SYSVAR(SYSWTERM)
if lines < 43
then do;
address ISPEXEC;
zmsg000l = "LM4 with 43x80 Chars required"
"setmsg msg(ispz000)"
exit(8);
end ;
/* Create ISPF table if necessary */
address ispexec
"control errors return" /* ISPF Error -> control back to pgm */
"tbopen tlrsn write" /* try to open table */
NAMES ="(CLRSN CTS CTSUTC CUNIQ JULIAN GMTTIME)"
if RC = 0 then do
address ispexec "tbQuery tlrsn names(tnm)"
if tnm <> names then do
say 'old table tLrsn has bad filed names' tnm
say 'drop and recreate table tLrsn' names
address ispexec 'tbEnd tLrsn'
address ispexec 'tberase tLrsn'
rc = 8
end
end
if rc = 8 then do /* if table not found...*/
address ispexec
"tbcreate tlrsn", /* table create */
"names"names "write replace"
if rc > 4 then do
say "Table create error with RC "rc
exit
end
"tbopen tlrsn write" /* table open */
end
if rc = 12 then do
"tbclose tlrsn "
"tbopen tlrsn write" /* try to open table */
if rc > 0 then do
say "Table open error with RC "rc
end
end
"tbtop tlrsn" /* jump to first row */
/* Display panel until PF3 is pressed */
selrows = "ALL" /* Angaben für Panel */
num1 = 1 /* Linien-Pointer */
c = ''
zc = 'CSR'
sdata = 'N'
ptimest = ''
plrsn = ''
do forever /* solange nicht PF3 */
call read_cvt
"tbtop tlrsn" /* jump to first row */
"tbdispl tlrsn panel(plrsn)" /* Panel anzeigen bis */
if rc > 4 then leave /* PF3 gedrückt? */
do while rc < 8
if c = 'D' then do
call del_row /* Zeilen löschen */
end
else if c <> ' ' then do
zmsg000s = "Command unknown"
zmsg000l = "Command unknown, only Delete(D) allowed"
"setmsg msg(ispz000)" /* Meldung ausgeben */
leave
end
if ztdSels <= 1 then
leave
"tbdispl tlrsn" /* get next selection */
end
c = ''
if plrsn <> '' then call calcFromLrsn pLrsn
if ptimest <> '' then call calcFromTst pTimeSt
if pUniq <> '' then call calcFromUniq pUniq
end
if sdata='Y' then
"tbclose tlrsn "
else
"tbend tlrsn"
exit
/* expand timestamp and validate it ***********************************/
checkTst: procedure
parse arg pTimeSt
/* ptimest = Timestamp format yyyy-mm-dd-hh.mm.ss.ffffff */
rTimeSt =overlay(ptimest, '1972-01-01-00.00.00.000000')
call parseTimestamp rTimest
/* check if values in range */
if (yyyy<1972) | (yyyy>2141) then do
zmsg000s = ""
zmsg000l = "year range: 1972-2041"
address ispExec " setmsg msg(ispz000)" /* Meldung ausgeben */
return ''
end
if (mo<1) | (mo>12) then do
zmsg000s = ""
zmsg000l = "month range 1-12"
address ispExec "setmsg msg(ispz000)" /* Meldung ausgeben */
return ''
end
if (dd<1) | (dd>31) then do
zmsg000s = ""
zmsg000l = "day range 1-31"
address ispexec "setmsg msg(ispz000)" /* Meldung ausgeben */
return ''
end
return rTimest
endProckedure checkTst
parseTimestamp:
parse arg yyyy'-'mo'-'dd'-'hh'.'mm'.'ss'.'ffffff
return
return mo'/'dd'/'yyyy' 'hh':'mm':'ss'.'ffffff
/* delete current row ***********************************************/
del_row:
address ispexec
rowid_nr=0
"tbget tdbnr rowid(rowid_nr)" /* Curor-Position lesen */
"tbskip tdbnr row("rowid_nr")" /* Cursor auf Row setzen */
"tbdelete tlrsn" /* Zeile löschen */
c = ''
return
/* read timeZoneOffset and leapSeconds registers
and set variables for uniq ***********************************/
read_cvt:
/* offsets documented in z/OS Data Areas Vol.1 */
cvt_off ='00000010' /* (offset = X'10') */
cvtext2_off='00000560'
cvtldto_off='00000038'
cvtlso_off ='00000050'
/* get CVT control block adress */
cvt_adr =C2X(STORAGE(cvt_off,4))
/* get address of extention2 */
cvtext2_adr =D2X(X2D(cvt_adr) + X2D(cvtext2_off))
/* get address of cvtldto timezone value */
cvtldto_adr =D2X(X2D(cvtext2_adr) + X2D(cvtldto_off))
/* get value */
cvtldto =C2X(STORAGE(cvtldto_adr,8))
/* get address of cvtlso leap seconds value */
cvtlso_adr =D2X(X2D(cvtext2_adr) + X2D(cvtlso_off))
/* get value */
cvtlso =C2X(STORAGE(cvtlso_adr,8))
cTZ = x2d(cvtLdto) * 1e-6 / 256 / 16 / 3600
cLS = trunc(x2d(cvtLso) * 1e-6 / 256 / 16)
uniqDigits = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ012345678'
/* find lrsn of day 0 */
uniqZero = left(conv2tod('2004-12-31-00.00.22.000000'), 12)
/* 0 out last 6 bits */
uniqZero = b2x(overlay('000000', x2b(uniqZero), 43))
if debug then do
say "cvt_adr = "cvt_adr
say "cvtext2_adr = "cvtext2_adr
say "cvtldto_adr = "cvtldto_adr
say "cvtldto (TOD-fmt) = "cvtldto,
'=' (x2d(cvtldto) * 16e-6 / 256 / 256) 'secs timezone'
say "cvtldto_adr = "cvtlso_adr
say "cvtlso (TOD-fmt) = "cvtlso ,
'=' (x2d(left(cvtlso, 13)) * 1e-6 ) 'leap secs'
say 'uniqZero' uniqZero ,
'base' length(uniqDigits) 'digits' uniqDigits
end
return
endSubroutin read_cvt
/* calculate all values from timestamp and add row ********************/
calcFromTst:
parse arg pTst
/* Timestamp format: yyyy-mm-dd-hh.mm.ss.ffffff */
rTimeSt = checkTst(pTst)
if rTimeSt = '' then
return
lrsn_cet= CONV2TOD(rTimeSt)
lrsn_cet=LEFT(STRIP(lrsn_cet),16,'0')
if debug then say "LRSN (CET) ="lrsn_cet
cLrsn = D2X(X2D(lrsn_cet) - X2D(CVTLDTO) + X2D(CVTLSO))
if debug then say "LRSN (UTC) ="clrsn
cts = rtimest /*ptimest with overlay */
ctsutc = CONV2TS(clrsn)
gmtTime = substr(ctsutc, 12, 8)
cUniq = lrsn2uniq(cLrsn)
julian = tst2jul(cts)
ptimest = ''
"tbadd tlrsn"
return
endProcedure calcFromTst
/* from lrsn calculate all values add it to our table *****************/
calcFromLrsn:
parse arg lrsn
LRSN=LEFT(STRIP(LRSN),16,'0')
if debug then say "LRSN (UTC) ="LRSN
LRSN_TZ=D2X(X2D(LRSN) + X2D(CVTLDTO))
if debug then say "LRSN timezone corrected ="LRSN_TZ
LRSN_CET=D2X(X2D(LRSN_TZ) - X2D(CVTLSO))
if debug then say "LRSN timezone and leap seconds corrected ="LRSN_CET
if debug then say ""
if debug then say ""
if debug then say ""
/*********
LEAPSEC = 23
XSEC = X2D('0000000F4240000');
1 2 3 4 5 6 7
CORR = LEAPSEC * XSEC
**********/
if debug then say =CONV2TS(LRSN) "(UTC)"
clrsn = lrsn
cts = CONV2TS(LRSN_CET)
ctsutc = CONV2TS(LRSN)
gmtTime = substr(ctsutc, 12, 8)
cUniq = lrsn2uniq(cLrsn)
julian = tst2jul(cts)
"tbadd tlrsn"
if debug then say "RC="rc
plrsn = ''
return
endProcedure calcFromLrsn
/* from uniq calculate all values and add them to our table ***********/
calcFromUniq:
parse arg uniq
if verify(uniq, uniqDigits) > 0 then do
zmsg000s = "bad uniq"
zmsg000s = ""
zmsg000l = "Uniq allows only characters A-Z and 0-8"
"setmsg msg(ispz000)" /* Meldung ausgeben */
return
end
call calcFromLrsn uniq2Lrsn(uniq)
pUniq = ''
return
calcFromUniq
/* timestamp to julian ************************************************/
tst2jul: procedure
parse arg yyyy '-' mm '-' dd '-'
/* date function cannot convert to julian, only from julian
==> guess a julian <= the correct and
try the next values
*/
j = trunc((mm-1) * 29.5) + dd
yy = right(yyyy, 2)
do j=j by 1
j = right(j, 3, 0)
d = date('s', yy || j, 'j')
if substr(d, 3) = yy || mm || dd then
return yy || j
end
return
/* convert a lrsn to the uniq variable ********************************/
lrsn2uniq: procedure expose uniqZero uniqDigits debug
parse arg lrsn
/* unique are bits 0:41 of the TodClock value
minus 31.12.2004 represented
by base 35 by 'ABC...YZ01..8'
*/
lrsn = left(lrsn, 12)
diff = x2d(lrsn) - x2d(uniqZero)
if diff < 0 then
return '<2005|'
diff = right(d2x(diff), 12, 0)
if debug then say ' lrsn ' lrsn
if debug then say '- zero ' uniqZero
if debug then say '= ' diff
d42 = b2x(left(right(x2b(diff), 48, 0), 42))
if debug then say 'd42 ' d42
uni = right(i2bd(x2d(d42), uniqDigits), 8, 'A')
if debug then say 'uni ' uni
return uni
endProcedure lrsn2uniq
/* convert a uniq variable to lrsn ************************************/
uniq2lrsn: procedure expose uniqZero uniqDigits
parse arg uniq
uniq = left(uniq, 8, 'A')
d42 = d2x(bd2i(uniq, uniqDigits))
d48 = b2x('00'x2b(d42)'000000')
lrsn = right(d2x(x2d(d48) + x2d(uniqZero)), 12, 0)
return lrsn
endProcedure uniq2lrsn
/* conversion from Timestamp to TOD Clock Value ***********************/
CONV2TOD: PROCEDURE
/* timestamp yyyy-mm.... -> tod value: - leapseconds
BLSUXTID is described in z/OS V1R7.0 MVS IPCS Customization
BLSUXTID format : mo/dd/yyyy hh:mm:ss.ffffff
*/
parse arg tst
call parseTimestamp tst
tDate = mo'/'dd'/'yyyy' 'hh':'mm':'ss'.'ffffff
ACC=copies('0',8)
ADDRESS LINKPGM "BLSUXTID TDATE ACC"
RETURN LEFT(c2x(ACC),16,'0')
endProcedure conv2tod
/* conversion from TOD Clock Value to Timestamp */
/* BLSUXTOD is described in z/OS V1R7.0 MVS IPCS Customization */
/* input -> + leapseconds -> output */
CONV2TS: PROCEDURE
ACC=ARG(1)
ACC=X2C(ACC)
TDATE = COPIES('0' , 26)
ADDRESS LINKPGM "BLSUXTOD ACC TDATE"
/* return format : mo/dd/yyyy hh:mm:ss.ffffff */
/* Timestamp format: yyyy-mm-dd-hh.mm.ss.ffffff */
parse var TDATE mo '/' dd '/' yyyy hh ':' mm ':' ss '.' ffffff
TDATE = yyyy'-'mo'-'dd'-'hh'.'mm'.'ss'.'ffffff
RETURN TDATE
bd2i: procedure expose m.
parse arg v, digits
b = length(digits)
i = 0
do x = 1 to length(v)
q = substr(v, x, 1)
r = pos(q, digits)
if r < 1 then
call err 'bad digit' q 'in' v 'valid digits' digits
i = i * b + r - 1
end
return i
i2bd: procedure expose m.
parse arg i, digits
if i = 0 then
return left(digits, 1)
b = length(digits)
v = ''
do while i > 0
v = substr(digits, 1 + (i // b), 1) || v
i = i % b
end
return v