View Issue Details

IDProjectCategoryView StatusLast Update
0030394FPCRTLpublic2021-05-03 18:26
ReporterDenis Kozlov Assigned ToMichael Van Canneyt  
PrioritynormalSeverityminorReproducibilityN/A
Status resolvedResolutionfixed 
Product Version3.1.1 
Summary0030394: [patch] UTC time in FPC
DescriptionThis patch adds a UniversalTime function which returns current TDateTime in UTC.

Currently, it's possible to use LocalTimeToUniversal(Now), but it is inefficient and suffers from a race condition.

Implementation of UniversalTime is based on LazUTF8SysUtils.NowUTC, but is significantly simplified and has an improved fallback implementation.
Additional InformationAs discussed in the mailing list:
http://lists.freepascal.org/fpc-devel/2016-July/037226.html

The name UniversalTime seems better than NowUTC, and it fits nicely in DateUtils unit, but feel free to change it as you see fit.
Tagspatch
Fixed in Revision
FPCOldBugId
FPCTarget-
Attached Files

Activities

Denis Kozlov

2016-07-21 08:27

reporter  

dateutil.inc.patch (1,623 bytes)   
Index: packages/rtl-objpas/src/inc/dateutil.inc
===================================================================
--- packages/rtl-objpas/src/inc/dateutil.inc	(revision 34165)
+++ packages/rtl-objpas/src/inc/dateutil.inc	(working copy)
@@ -430,8 +430,8 @@
 Function UniversalTimeToLocal(UT: TDateTime; TZOffset : Integer): TDateTime;
 Function LocalTimeToUniversal(LT: TDateTime): TDateTime;
 Function LocalTimeToUniversal(LT: TDateTime; TZOffset: Integer): TDateTime;
+Function UniversalTime: TDateTime;
 
-
 { ScanDateTime is a limited inverse of formatdatetime }
 function ScanDateTime(const Pattern:string;const s:string;const fmt:TFormatSettings;startpos:integer=1) : tdatetime; overload;
 function ScanDateTime(const Pattern:string;const s:string;startpos:integer=1) : tdatetime; overload;
@@ -438,7 +438,15 @@
 
 implementation
 
-uses sysconst;
+uses
+  {$ifdef WINDOWS}
+  Windows,
+  {$else}
+  {$ifdef UNIX}
+  Unix,
+  {$endif}
+  {$endif}
+  sysconst;
 
 const
   TDateTimeEpsilon = 2.2204460493e-16;
@@ -2583,7 +2591,32 @@
     Result := LT;
 end;
 
+function UniversalTime: TDateTime;
+{$ifdef WINDOWS}
+var
+  SystemTime: TSystemTime;
+begin
+  Windows.GetSystemTime(SystemTime);
+  Result := SystemTimeToDateTime(SystemTime);
+end;
 {$else}
+{$ifdef UNIX}
+var
+  tp: timeval;
+begin
+  fpgettimeofday(@tp,nil);
+  Result := UnixToDateTime(tp.tv_sec);
+  Result := IncMilliSecond(Result, tp.tv_usec div 1000);
+end;
+{$else}
+begin
+  // Beware, it suffers from a race condition!
+  Result := LocalTimeToUniversal(Now);
+end;
+{$endif}
+{$endif}
+
+{$else}
 implementation
 {$endif FPUNONE}
 end.
dateutil.inc.patch (1,623 bytes)   

Michael Van Canneyt

2016-07-30 10:08

administrator   ~0093903

Can you please change the implementation so it is included in sysutils ?

DateUtils is the wrong place for this, because that unit should remain OS independent.

Denis Kozlov

2016-08-03 12:19

reporter  

sysutils.patch (5,102 bytes)   
Index: rtl/objpas/sysutils/dati.inc
===================================================================
--- rtl/objpas/sysutils/dati.inc	(revision 34245)
+++ rtl/objpas/sysutils/dati.inc	(working copy)
@@ -271,6 +271,36 @@
   result := systemTimeToDateTime(SystemTime);
 end;
 
