dbrm.rex

/* 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
 
/* mise en commentaire pour soumission en batch */
/* address ISPEXEC 'SETMSG MSG(ISRZ000)' */
 
/* if rc ^= 0 then say smsg */ /* ISPF failure, try REXX say instead */
 
DBRMMRIC = substr(DBRM.1,80,1)
/* DBRMMRIC translation taken from ISC response 12E25,093,649 */
select
   when DBRMMRIC = 'Q' then db2ver='V12'
   when DBRMMRIC = 'P' then db2ver='V11'
   when DBRMMRIC = 'O' then db2ver='V10'
   when DBRMMRIC = 'M' then db2ver='V9'
   when DBRMMRIC = 'L' then db2ver='V8'
   when DBRMMRIC = 'K' then db2ver='V7'
   when DBRMMRIC = 'J' then db2ver='V6'
   otherwise db2ver='Pre V6'
end
 
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
 
/* 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


//* USAGE : DBRM PDSNAME(MEMBER)
//REXEDIT   EXEC PGM=IKJEFT01,DYNAMNBR=20,REGION=0M,COND=(4,LT)
//SYSEXEC  DD DISP=SHR,DSN=SYSPRM.WSYNGUD.CNTL
//SYSTSPRT DD SYSOUT=*
//SYSPRINT DD SYSOUT=*
//SYSTSIN  DD  *
 DBRM Your_Dbrmlib(YourModule)
/*