|
Do you have source some source that you want to share? Is there some source that you want to see posted here? If so, Contact Us and we'll be more than happy to help. |
* ====================================================================== *
* *
* Date & Time Procedures and Functions *
* *
* Dependant Objects: *
* ------------------ *
* *
* OFSTMSTMP - *DTAARA - Offset For Systemclock In Seconds *
* *
* CRTDTAARA DTAARA(RADDATZ/OFSTMSTMP) *
* TYPE(*DEC) *
* LEN(12) *
* VALUE(0) *
* TEXT('Offset For Systemclock') *
* *
* ====================================================================== *
* 1999, Thomas Raddatz *
* ====================================================================== *
H NOMAIN
H DATFMT(*ISO) TIMFMT(*ISO)
*
* Global Reference Fields
D r_bool S 1A based(ptrDummy)
*** r_bool S N based(ptrDummy)
*
* Data Areas
D g_ofsTmStmp S 12S 0 dtaara(OFSTMSTMP)
*
* Global Constants
D bTrue C const(*ON )
D bFalse C const(*OFF)
*
*//BEGIN COPY
* ====================================================================== *
* Prototypes, Usually placed into a COPY-Book
* ====================================================================== *
* Get Current System Time
D f_getSysTime PR T
*
* Get Current System Date
D f_getSysDate PR D
*
* Get Current System Timestamp
D f_getSysTmStmp PR Z
*
* Set System Date And Time
D f_setSysClock PR like(r_bool)
D i_date D const
D options(*OMIT)
D i_time T const
D options(*OMIT: *NOPASS)
*
* Reset Offset Of System Clock
D f_resetTmOfs PR like(r_bool)
*
* Test For Omitted Argument
D p_testOmtArg PR extproc('CEETSTA')
D presence_flag 10I 0
D arg_num 10I 0 const
D fc 12A options(*OMIT)
*//END COPY
*
* ====================================================================== *
* Procedures & Functions
* ====================================================================== *
*
* ---------------------------------------------------------------------- *
* Get Current System Time
* ---------------------------------------------------------------------- *
P f_getSysTime B export
*
D f_getSysTime PI T
*
* Work Fields
D tmStmp S Z inz
D time S T inz
* -------------------------------------------------------------
*
C Eval tmStmp = f_getSysTmStmp
C Move tmStmp time
*
C Return time
*
P f_getSysTime E
*
* ---------------------------------------------------------------------- *
* Get Current System Date
* ---------------------------------------------------------------------- *
P f_getSysDate B export
*
D f_getSysDate PI D
*
* Work Fields
D tmStmp S Z inz
D date S D inz
* -------------------------------------------------------------
*
C Eval tmStmp = f_getSysTmStmp
C Move tmStmp date
*
C Return date
*
P f_getSysDate E
*
* ---------------------------------------------------------------------- *
* Get Current System Timestamp
* ---------------------------------------------------------------------- *
P f_getSysTmStmp B export
*
D f_getSysTmStmp PI Z
*
* Work Fields
D tmStmp S Z inz
* -------------------------------------------------------------
*
C Time tmStmp
*
* Get offset of system clock
C In (E) g_ofsTmStmp
C If not %error B01
C AddDur g_ofsTmStmp:*stmStmp
C Endif E01
*
C Return tmStmp
*
P f_getSysTmStmp E
*
* ---------------------------------------------------------------------- *
* Set System Clock (Date & Time)
* ---------------------------------------------------------------------- *
P f_setSysClock B export
*
D f_setSysClock PI like(r_bool)
D i_date D const
D options(*OMIT)
D i_time T const
D options(*OMIT: *NOPASS)
*
* Return Code
D isOK S like(r_bool)
D inz(bFalse)
*
* Parameter Positions
D parm_date C const(1)
D parm_time C const(2)
*
* Work Fields
D isPresent S 10I 0 inz
D date S D inz
D time S T inz
D v_tmStmp S Z inz
D r_tmStmp S Z inz
D ofsTmStmp S 30S 0 inz
* -------------------------------------------------------------
*
* i_date passed to the function? ...
C If %parms >= parm_date B01
* ... passed but omitted?
C Callp p_testOmtArg(isPresent: parm_date: *)
* If the parameter is present ...
C If isPresent = 1 B02
* ... then
* use the date passed to the function
C Eval date = i_date
C Else X02
* ... else
* assume that the time is to be changed only.
* Use the current virtual date.
C Eval date = f_getSysDate
C Endif E02
C Else X01
* ... not passed
* assume that the time is to be changed only.
* Use the current virtual date.
C Eval date = f_getSysDate
C Endif E01
*
* i_time passed to the function? ...
C If %parms >= parm_time B01
* ... passed but omitted?
C Callp p_testOmtArg(isPresent: parm_time: *)
* If the parameter is present ...
C If isPresent = 1 B02
* ... then
* use the time passed to the function
C Eval time = i_time
C Else X02
* ... else
* assume that the date is to be changed only.
* Use the current virtual time.
C Eval time = f_getSysTime
C Endif E02
C Else X01
* ... not passed
* assume that the date is to be changed only.
* Use the current virtual time.
C Eval time = f_getSysTime
C Endif E01
*
* Compute virtual timestamp
C Move date v_tmStmp
C Move time v_tmStmp
*
* Get real timestamp from system clock
C Time r_tmStmp
*
* Compute difference between real-timestamp and virtual-timestamp
* (Result in seconds)
C v_tmStmp SubDur r_tmStmp ofsTmStmp:*s
*
* Write result to data area
* If the new offset is smaller/equal than the max. offset that can
* be hold by the data area, ...
C If ofsTmStmp <= (10 ** %len(g_ofsTmStmp)) - 1 B01
* ... then
* put the new offset into the data area
C *lock In (E) g_ofsTmStmp
*
* If the data area could be locked ...
C If not %error B02
* ... then
* put the new offset into the data area
C Eval g_ofsTmStmp = ofsTmStmp
C Out g_ofsTmStmp
* and everything is fine
C Eval isOK = bTrue
C Else X02
* ... else
* return an error condition
C Eval isOK = bFalse
C Endif E02
C Else X01
* ... else
* return an error condition
C Eval isOK = bFalse
C Endif E01
*
C Return isOK
*
P f_setSysClock E
*
* ---------------------------------------------------------------------- *
* Reset Offset Of System Clock
* ---------------------------------------------------------------------- *
P f_resetTmOfs B export
*
D f_resetTmOfs PI like(r_bool)
*
* Return Code
D isOK S like(r_bool)
D inz(bFalse)
*
* Work Fields
* -------------------------------------------------------------
*
* Reset offset stored in data area OFSTMSTMP
C *lock In (E) g_ofsTmStmp
*
* If the data area could be locked ...
C If not %error B01
* ... then
* set the offset to *ZERO
C Eval g_ofsTmStmp = 0
C Out g_ofsTmStmp
* and everything is fine
C Eval isOK = bTrue
C Else X01
* ... else
* return an error condition
C Eval isOK = bFalse
C Endif E01
*
C Return isOK
*
P f_resetTmOfs E
*
|