+{   UniversalTime returns the current Universal (UTC) Date and Time   }
+
+// 'datutil.inc' contains routines required by UniversalTime
+{$i datutil.inc}
+
+function UniversalTime: TDateTime;
+{$ifdef WINDOWS}
+var
+  SystemTime: TSystemTime;
+begin
+  Windows.GetSystemTime(SystemTime);
+  Result := SystemTimeToDateTime(SystemTime);
+end;
+{$else}
+{$ifdef UNIX}
+var
+  tp: timeval;
+begin
+  fpgettimeofday(@tp, nil);
+  Result := UnixToDateTime(tp.tv_sec);
+  Result := IncMilliSecond(Result, tp.tv_usec div 1000);
+end;
+{$else}
+begin
+  // Beware, it suffers from a race condition!
+  Result := LocalTimeToUniversal(Now);
+end;
+{$endif}
+{$endif}
+
 {   IncMonth increments DateTime with NumberOfMonths months,
     NumberOfMonths can be less than zero   }
 
Index: rtl/objpas/sysutils/datih.inc
===================================================================
--- rtl/objpas/sysutils/datih.inc	(revision 34245)
+++ rtl/objpas/sysutils/datih.inc	(working copy)
@@ -126,6 +126,7 @@
 function Date: TDateTime;
 function Time: TDateTime;
 function Now: TDateTime;
+function UniversalTime: TDateTime;
 function IncMonth(const DateTime: TDateTime; NumberOfMonths: integer = 1 ): TDateTime;
 procedure IncAMonth(var Year, Month, Day: Word; NumberOfMonths: Integer = 1);
 function IsLeapYear(Year: Word): boolean;
Index: rtl/objpas/sysutils/datutil.inc
===================================================================
--- rtl/objpas/sysutils/datutil.inc	(revision 0)
+++ rtl/objpas/sysutils/datutil.inc	(working copy)
@@ -0,0 +1,95 @@
+//------------------------------------------------------------------------------
+// UniversalTime function requires additional routines found in DateUtils unit,
+// but DateUtils is not in RTL, so here are copies of required functions.
+//------------------------------------------------------------------------------
+
+const
+  // Copy of DateUtils.TDateTimeEpsilon
+  TDateTimeEpsilon = 2.2204460493e-16;
+
+// Copy of DateUtils.MaybeSkipTimeWarp
+Procedure MaybeSkipTimeWarp(OldDate: TDateTime; var NewDate: TDateTime);
+begin
+  if (OldDate>=0) and (NewDate<-TDateTimeEpsilon) then
+    NewDate:=int(NewDate-1.0+TDateTimeEpsilon)-frac(1.0+frac(NewDate))
+  else if (OldDate<=-1.0) and (NewDate>-1.0+TDateTimeEpsilon) then
+    NewDate:=int(NewDate+1.0-TDateTimeEpsilon)+frac(1.0-abs(frac(1.0+NewDate)));
+end;
+
+// Copy of DateUtils.IncNegativeTime
+function IncNegativeTime(AValue, Addend: TDateTime): TDateTime;
+  // Inlined to eliminate extra dependency on Math unit
+  function SameValue(const A, B: TDateTime; Epsilon: TDateTime): Boolean;
+  begin
+    if (A>B) then
+      Result:=((A-B)<=Epsilon)
+    else
+      Result:=((B-A)<=Epsilon);
+  end;
+var
+  newtime: tdatetime;
+begin
+  newtime:=-frac(Avalue)+frac(Addend);
+  { handle rounding errors }
+  if SameValue(newtime,int(newtime)+1,TDateTimeEpsilon) then
+    newtime:=int(newtime)+1
+  else if SameValue(newtime,int(newtime),TDateTimeEpsilon) then
+    newtime:=int(newtime);
+  { time underflow -> previous day }
+  if newtime<-TDateTimeEpsilon then
+    begin
+      newtime:=1.0+newtime;
+      avalue:=int(avalue)-1;
+    end
+  { time overflow -> next day }
+  else if newtime>=1.0-TDateTimeEpsilon then
+    begin
+      newtime:=newtime-1.0;
+      avalue:=int(avalue)+1;
+    end;
+  Result:=int(AValue)+int(Addend)-newtime;
+end;
+
+// Copy of DateUtils.IncSecond
+Function IncSecond(const AValue: TDateTime; const ANumberOfSeconds: Int64): TDateTime;
+begin
+  if AValue>=0 then
+    Result:=AValue+ANumberOfSeconds/SecsPerDay
+  else
+    Result:=IncNegativeTime(Avalue,ANumberOfSeconds/SecsPerDay);
+  MaybeSkipTimeWarp(AValue,Result);
+end;
+
+// Copy of DateUtils.IncMilliSecond
+Function IncMilliSecond(const AValue: TDateTime; const ANumberOfMilliSeconds: Int64): TDateTime;
+begin
+  if Avalue>=0 then
+    Result:=AValue+ANumberOfMilliSeconds/MSecsPerDay
+  else
+    Result:=IncNegativeTime(Avalue,ANumberOfMilliSeconds/MSecsPerDay);
+  MaybeSkipTimeWarp(AValue,Result);
+end;
+
+// Copy of DateUtils.UnixToDateTime
+Function UnixToDateTime(const AValue: Int64): TDateTime;
+begin
+  Result:=IncSecond(UnixEpoch, AValue);
+end;
+
+// Copy of DateUtils.LocalTimeToUniversal
+Function LocalTimeToUniversal(LT: TDateTime;TZOffset: Integer): TDateTime;
+begin
+  if (TZOffset > 0) then
+    Result := LT - EncodeTime(TZOffset div 60, TZOffset mod 60, 0, 0)
+  else if (TZOffset < 0) then
+    Result := LT + EncodeTime(Abs(TZOffset) div 60, Abs(TZOffset) mod 60, 0, 0)
+  else
+    Result := LT;
+end;
+
+// Copy of DateUtils.LocalTimeToUniversal
+Function LocalTimeToUniversal(LT: TDateTime): TDateTime;
+begin
+  Result:=LocalTimeToUniversal(LT,-GetLocalTimeOffset);
+end;
+
sysutils.patch (5,102 bytes)   

