/* REXX - Display a DBRM TimeStamp in a real date time format.     */
/*      - format is TSO DBRMTS DSN(MEMBER)  (no quotes)            */
/*      - or TSO DBRMTS CONTOKEN=xxxxxxxxxxxxxxxx [MODE=SQLJ]      */
/*           xx...xx is the 16 hex digits of the contoken.         */
/*                                                                 */
/* Brian Kavanagh 92/09/10                                         */
/* Terry Doner    94/04/22                                         */
/* Axel Zuber     04/03/25 fixed the microseconds todo             */
/* Peter Wirfs    06/07/08 amendment                               */
/* Gernot Ruban   08/11/27 amendment for V81 and V91               */
/* Axel Zuber     09/10/06 added contokens generated by SQLJ/IBM   */

parse upper arg inparm

if substr(inparm,1,9) = 'CONTOKEN='  /* added for batch testing */
then do
   parse var inparm . 'CONTOKEN='contoken 'MODE='mode

   contoken = strip(contoken)
   mode     = strip(mode)

   if mode ^= ' ' & mode ^= 'SQLJ'
   then do
      say "unsupported mode" mode
      exit
   end

   /*
   contoken = substr(inparm,10,16)    /* DISPLAY HEX       */
   */
   tod   = TimeStamp(contoken, mode)
   say 'Contoken' contoken '=>'tod

   zedlmsg = 'Contoken' contoken '=>'tod
   zedsmsg = '=>'tod
   address ISPEXEC 'SETMSG MSG(ISRZ000)'
   if rc = 0,
   then return 0
   else return tod /* only valid for return to other rexx */
                   /* in a non iSPF environment */

   return 0
end

/* assume we have dataset input */
dsn=inparm

if DSN = ""
then do
   SAY "Format of exec is...TS PDSName(MemberName)"
   exit
end

IndexPos = Index(DSN,"(")
If IndexPos = 0
then do
   say "Dataset specified must include member."
   exit
end


/* strip quotes if they exist */

if left(DSN,1) = "'" then DSN = Substr(DSN,2)

IndexPos = Index(DSN,"'")

If IndexPos > 0
then do
   DSNLength = IndexPos - 1
   DSN = left(DSN,DSNLength)
end

status = sysdsn("'"dsn"'")
if status ^= "OK"
then do
   say "Problem with PDS Name Supplied..." status
   exit
end

IndexPos  = Index(DSN,"(")
IndexPos  = IndexPos + 1
Member    = Substr(DSN,IndexPos)
IndexPos  = Index(Member,")")
MemLength = IndexPos - 1
Member    = left(Member,MemLength)

"alloc file(sysin) dataset('"dsn"') shr reuse"
"execio 2 diskr sysin (stem dbrm. finis"

if rc ^= 0,
then do
  say "Problem reading member. Could it be empty? RC="RC
  exit
end

"free file(sysin)"

if left(DBRM.1,4) ^= "DBRM"
then do
  say "PDS Member is not a DBRM"
  exit
end

contoken = c2x(substr(dbrm.1,25,8))
/* quick hack. find a better criterion */
/* than the 'userid equal to blanks'   */
mode     = ''
if substr(dbrm.1,9,8) = "" then mode = 'SQLJ'

tod = TimeStamp(contoken, mode)

zedsmsg = tod
zedlmsg = Member !! ": '"contoken"'X ==>" tod

address ISPEXEC 'SETMSG MSG(ISRZ000)'

if rc ^= 0 then say smsg /* ISPF failure, try REXX say instead */

DBRMMRIC = substr(DBRM.1,80,1)
db2ver='Pre V1.3'
/* DBRMMRIC translation taken from ISC response 12E25,093,649 */
if DBRMMRIC = 'B' then db2ver='V1.3'
if DBRMMRIC = 'C' then db2ver='V2.1'
if DBRMMRIC = 'D' then db2ver='V2.2'
if DBRMMRIC = 'E' then db2ver='V2.3'
if DBRMMRIC = 'F' then db2ver='V3.1'
if DBRMMRIC = 'G' then db2ver='V4.1'
if DBRMMRIC = 'H' then db2ver='V5.1'
if DBRMMRIC = 'I' then db2ver='V6.1'
if DBRMMRIC = 'J' then db2ver='V7.1'
if DBRMMRIC = 'K' then db2ver='V7.2'
if DBRMMRIC = 'L' then db2ver='V8.1'
if DBRMMRIC = 'M' then db2ver='V9.1'

say 'DBRM name      :' substr(DBRM.1,17, 8)
say 'Pre-Compiled by:' substr(DBRM.1, 9, 8)
say "Contoken       :'"contoken"'X"
say "Timestamp      :" tod
if DBRMMRIC >'D' then ,
say 'Version Id     :' substr(DBRM.2, 3,64)
say "DB2 Version    :" db2ver

return 0

/*******************************************/

