zOs/REXX/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 ;
say 'walters test version lrsn'
/* Create ISPF table if necessary */
address ispexec
"control errors return" /* ISPF Error -> control back to pgm */
"tbopen tlrsn write" /* try to open table */
NAMES ="(CLRSN CTS CTSUTC CUNIQ JULIAN GMTTIME)"
if RC = 0 then do
address ispexec "tbQuery tlrsn names(tnm)"
if tnm <> names then do
say 'old table tLrsn has bad filed names' tnm
say 'drop and recreate table tLrsn' names
address ispexec 'tbEnd tLrsn'
address ispexec 'tberase tLrsn'
rc = 8
end
end
if rc = 8 then do /* if table not found...*/
address ispexec
"tbcreate tlrsn", /* table create */
"names"names "write replace"
if rc > 4 then do
say "Table create error with RC "rc
exit
end
"tbopen tlrsn write" /* table open */
end
if rc = 12 then do
"tbclose tlrsn "
"tbopen tlrsn write" /* try to open table */
if rc > 0 then do
say "Table open error with RC "rc
end
end
"tbtop tlrsn" /* jump to first row */
/* Display panel until PF3 is pressed */
selrows = "ALL" /* Angaben für Panel */
num1 = 1 /* Linien-Pointer */
c = ''
zc = 'CSR'
sdata = 'N'
ptimest = ''
plrsn = ''
do forever /* solange nicht PF3 */
call timeReadCvt
cLS = trunc(m.time_Leap * m.time_StckUnit)
cTZ = trunc(m.time_Zone * m.time_StckUnit / 3600)
"tbtop tlrsn" /* jump to first row */
"tbdispl tlrsn panel(plrsn)" /* Panel anzeigen bis */
if rc > 4 then leave /* PF3 gedrückt? */
do while rc < 8
if c = 'D' then do
call del_row /* Zeilen löschen */
end
else if c <> ' ' then do
zmsg000s = "Command unknown"
zmsg000l = "Command unknown, only Delete(D) allowed"
"setmsg msg(ispz000)" /* Meldung ausgeben */
leave
end
if ztdSels <= 1 then
leave
"tbdispl tlrsn" /* get next selection */
end
c = ''
if plrsn <> '' then do
eLrsn = left(pLrsn, 12, 0)
call show timeLrsn2LZT(eLrsn), eLrsn
pLrsn = ''
end
if ptimest <> '' then do
rTimeSt = checkTst(pTimeSt)
if rTimeSt \== '' then
call show rTimeSt, timeLZT2Lrsn(rTimeSt)
pTimeSt = ''
end
if pUniq <> '' then do
lrsn = timeUniq2Lrsn(pUniq)
call show timeLrsn2LZT(lrsn), lrsn, pUniq
pUniq = ''
end
end
if sdata='Y' then
"tbclose tlrsn "
else
"tbend tlrsn"
exit
show:
parse arg cTs, cLrsn, cUniq
ctsutc = timeLrsn2Gmt(cLrsn)
gmtTime = substr(ctsutc, 12, 8)
if cUniq == '' then
cUniq = timeLrsn2uniq(cLrsn)
julian = time2jul(cts)
"tbadd tlrsn"
return 0
endSubroutine show
/* expand timestamp and validate it ***********************************/
checkTst: procedure
parse arg pTimeSt
/* ptimest = Timestamp format yyyy-mm-dd-hh.mm.ss.ffffff */
rTimeSt =overlay(ptimest, '1972-01-01-00.00.00.000000')
call timestampParse rTimest
/* check if values in range */
if (\ datatype(yyyy, 'n') | yyyy<1972) | (yyyy>2141) then do
zmsg000s = ""
zmsg000l = "year range: 1972-2041"
address ispExec " setmsg msg(ispz000)" /* Meldung ausgeben */
return ''
end
if (\ datatype(mo, 'n') | mo<1) | (mo>12) then do
zmsg000s = ""
zmsg000l = "month range 1-12"
address ispExec "setmsg msg(ispz000)" /* Meldung ausgeben */
return ''
end
if (dd<1) | (dd>31) then do
zmsg000s = ""
zmsg000l = "day range 1-31"
address ispexec "setmsg msg(ispz000)" /* Meldung ausgeben */
return ''
end
return rTimest
endProckedure checkTst
/* delete current row ***********************************************/
del_row:
address ispexec
rowid_nr=0
"tbget tdbnr rowid(rowid_nr)" /* Curor-Position lesen */
"tbskip tdbnr row("rowid_nr")" /* Cursor auf Row setzen */
"tbdelete tlrsn" /* Zeile löschen */
c = ''
return
/* copy time begin ****************************************************
11.12.14 wk: added lrsn2uniq
11.05.13 wk: numeric digits transparent: in jeder Procedure drin
time2jul, tst externalisiert
**********************************************************************/
/*--- read timeZoneOffset and leapSeconds registers
and set variables for uniq ----------------------------------*/
timeReadCvt: procedure expose m.
parse arg debug
numeric digits 15
/* offsets documented in z/OS Data Areas Vol.1 */
cvtOH = '00000010' /* cvt control block Address */
cvtext2O = x2d('00000560') /* offset to extension 2 */
cvtldtoO = x2d('00000038') /* offset to timezone */
cvtlsoO = x2d('00000050') /* offset to leapSeconds */
/* CVT CB address + extention2 */
cvtExt2A = C2D(STORAGE(cvtOH,4)) + cvtext2O
/* cvtLdto timeZone address +offset */
m.time_Zone = c2d(STORAGE(d2x(cvtext2A+cvtldtoO, 8), 8))
m.time_StckUnit = 1e-6 / 256 / 16
/* cvtLso LeapSecs address +offset */
m.time_Leap = c2d(STORAGE(d2x(cvtext2A+cvtlsoO, 8), 8))
m.time_UQDigits = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ012345678'
/* find lrsn of day 0 */
m.time_UQZero = x2d(timeGmt2Lrsn('2004-12-31-00.00.22.000000')) ,
% 64 * 64 /* 0 out last 6 bits */
if debug == 1 then do
say 'stckUnit =' m.time_StckUnit
say 'timeLeap =' d2x(m.time_Leap,16) '=' m.time_Leap ,
'=' format(m.time_Leap * m.time_StckUnit,9,3) 'secs'
say 'timeZone =' d2x(m.time_Zone,16) '=' m.time_Zone,
'=' format(m.time_Zone * m.time_StckUnit,6,3) 'secs'
say "cvtext2_adr =" d2x(cvtExt2A, 8)
say 'timeUQZero =' m.time_UQZero
say 'timeUQDigis =' ,
length(m.time_UQDigits) 'digits' m.time_UQDigits
end
m.time_ReadCvt = 1
return
endSubroutine timeReadCvt
timestampParse:
parse arg yyyy'-'mo'-'dd'-'hh'.'mm'.'ss'.'ffffff
return
/*--- GMT timestamp yyyy-mm.... -> stck value char(8)
BLSUXTID is described in z/OS V1R7.0 MVS IPCS Customization
BLSUXTID format : mo/dd/yyyy hh:mm:ss.ffffff ---------------*/
timeGmt2Stck: procedure expose m.
parse arg tst
call timestampParse tst
tDate = mo'/'dd'/'yyyy' 'hh':'mm':'ss'.'ffffff
ACC=left('', 8, '00'x)
ADDRESS LINKPGM "BLSUXTID TDATE ACC"
RETURN acc
endProcedure timeGmt2Stck
/*--- GMT timestamp yyyy-mm.... -> stck value in hex(16) ------------*/
timeGmt2LRSN: procedure expose m.
return c2x(left(timeGmt2Stck(arg(1)), 6))
endProcedure timeGmt2LRSN
/*--- LZT (Locale Zurich Tst -> stck value in hex(16) ---------------*/
timeLZT2LRSN: procedure expose m.
parse arg tst
numeric digits 23
if m.time_ReadCvt \== 1 then
call timeReadCvt
return left(d2x(c2d(timeGmt2Stck(tst)) ,
- m.time_Zone + m.time_Leap, 16), 12)
endProcedure timeLZT2LRSN
/*--- conversion from Stck Clock Value to GMT Timestamp
BLSUXTOD is described in z/OS V1R7.0 MVS IPCS Customization
input -> + leapseconds -> output ----------------------------*/
timeStck2Gmt: PROCEDURE expose m.
parse arg stck
stck = left(stck, 8, '00'x)
TDATE = COPIES('0' , 26)
ADDRESS LINKPGM "BLSUXTOD stck TDATE"
/* return format : mo/dd/yyyy hh:mm:ss.ffffff */
/* Timestamp format: yyyy-mm-dd-hh.mm.ss.ffffff */
parse var TDATE mo '/' dd '/' yyyy hh ':' mm ':' ss '.' ffffff
RETURN yyyy'-'mo'-'dd'-'hh'.'mm'.'ss'.'ffffff
endProcedure timeStck2Gmt
/*--- conversion from Lrsn Clock Value to GMT Timestamp -------------*/
timeLrsn2Gmt:
return timeStck2Gmt(x2c(arg(1)))
endProcedure timeLrsn2Gmt
/*--- conversion from Lrsn Clock Value to LZT Local Zurich Time -----*/
timeLrsn2LZT: procedure expose m.
parse arg lrsn
numeric digits 23
if m.time_ReadCvt \== 1 then
call timeReadCvt
return timeStck2Gmt(d2c(x2d(left(lrsn, 16, 0)) ,
+ m.time_Zone-m.time_Leap))
endProcedure timeLrsn2LZT
/*--- timestamp to julian --------------------------------------------*/
time2jul: procedure expose m.
parse arg yyyy '-' mm '-' dd '-'
/* date function cannot convert to julian, only from julian
==> guess a julian <= the correct and
try the next values
*/
j = trunc((mm-1) * 29.5) + dd
yy = right(yyyy, 2)
do j=j by 1
j = right(j, 3, 0)
d = date('s', yy || j, 'j')
if substr(d, 3) = yy || mm || dd then
return yy || j
end
return
endProcedure time2jul
/* convert a lrsn to the uniq variable ********************************/
timeLrsn2uniq: procedure expose uniqZero uniqDigits debug
parse arg lrsn
/* unique are bits 0:41 of the TodClock value
minus 31.12.2004 represented
by base 35 by 'ABC...YZ01..8'
*/
if m.time_ReadCvt \== 1 then
call timeReadCvt
lrsn = left(lrsn, 12, 0)
numeric digits 15
diff = x2d(lrsn) - m.time_UQZero
if diff < 0 then
return'< 2005'
return right(i2q(diff % 64, m.time_UQDigits), 8, 'A')
endProcedure timeLrsn2Uniq
/* convert a uniq variable to lrsn ************************************/
timeUniq2lrsn: procedure expose m.
parse arg uniq
if m.time_ReadCvt \== 1 then
call timeReadCvt
numeric digits 15
u1 = q2i(left(uniq, 8, 'A'), m.time_UQDigits) * 64
lrsn = right(d2x(u1 + m.time_UQZero), 12, 0)
return lrsn
endProcedure uniq2lrsn
/*--- translate a number in q-system to decimal
arg digits givs the digits corresponding to 012.. in the q sysem
q = length(digits) --------------------------------------------*/
q2i: procedure expose m.
parse arg v, digits
b = length(digits)
i = 0
do x = 1 to length(v)
q = substr(v, x, 1)
r = pos(q, digits)
if r < 1 then
call err 'bad digit' q 'in' v 'valid digits' digits
i = i * b + r - 1
end
return i
endProcedure q2i
/*--- translate a decimal number to q-system - inverse of q2i --------*/
i2q: procedure expose m.
parse arg i, digits
if i = 0 then
return left(digits, 1)
b = length(digits)
v = ''
do while i > 0
v = substr(digits, 1 + (i // b), 1) || v
i = i % b
end
return v
endProcedure i2q
/* copy time end -----------------------------------------------------*/