Denis Kozlov

2016-08-03 12:24

reporter   ~0093987

I have attached a new patch:
> sysutils.patch [^] (5,102 bytes) 2016-08-03 13:19

As suggested in the mailing list, I have moved UniversalTime function to SysUtils instead of DateUtils.

All necessary routines were copied over from DateUtils into a separate include file in RTL (rtl/objpas/sysutils/datutil.inc) to keep it contained.

I'm still not sure that it's the best way, so I'll leave it up to you.

Michael Van Canneyt

2021-05-03 18:26

administrator   ~0130742

This function has been added meanwhile by Ondrej Pokorny.

function NowUTC: TDateTime;

Extra functions for more fine-tuned handling were also added:
{ FPC Extra }
Procedure GetLocalTime(var SystemTime: TSystemTime);
function GetUniversalTime(var SystemTime: TSystemTime): Boolean;

procedure ReplaceTime(var dati:TDateTime; NewTime : TDateTime); inline;
procedure ReplaceDate(var DateTime: TDateTime; const NewDate: TDateTime); inline;

function GetLocalTimeOffset: Integer;
function GetLocalTimeOffset(const DateTime: TDateTime; const InputIsUTC: Boolean; out Offset: Integer): Boolean;
function GetLocalTimeOffset(const DateTime: TDateTime; const InputIsUTC: Boolean = False): Integer;

{ UTC <-> Local time }
Function UniversalTimeToLocal(UT: TDateTime): TDateTime;
Function UniversalTimeToLocal(UT: TDateTime; TZOffset : Integer): TDateTime;
Function LocalTimeToUniversal(LT: TDateTime): TDateTime;
Function LocalTimeToUniversal(LT: TDateTime; TZOffset: Integer): TDateTime;

Issue History

Date Modified Username Field Change
2016-07-21 08:27 Denis Kozlov New Issue
2016-07-21 08:27 Denis Kozlov File Added: dateutil.inc.patch
2016-07-22 07:58 Denis Kozlov Tag Attached: patch
2016-07-30 10:05 Michael Van Canneyt Assigned To => Michael Van Canneyt
2016-07-30 10:05 Michael Van Canneyt Status new => assigned
2016-07-30 10:08 Michael Van Canneyt Note Added: 0093903
2016-07-30 10:08 Michael Van Canneyt Status assigned => feedback
2016-08-03 12:19 Denis Kozlov File Added: sysutils.patch
2016-08-03 12:24 Denis Kozlov Note Added: 0093987
2016-08-03 12:24 Denis Kozlov Status feedback => assigned
2021-05-03 18:26 Michael Van Canneyt Status assigned => resolved
2021-05-03 18:26 Michael Van Canneyt Resolution open => fixed
2021-05-03 18:26 Michael Van Canneyt FPCTarget => -
2021-05-03 18:26 Michael Van Canneyt Note Added: 0130742