TimeStamp: procedure; arg ts, mode

select
when ts = '0E5F2F3F00404040' ! ts = '0E5F2F3F01404040'
then do
   tod = '0001-01-01-00.00.00.00'
end
when left(ts,1) = "0"
then do
   /* amendment by Peter Wirfs, 2006-08-7 */
   parse var ts 2 byte1to4half +7,
           10 byte4halfto7
   tod = x2c(byte1to4half!!byte4halfto7)
end
when mode = 'SQLJ'
then do
   tod = #sqljtod(ts)
end
otherwise do
   numeric digits 30
   w1 = left(ts,8)
   w2 = right(ts,8)
   w2 = sll(w2,3)
   tod = #tod(sldl(w1!!w2,3)) "(UTC/GMT)"
end
end /* select */

return tod

sll: Procedure; arg w,x
return B2X(right(X2B(w)!!copies('0',x),32))

sldl: Procedure; arg dw,x
return B2X(right(X2B(dw)!!copies('0',x),64))

srd: Procedure; arg dw,x
return B2X(left(copies('0',x)!!X2B(dw),64))

/*******************************************/

#tod: procedure; arg tod

numeric digits 20

msecs   = X2D(srd(tod,12))

secs     = msecs % 1000000
msecs    = msecs - 1000000 * secs
days     = secs % 86400
secs     = secs - 86400  * days
hours    = secs % 3600
secs     = secs - 3600  * hours
minutes  = secs % 60
secs     = secs - 60   * minutes

xhours   = right('00'hours,2)
xminutes = right('00'minutes,2)
xsecs    = right('00'secs,2)
xms      = right('000000'msecs,6)
xtime    = xhours'.'xminutes'.'xsecs'.'xms

xdate    = jd2cal(cal2jd(1900 01 01)+days)

parse var xdate years month days

xdate = right('0000'years,4) !!'-'!!,
        right('00'month,2)   !!'-'!!,
        right('00'days,2)

return xdate!!"-"!!xtime

/*******************************************/

#sqljtod: procedure; arg token

/* trace '?I' */

xmap   = "4142434445464748494A4B4C4D4E4F50",
       !!"5152535455565758595A616263646566",
       !!"6768696A6B6C6D6E6F70717273747576",
       !!"7778797A313233343536373839304023",
       !!"245F2020202020202020202020202020",
       !!"20202020202020202020202020202020",
       !!"20202020202020202020202020202020",
       !!"20202020202020202020202020202020",
       !!"20202020202020202020202020202020",
       !!"20202020202020202020202020202020",
       !!"25202B20202020202020202020202020",
       !!"202020202020"

dayofweek.0 = 'Sun'
dayofweek.1 = 'Mon'
dayofweek.2 = 'Tue'
dayofweek.3 = 'Wed'
dayofweek.4 = 'Thu'
dayofweek.5 = 'Fri'
dayofweek.6 = 'Sat'

map    = x2c(xmap)
abyte0 = x2c(token)

nanolo   = pos(substr(abyte0, 1, 1), map)-1
nanohi   = pos(substr(abyte0, 2, 1), map)-1
secs     = pos(substr(abyte0, 3, 1), map)-1
minutes  = pos(substr(abyte0, 4, 1), map)-1
hours    = pos(substr(abyte0, 5, 1), map)-1
day      = pos(substr(abyte0, 6, 1), map)-1
month    = pos(substr(abyte0, 7, 1), map)
year     = pos(substr(abyte0, 8, 1), map)

/* this may be a bug in IBM's token generation code. */
/* they use getDay(ofWeek) instead of getDayofMonth. */
if 0<=day & day<7
then day = dayofweek.day
else day = '???'

msecs    = 62 * nanohi + nanolo
year     = year + 1961  /* adjust after 2024 ;-) */

xhours   = right('00'hours,2)
xminutes = right('00'minutes,2)
xsecs    = right('00'secs,2)
xms      = right('000'msecs,3)
xtime    = xhours'.'xminutes'.'xsecs'.'xms

xdate    = right('0000'year,4)'-'right('00'month,2)'-'day

/* trace 'off' */

return xdate!!"-"!!xtime

/*******************************************/

jd2cal: procedure; arg jd julian_calendar

a=trunc((jd/36524.25)-51.12264)
b=jd+1+a-a%4+1524
c=trunc((b/365.25)-0.3343)
d=trunc(365.25*c)
e=(b-d)%30.61
d=b-d-trunc(30.61*e)
m=e-1
y=c-4716

if e>13.5 then m=m-12
if m<2.5 then y=y+1

return right("0000"y,4) right("00"m,2) right("00"d,2)

/*******************************************/

cal2jd: procedure; arg yyyy mm dd

jd=367*yyyy+275*mm%9-((mm+9)%12+yyyy)*7%4+dd+1721029,
  -((yyyy+(mm-9)%7)%100+1)*3%4

return jd