which is included in the package\r
----------------------------------------------------------------------------- }\r
{\r
-this unit returns unix timestamp with seconds and microseconds (as float)\r
-works on windows/delphi, and on freepascal on unix.\r
+this unit has several functions for getting unix and monotonic time and UTC offset on both windows and linux/unix\r
+\r
+this unit aims to work on delphi 6 and later, both x86 and x64, on win95 and later\r
+delphi 5 may work (untested).\r
+as well as freepascal on linux x86 and x64 and freebsd x64 (tested), windows, and other unixes (untested)\r
+\r
+provided functions. all are available on both windows and linux/unix:\r
+- unix timestamp as a (double or extended) float or integer: unixtimefloat, unixtimeint\r
+- monotonic timestamp as float: monotimefloat, wintimefloat (both are equivalent)\r
+- _coarse versions of the floats, which can be faster, and precision in the milliseconds.\r
+- btime_gettime: a unified function like clock_gettime. less reliant on floats.\r
+- tzgetoffset returns the UTC offset (timezone) in seconds\r
+\r
+- on windows, it provides the legacy function gettimeofday (on unix, use the one provided by the OS units)\r
+\r
+other things in the interface are often more implementation specific, there for legacy reasons, and not guaranteed stable\r
+\r
+this unit should be 2038 safe:\r
+- seconds are handled as 64 bits\r
+- on 32 bits linux, it uses clock_gettime64 if available \r
+- for getting the UTC offset on unix, this unit does its own, 64 bits aware, parsing of the zoneinfo file \r
+- tested with clock set after 2038\r
}\r
\r
+\r
unit btime;\r
+{$ifdef fpc}\r
+ {$mode delphi}\r
+{$endif}\r
+\r
+{$include lcoreconfig.inc}\r
\r
interface\r
\r
+{$ifdef mswindows}\r
+uses\r
+ ltimevalstuff;\r
+{$endif}\r
+\r
+{$ifdef linux}\r
+uses\r
+ linux,syscall;\r
+{$endif}\r
+\r
+{$ifdef freebsd}\r
+uses\r
+ freebsd;\r
+{$endif}\r
+\r
+{$ifdef FPC_HAS_TYPE_EXTENDED}{$define has_extended}{$endif}\r
+{$ifndef fpc}{$ifdef cpu386}{$define has_extended}{$endif}{$endif}\r
+\r
type\r
+ {$ifdef has_extended}\r
float=extended;\r
+ {$else}\r
+ float=double;\r
+ {$endif}\r
+ tunixtimeint=int64;\r
+\r
+const\r
+ colorburst=39375000/11; {3579545.4545....}\r
+\r
+ {\r
+ CLOCK_MONOTONIC is the standard monotonic time offered by the OS, it may or may not include suspend time\r
+ CLOCK_BOOTTIME includes suspend time.\r
+ CLOCK_UPTIME excludes suspend time.\r
+ }\r
+\r
+ {$ifdef mswindows}\r
+ CLOCK_REALTIME=0;\r
+ CLOCK_MONOTONIC=1;\r
+ CLOCK_REALTIME_COARSE=2;\r
+ CLOCK_MONOTONIC_COARSE=3;\r
+ CLOCK_BOOTTIME=CLOCK_MONOTONIC; //GetTickCount\r
+ CLOCK_UPTIME=4; //QueryUnbiasedInterruptTime, fallback to QueryPerformanceCounter\r
+ CLOCK_UPTIME_FAST=CLOCK_UPTIME;\r
+ {$endif}\r
+\r
+ {$ifdef linux}\r
+ CLOCK_REALTIME=linux.CLOCK_REALTIME;\r
+ CLOCK_MONOTONIC=linux.CLOCK_MONOTONIC;\r
+ CLOCK_REALTIME_COARSE=linux.CLOCK_REALTIME_COARSE;\r
+ CLOCK_MONOTONIC_COARSE=linux.CLOCK_MONOTONIC_COARSE;\r
+ CLOCK_BOOTTIME=7; //linux.CLOCK_BOOTTIME - constant missing in freepascal\r
+ CLOCK_UPTIME=CLOCK_MONOTONIC;\r
+ CLOCK_UPTIME_FAST=CLOCK_MONOTONIC_COARSE;\r
+ {$endif}\r
+\r
+ {$ifdef freebsd}\r
+ CLOCK_REALTIME=freebsd.CLOCK_REALTIME;\r
+ CLOCK_MONOTONIC=freebsd.CLOCK_MONOTONIC;\r
+ CLOCK_REALTIME_COARSE=freebsd.CLOCK_REALTIME_FAST;\r
+ CLOCK_MONOTONIC_COARSE=freebsd.CLOCK_MONOTONIC_FAST;\r
+ CLOCK_BOOTTIME=CLOCK_MONOTONIC;\r
+ CLOCK_UPTIME=freebsd.CLOCK_UPTIME;\r
+ CLOCK_UPTIME_FAST=freebsd.CLOCK_UPTIME_FAST;\r
+ {$endif}\r
+\r
+ {$ifdef darwin}\r
+ CLOCK_REALTIME=0; //values taken from darwin libc time.h\r
+ CLOCK_MONOTONIC=6;\r
+ CLOCK_REALTIME_COARSE=CLOCK_REALTIME; //darwin lacks these or equivalents\r
+ CLOCK_MONOTONIC_COARSE=CLOCK_MONOTONIC;\r
+ CLOCK_BOOTTIME=CLOCK_MONOTONIC;\r
+ CLOCK_UPTIME_RAW=8;\r
+ CLOCK_UPTIME=CLOCK_UPTIME_RAW;\r
+ CLOCK_UPTIME_FAST=CLOCK_UPTIME_RAW;\r
+ {$endif}\r
+\r
+ CLOCK_REALTIME_FAST=CLOCK_REALTIME_COARSE;\r
+ CLOCK_MONOTONIC_FAST=CLOCK_MONOTONIC_COARSE;\r
+\r
\r
var\r
timezone:integer;\r
timezonestr:string;\r
- irctime,unixtime:integer;\r
+ irctime,unixtime:tunixtimeint;\r
tickcount:integer;\r
- settimebias:integer;\r
- qpcjump:float; {can be read out and reset for debug purpose}\r
- performancecountfreq:extended;\r
+ settimebias:tunixtimeint;\r
+ performancecountfreq:int64;\r
+ performancecountstep:float;\r
+\r
+ btimenowin8:boolean;\r
\r
function irctimefloat:float;\r
-function irctimeint:integer;\r
+function irctimeint:tunixtimeint;\r
\r
+//unix timestamp (UTC) float seconds\r
function unixtimefloat:float;\r
-function unixtimeint:integer;\r
+function unixtimeint:tunixtimeint;\r
+\r
+//monotonic float seconds\r
+function monotimefloat:float;\r
+\r
+//coarse float seconds - usually faster, but a resolution in the milliseconds\r
+function unixtimefloat_coarse:float;\r
+function monotimefloat_coarse:float;\r
\r
+//float versions of CLOCK_BOOTTIME and CLOCK_UPTIME\r
+function boottimefloat:float;\r
+function uptimefloat:float;\r
+\r
+//monotonic (alias, old function name)\r
function wintimefloat:float;\r
\r
-procedure settime(newtime:integer);\r
+//get localtime vs UTC offset in seconds\r
+function tzgetoffset:integer;\r
+\r
+procedure settime(newtime:tunixtimeint);\r
procedure gettimezone;\r
procedure timehandler;\r
procedure init;\r
\r
-function timestring(i:integer):string;\r
-function timestrshort(i:integer):string;\r
+function timestring(i:tunixtimeint):string; // Wednesday August 15 2012 -- 16:21:09 +02:00\r
+function timestrshort(i:tunixtimeint):string; // Wed Aug 15 16:21:09 2012\r
+function timestriso(i:tunixtimeint):string; // 2012-08-15 16:21:09\r
+function timestrisoutc(i:float):string; // 2012-08-15T14:21:09.255553Z\r
+\r
+procedure beginhightimerrate;\r
+procedure endhightimerrate;\r
+\r
+procedure tzinvalidate;\r
+\r
+{$ifdef unix}\r
+function tzgetoffsetforts(ts:tunixtimeint):integer;\r
+{$endif}\r
+\r
+{$ifdef mswindows}\r
+function unixtimefloat_systemtime:float;\r
+{$endif}\r
\r
function oletounixfloat(t:float):float;\r
-function oletounix(t:tdatetime):integer;\r
-function unixtoole(i:integer):tdatetime;\r
+function oletounix(t:tdatetime):tunixtimeint;\r
+function unixtoole(i:float):tdatetime;\r
\r
+{$ifdef mswindows}\r
+function mmtimefloat:float;\r
+function mmtimeint64:int64;\r
+function qpctimefloat:float;\r
+{$endif}\r
+\r
+{$ifdef mswindows}\r
+function gettimeofday(var tv:ttimeval):integer;\r
+{$endif}\r
+\r
+\r
+const\r
+ mmtime_driftavgsize=32;\r
+ mmtime_warmupnum=4;\r
+ mmtime_warmupcyclelength=15;\r
var\r
+ //this flag is to be set when btime has been running long enough to stabilise\r
+ warmup_finished:boolean;\r
+\r
timefloatbias:float;\r
+ ticks_freq:float=0;\r
+ ticks_freq2:float=0;\r
+ ticks_freq_known:boolean=false;\r
lastunixtimefloat:float=0;\r
+ lastsynctime:float=0;\r
+ lastsyncbias:float=0;\r
\r
-implementation\r
+ mmtime_last:integer=0;\r
+ mmtime_wrapadd:int64;\r
+ mmtime_lastsyncmm:float=0;\r
+ mmtime_lastsyncqpc:float=0;\r
+ mmtime_drift:float=1;\r
+ mmtime_lastresult:float;\r
+ mmtime_nextdriftcorrection:float;\r
+ mmtime_driftavg:array[0..mmtime_driftavgsize] of float;\r
+ mmtime_synchedqpc:boolean;\r
\r
-{$ifdef fpc}\r
- {$mode delphi}\r
-{$endif}\r
+ mmtime_prev_drift:float;\r
+ mmtime_prev_lastsyncmm:float;\r
+ mmtime_prev_lastsyncqpc:float;\r
+\r
+ gettime64_nosupport_cached:boolean;\r
+ coarse_nosupport_cached:boolean;\r
\r
+type\r
+ //i define my own "timespec" and "gettime" because that way, they can be 64 bits even if the real one is 32 bits, and avoid the wrong one being used.\r
+ //tbtimespec can't be changed because it is passed as-is to clock_gettime64\r
+ tbtimespec=packed record\r
+ tv_sec:int64;\r
+ tv_nsec:int64;\r
+ end;\r
+ pbtimespec=^tbtimespec;\r
+\r
+\r
+//on unix, btime_gettime is the "inner" function that calls the actual OS/library functions, and other functions in btime call it\r
+//on windows, btime_gettime is an "outer" function that calls the other functions. so if not called by the app, it does not add to exe size.\r
+function btime_gettime(clockid:integer;tp:pbtimespec):integer;\r
+\r
+implementation\r
uses\r
{$ifdef UNIX}\r
{$ifdef VER1_0}\r
linux,\r
{$else}\r
- baseunix,unix,unixutil,{needed for 2.0.2}\r
+ baseunix,unix,unixutil,sockets, {unixutil and sockets needed by unixstuff.inc on some compiler versions}\r
{$endif}\r
{$else}\r
- windows,\r
+ windows,unitsettc,mmsystem,\r
{$endif}\r
sysutils;\r
\r
result := t;\r
end;\r
\r
-function oletounix(t:tdatetime):integer;\r
+function oletounix(t:tdatetime):tunixtimeint;\r
begin\r
- result := trunc(oletounixfloat(t));\r
+ result := round(oletounixfloat(t));\r
end;\r
\r
-function unixtoole(i:integer):tdatetime;\r
+function unixtoole(i:float):tdatetime;\r
begin\r
result := ((i)/86400)+daysdifference;\r
end;\r
{$ifdef unix}\r
{-----------------------------------------*nix/freepascal code to read time }\r
\r
+{$ifdef linux}{$define have_clock_gettime}{$endif}\r
+{$ifdef freebsd}{$define have_clock_gettime}{$endif}\r
+\r
+{$ifdef linux}\r
+ {$ifdef cpu386}{$define use_syscall_gettime64}{$endif}\r
+ {$ifdef cpu32}{$define use_syscall_gettime64}{$endif}\r
+\r
+ {$ifdef use_syscall_gettime64}\r
+const\r
+ clock_gettime64=403;\r
+ {$endif}\r
+{$endif} //linux\r
+\r
+\r
+\r
+{$ifdef darwin} {mac OS X}\r
+ type\r
+ tmach_timebase_info = packed record\r
+ numer: cardinal;\r
+ denom: cardinal;\r
+ end;\r
+ pmach_timebase_info = ^tmach_timebase_info;\r
+\r
+ function mach_absolute_time: int64; cdecl; external;\r
+ function mach_timebase_info(info: pmach_timebase_info): integer; cdecl; external;\r
+\r
+ var\r
+ timebase_info: tmach_timebase_info;\r
+{$endif} //darwin\r
+\r
+\r
+function btime_gettime(clockid:integer;tp:pbtimespec):integer;\r
+var\r
+{$ifdef have_clock_gettime}\r
+ ts: ttimespec;\r
+{$endif}\r
+ tv: ttimeval;\r
+{$ifdef darwin}\r
+ nanos:int64;\r
+ nanosf:extended;\r
+{$endif}\r
+\r
+begin\r
+ result := -1; //error\r
+\r
+ {$ifdef darwin}\r
+ if (clockid = CLOCK_MONOTONIC) or (clockid = CLOCK_MONOTONIC_COARSE) then begin\r
+ if timebase_info.denom = 0 then begin\r
+ mach_timebase_info(@timebase_info);\r
+ end;\r
+ if (timebase_info.denom > 0) then begin\r
+ nanos := mach_absolute_time;\r
+ if (nanos > 0) then begin\r
+ result := 0; //indicate success\r
+ if (timebase_info.denom > 10) then begin\r
+ //on powerpc mac, numer and denom are large numbers such as 1000000000 and 33333335, and extended is available\r
+ nanosf := nanos;\r
+ nanosf := (nanosf * timebase_info.numer) / timebase_info.denom;\r
+ nanos := trunc(nanosf);\r
+ end else begin\r
+ //on intel mac, numer and denom are 1 and 1. on apple silicon they are typically 125 and 3, and extended is not available\r
+ nanos := nanos div timebase_info.denom;\r
+ nanos := nanos * timebase_info.numer;\r
+ end;\r
+ tp.tv_sec := nanos div 1000000000;\r
+ tp.tv_nsec := nanos mod 1000000000;\r
+ exit;\r
+ end;\r
+ end;\r
+ end;\r
+ {$endif} //darwin\r
+\r
+ if (coarse_nosupport_cached) then begin\r
+ if (clockid = CLOCK_REALTIME_COARSE) then clockid := CLOCK_REALTIME;\r
+ if (clockid = CLOCK_MONOTONIC_COARSE) then clockid := CLOCK_MONOTONIC;\r
+ end;\r
+\r
+ {$ifdef use_syscall_gettime64}\r
+ //don't do this for monotonic for performance reasons\r
+ //the clock_gettime call below has the potential to be handled by libc, and then it is faster\r
+ //also if it failed, don't call it again to avoid slowdown of doing two calls every time\r
+ if (not ((clockid = CLOCK_MONOTONIC) or (clockid = CLOCK_MONOTONIC_COARSE) or (clockid = CLOCK_BOOTTIME) or (clockid = CLOCK_UPTIME))) and (not gettime64_nosupport_cached) then begin\r
+ result := do_syscall(clock_gettime64,clockid,tsysparam(tp));\r
+\r
+ if ((clockid = CLOCK_REALTIME) or (clockid = CLOCK_REALTIME_COARSE)) and (result <> 0) then gettime64_nosupport_cached := true;\r
+\r
+ if (result = 0) then exit;\r
+ end;\r
+ {$endif}\r
+\r
+ {$ifdef have_clock_gettime}\r
+ result := clock_gettime(clockid, @ts);\r
+ if (result <> 0) then begin\r
+ //fallback\r
+ if (clockid = CLOCK_REALTIME_COARSE) then begin\r
+ coarse_nosupport_cached := true;\r
+ result := clock_gettime(CLOCK_REALTIME, @ts);\r
+ end else\r
+ if (clockid = CLOCK_MONOTONIC_COARSE) then begin\r
+ coarse_nosupport_cached := true;\r
+ result := clock_gettime(CLOCK_MONOTONIC, @ts);\r
+ end;\r
+ end;\r
+ if (result = 0) then begin\r
+ tp.tv_sec := ts.tv_sec;\r
+ tp.tv_nsec := ts.tv_nsec;\r
+\r
+ {$ifndef cpu64}\r
+ if (tp.tv_sec < -1) then inc(tp.tv_sec, $100000000);\r
+ {$endif}\r
+\r
+ exit;\r
+ end;\r
+ {$endif} //have_clock_gettime\r
+\r
+ result := gettimeofday(tv);\r
+ if (result = 0) then begin\r
+ tp.tv_sec := tv.tv_sec;\r
+ tp.tv_nsec := tv.tv_usec * 1000;\r
+\r
+ {$ifndef cpu64}\r
+ if (tp.tv_sec < -1) then inc(tp.tv_sec, $100000000);\r
+ {$endif}\r
+ end;\r
+end;\r
+\r
+\r
function unixtimefloat:float;\r
var\r
- tv:ttimeval;\r
+ ts:tbtimespec;\r
begin\r
- gettimeofday(tv);\r
- result := tv.tv_sec+(tv.tv_usec/1000000);\r
+ btime_gettime(CLOCK_REALTIME, @ts);\r
+ //doing the below as a division causes a bug in fpc 3.2.0 x64, where the result becomes single precision\r
+ result := ts.tv_sec + (ts.tv_nsec * 0.000000001);\r
end;\r
\r
-function wintimefloat:extended;\r
+\r
+function monotimefloat:float;\r
+var\r
+ ts:tbtimespec;\r
begin\r
- result := unixtimefloat;\r
+ btime_gettime(CLOCK_MONOTONIC, @ts);\r
+ result := ts.tv_sec + (ts.tv_nsec * 0.000000001);\r
end;\r
\r
-function unixtimeint:integer;\r
+\r
+function unixtimefloat_coarse:float;\r
var\r
- tv:ttimeval;\r
+ ts:tbtimespec;\r
begin\r
- gettimeofday(tv);\r
- result := tv.tv_sec;\r
+ btime_gettime(CLOCK_REALTIME_COARSE, @ts);\r
+ result := ts.tv_sec + (ts.tv_nsec * 0.000000001);\r
end;\r
\r
-{$else} {delphi 3}\r
+\r
+function monotimefloat_coarse:float;\r
+var\r
+ ts:tbtimespec;\r
+begin\r
+ btime_gettime(CLOCK_MONOTONIC_COARSE, @ts);\r
+ result := ts.tv_sec + (ts.tv_nsec * 0.000000001);\r
+end;\r
+\r
+\r
+function boottimefloat:float;\r
+var\r
+ ts:tbtimespec;\r
+begin\r
+ btime_gettime(CLOCK_BOOTTIME, @ts);\r
+ result := ts.tv_sec + (ts.tv_nsec * 0.000000001);\r
+end;\r
+\r
+\r
+function uptimefloat:float;\r
+var\r
+ ts:tbtimespec;\r
+begin\r
+ btime_gettime(CLOCK_UPTIME, @ts);\r
+ result := ts.tv_sec + (ts.tv_nsec * 0.000000001);\r
+end;\r
+\r
+\r
+function unixtimeint:tunixtimeint;\r
+var\r
+ ts:tbtimespec;\r
+begin\r
+ btime_gettime(CLOCK_REALTIME,@ts);\r
+ result := ts.tv_sec;\r
+end;\r
+\r
+{------------------------------ end of *nix/freepascal section}\r
+\r
+{$endif} //unix\r
+\r
+{$ifdef mswindows}\r
{------------------------------ windows/delphi code to read time}\r
\r
-{ free pascals tsystemtime is incomaptible with windows api calls\r
- so we declare it ourselves - plugwash\r
+\r
+procedure tzinvalidate;\r
+begin\r
+ gettimezone;\r
+end;\r
+\r
+\r
+var\r
+ GetTickCount64:function:int64; stdcall;\r
+ gettickcount64_inited:boolean;\r
+\r
+procedure init_gettickcount64;\r
+var\r
+ dllhandle:thandle;\r
+begin\r
+ gettickcount64_inited := true;\r
+ dllhandle := loadlibrary('kernel32.dll');\r
+ if (dllhandle <> 0) then begin\r
+ GetTickCount64 := getprocaddress(dllhandle,'GetTickCount64');\r
+ end;\r
+end;\r
+\r
+\r
+\r
+function mmtimeint64:int64;\r
+var\r
+ i:int64;\r
+begin\r
+ if not gettickcount64_inited then init_gettickcount64;\r
+ if assigned(GetTickCount64) then begin\r
+ result := GetTickCount64;\r
+ end else begin\r
+ i := gettickcount;\r
+ if i < mmtime_last then begin\r
+ mmtime_wrapadd := mmtime_wrapadd + $100000000;\r
+ end;\r
+ mmtime_last := i;\r
+ result := mmtime_wrapadd + i;\r
+ end;\r
+end;\r
+\r
+\r
+{\r
+time float: gettickcount\r
+resolution: 9x: ~55 ms NT: 1/64th of a second\r
+guarantees: continuous without any jumps\r
+frequency base: same as system clock.\r
+epoch: system boot\r
}\r
-{$ifdef fpc}\r
-type\r
- TSystemTime = record\r
- wYear: Word;\r
- wMonth: Word;\r
- wDayOfWeek: Word;\r
- wDay: Word;\r
- wHour: Word;\r
- wMinute: Word;\r
- wSecond: Word;\r
- wMilliseconds: Word;\r
- end;\r
- {$endif}\r
-function Date_utc: extended;\r
-var\r
- SystemTime: TSystemTime;\r
-begin\r
- {$ifdef fpc}\r
- GetsystemTime(@SystemTime);\r
- {$else}\r
- GetsystemTime(SystemTime);\r
- {$endif}\r
- with SystemTime do Result := EncodeDate(wYear, wMonth, wDay);\r
+function mmtimefloat:float;\r
+var\r
+ temp:float;\r
+begin\r
+ result := mmtimeint64 * 0.001;\r
+\r
+ if (ticks_freq <> 0) and ticks_freq_known then begin\r
+ {the value we get is rounded to 1 ms, but the ticks are not a multiple of 1 ms\r
+ this makes the value noisy. use the known ticks frequency to restore the original value}\r
+ temp := int((result / ticks_freq)+0.5) * ticks_freq;\r
+\r
+ {if the known ticks freq is wrong (can happen), disable the un-rounding behavior\r
+ this will be a bit less accurate but it prevents problems}\r
+ if abs(temp - result) > 0.002 then begin\r
+ ticks_freq := 0;\r
+ end else result := temp;\r
+ end;\r
end;\r
\r
-function Time_utc: extended;\r
var\r
- SystemTime: TSystemTime;\r
+ win_version_known:boolean;\r
+ win_isnt:boolean;\r
+ win_ver_major:integer;\r
+ win_ver_minor:integer;\r
+\r
+procedure init_win_version;\r
+var\r
+ o:tosversioninfo;\r
begin\r
- {$ifdef fpc}\r
- GetsystemTime(@SystemTime);\r
- {$else}\r
- GetsystemTime(SystemTime);\r
- {$endif}\r
- with SystemTime do\r
- Result := EncodeTime(wHour, wMinute, wSecond, wMilliSeconds);\r
+ if not win_version_known then begin\r
+ win_version_known := true;\r
+ fillchar(o,sizeof(o),0);\r
+ o.dwOSVersionInfoSize := sizeof(o);\r
+ getversionex(o);\r
+ win_isnt := o.dwPlatformId = VER_PLATFORM_WIN32_NT;\r
+ win_ver_major := o.dwMajorVersion;\r
+ win_ver_minor := o.dwMinorVersion;\r
+ end;\r
+end;\r
+\r
+procedure measure_ticks_freq;\r
+var\r
+ f,g:float;\r
+\r
+ adjust1,adjust2:cardinal;\r
+ adjustbool:longbool;\r
+ win8_or_later:boolean;\r
+begin\r
+ if (performancecountfreq = 0) then qpctimefloat;\r
+ ticks_freq_known := false;\r
+ settc;\r
+ f := mmtimefloat;\r
+ repeat g := mmtimefloat until g > f;\r
+ unsettc;\r
+ f := g - f;\r
+\r
+ init_win_version;\r
+\r
+ ticks_freq2 := f;\r
+ mmtime_synchedqpc := false;\r
+\r
+ if (win_isnt and (win_ver_major >= 5)) then begin\r
+ {windows 2000 and later: query tick rate from OS in 100 ns units\r
+ typical rates: XP: 156250 or 100144, windows 7: 156001}\r
+ if GetSystemTimeAdjustment(adjust1,adjust2,adjustbool) then begin\r
+ ticks_freq := adjust1 / 10000000.0;\r
+ ticks_freq_known := true;\r
+ mmtime_synchedqpc := false;\r
+\r
+ //windows 8/10/11, 10 MHz time source is invariant TSC. add 64 Hz check for safety.\r
+ //with manifest, windows 10/11 major.minor will be 10.0 \r
+ win8_or_later := ((win_ver_major = 6) and (win_ver_minor >= 2)) or (win_ver_major = 10);\r
+ if (win8_or_later and (performancecountfreq = 10000000) and (adjust1 = 156250)) then begin\r
+ mmtime_synchedqpc := true;\r
+ end;\r
+ end;\r
+ end;\r
+\r
+ {9x}\r
+ if (performancecountfreq = 1193182) and (f >= 0.050) and (f <= 0.060) then begin\r
+ ticks_freq_known := true;\r
+ ticks_freq := 65536 / (colorburst / 3);\r
+ mmtime_synchedqpc := true;\r
+ end;\r
+ ticks_freq_known := true;\r
+ if ticks_freq <> 0 then ticks_freq2 := ticks_freq;\r
+// writeln(formatfloat('0.000000',ticks_freq));\r
end;\r
\r
-function Now_utc: extended;\r
+{\r
+time float: QueryPerformanceCounter\r
+resolution: <1us\r
+guarantees: can have forward jumps depending on hardware. can have forward and backwards jitter on dual core.\r
+frequency base: on NT, not the system clock, drifts compared to it.\r
+epoch: system boot\r
+}\r
+function qpctimefloat:float;\r
+var\r
+ i64:int64;\r
begin\r
- Result := round(Date_utc) + Time_utc;\r
+ if performancecountfreq = 0 then begin\r
+ QueryPerformancefrequency(performancecountfreq);\r
+ performancecountstep := 1.0 / performancecountfreq;\r
+ end;\r
+ queryperformancecounter(i64);\r
+ result := i64 * performancecountstep;\r
end;\r
\r
+{\r
+time float: QPC locked to gettickcount\r
+resolution: <1us\r
+guarantees: continuous without any jumps\r
+frequency base: same as system clock.\r
+epoch: system boot\r
+}\r
+\r
+//function mmqpctimefloat:float;\r
+function monotimefloat:float;\r
const\r
- highdwordconst=4294967296.0;\r
+ maxretries=5;\r
+ margin=0.002;\r
+var\r
+{ jump:float;}\r
+ mm,f,qpc,newdrift:float;\r
+ qpcjumped:boolean;\r
+ a,b:integer;\r
+{ retrycount:integer;}\r
+begin\r
+ if not ticks_freq_known then measure_ticks_freq;\r
+{ retrycount := maxretries;}\r
+\r
+ qpc := qpctimefloat;\r
+ mm := mmtimefloat;\r
+ f := (qpc - mmtime_lastsyncqpc) * mmtime_drift + mmtime_lastsyncmm;\r
+ //writeln('XXXX ',formatfloat('0.000000',qpc-mm));\r
+ qpcjumped := ((f-mm) > ticks_freq2+margin) or ((f-mm) < -margin);\r
+// if qpcjumped then writeln('qpc jumped ',(f-mm));\r
+ if ((qpc > mmtime_nextdriftcorrection) and not mmtime_synchedqpc) or qpcjumped then begin\r
+\r
+ mmtime_nextdriftcorrection := qpc + 1;\r
+ repeat\r
+ mmtime_prev_drift := mmtime_drift;\r
+ mmtime_prev_lastsyncmm := mmtime_lastsyncmm;\r
+ mmtime_prev_lastsyncqpc := mmtime_lastsyncqpc;\r
+\r
+ mm := mmtimefloat;\r
+ { dec(retrycount);}\r
+ settc;\r
+ result := qpctimefloat;\r
+ f := mmtimefloat;\r
+ repeat\r
+ if f = mm then result := qpctimefloat;\r
+ f := mmtimefloat\r
+ until f > mm;\r
+ qpc := qpctimefloat;\r
+\r
+ unsettc;\r
+ if (qpc > result + 0.0001) then begin\r
+ continue;\r
+ end;\r
+ mm := f;\r
+\r
+ if (mmtime_lastsyncqpc <> 0) and not qpcjumped then begin\r
+ newdrift := (mm - mmtime_lastsyncmm) / (qpc - mmtime_lastsyncqpc);\r
+ mmtime_drift := newdrift;\r
+ { writeln('raw drift: ',formatfloat('0.00000000',mmtime_drift));}\r
+ move(mmtime_driftavg[0],mmtime_driftavg[1],sizeof(mmtime_driftavg[0])*high(mmtime_driftavg));\r
+ mmtime_driftavg[0] := mmtime_drift;\r
+\r
+{ write('averaging drift ',formatfloat('0.00000000',mmtime_drift),' -> ');}\r
+{ mmtime_drift := 0;}\r
+ b := 0;\r
+ for a := 0 to high(mmtime_driftavg) do begin\r
+ if mmtime_driftavg[a] <> 0 then inc(b);\r
+{ mmtime_drift := mmtime_drift + mmtime_driftavg[a];}\r
+ end;\r
+{ mmtime_drift := mmtime_drift / b;}\r
+ a := 5;\r
+ if (b = 1) then a := 5 else if (b = 2) then a := 15 else if (b = 3) then a := 30 else if (b = 4) then a := 60 else if (b = 5) then a := 120 else if (b >= 5) then a := 120;\r
+ mmtime_nextdriftcorrection := qpc + a;\r
+ if (b >= 2) then warmup_finished := true;\r
+{ writeln(formatfloat('0.00000000',mmtime_drift));}\r
+ if mmtime_synchedqpc then mmtime_drift := 1;\r
+ end;\r
\r
-function wintimefloat:extended;\r
+ mmtime_lastsyncqpc := qpc;\r
+ mmtime_lastsyncmm := mm;\r
+ { writeln(formatfloat('0.00000000',mmtime_drift));}\r
+ break;\r
+ until false;\r
+\r
+\r
+ qpc := qpctimefloat;\r
+\r
+ result := (qpc - mmtime_lastsyncqpc) * mmtime_drift + mmtime_lastsyncmm;\r
+\r
+ {f := (qpc - mmtime_prev_lastsyncqpc) * mmtime_prev_drift + mmtime_prev_lastsyncmm;\r
+ jump := result-f;\r
+ writeln('jump ',formatfloat('0.000000',jump),' drift ',formatfloat('0.00000000',mmtime_drift),' duration ',formatfloat('0.000',(mmtime_lastsyncqpc-mmtime_prev_lastsyncqpc)),' ',formatfloat('0.00000000',jump/(mmtime_lastsyncqpc-mmtime_prev_lastsyncqpc)));}\r
+\r
+ f := result;\r
+ end;\r
+\r
+ result := f;\r
+\r
+ if (result < mmtime_lastresult) then result := mmtime_lastresult;\r
+ mmtime_lastresult := result;\r
+end;\r
+\r
+\r
+function boottimefloat:float;\r
+begin\r
+ result := monotimefloat;\r
+end;\r
+\r
+var\r
+ QueryUnbiasedInterruptTime:function(var i:int64):longbool; stdcall;\r
+ unbiasedinterrupttime_inited:boolean;\r
+\r
+\r
+procedure initunbiasedinterrupttime;\r
var\r
- p:packed record\r
- lowpart:longint;\r
- highpart:longint\r
+ dllhandle:thandle;\r
+begin\r
+ unbiasedinterrupttime_inited := true;\r
+ dllhandle := loadlibrary('kernel32.dll');\r
+ if (dllhandle <> 0) then begin\r
+ QueryUnbiasedInterruptTime := getprocaddress(dllhandle,'QueryUnbiasedInterruptTime');\r
end;\r
- p2:tlargeinteger absolute p;\r
- e:extended;\r
+end;\r
+\r
+function unbiasedtime_100ns:int64;\r
begin\r
- if performancecountfreq = 0 then begin\r
- QueryPerformancefrequency(p2);\r
- e := p.lowpart;\r
- if e < 0 then e := e + highdwordconst;\r
- performancecountfreq := ((p.highpart*highdwordconst)+e);\r
+ result := -1;\r
+ if not unbiasedinterrupttime_inited then initunbiasedinterrupttime;\r
+ if assigned(@QueryUnbiasedInterruptTime) then begin\r
+ QueryUnbiasedInterruptTime(result);\r
end;\r
- queryperformancecounter(p2);\r
- e := p.lowpart;\r
- if e < 0 then e := e + highdwordconst;\r
- result := ((p.highpart*highdwordconst)+e)/performancecountfreq;\r
end;\r
\r
+function uptimefloat:float;\r
var\r
- classpriority,threadpriority:integer;\r
+ i:int64;\r
+begin\r
+ i := unbiasedtime_100ns;\r
+ if (i > 0) then begin\r
+ result := i * 0.0000001;\r
+ exit;\r
+ end;\r
+ result := qpctimefloat;\r
+end;\r
+\r
\r
-procedure settc;\r
+\r
+var\r
+ GetSystemTimePreciseAsFileTime:procedure(var v:tfiletime); stdcall;\r
+ win8inited:boolean;\r
+\r
+procedure initwin8;\r
var\r
- hprocess,hthread:integer;\r
+ dllhandle:thandle;\r
+\r
begin\r
- hProcess := GetCurrentProcess;\r
- hThread := GetCurrentThread;\r
+ win8inited := true;\r
+ dllhandle := loadlibrary('kernel32.dll');\r
+ if (dllhandle <> 0) then begin\r
+ GetSystemTimePreciseAsFileTime := getprocaddress(dllhandle,'GetSystemTimePreciseAsFileTime');\r
+ end;\r
+end;\r
\r
- ClassPriority := GetPriorityClass(hProcess);\r
- ThreadPriority := GetThreadPriority(hThread);\r
\r
- SetPriorityClass(hProcess, REALTIME_PRIORITY_CLASS);\r
- SetThreadPriority(hThread, THREAD_PRIORITY_TIME_CRITICAL);\r
+function win8time_as_unix_100ns:int64;\r
+var\r
+ ft:tfiletime;\r
+ i:int64 absolute ft;\r
+begin\r
+ result := -1;\r
+ if not win8inited then initwin8;\r
+ if assigned(@GetSystemTimePreciseAsFileTime) then begin\r
+ GetSystemTimePreciseAsFileTime(ft);\r
+ //change from windows 1601-01-01 to unix 1970-01-01.\r
+ dec(i, 116444736000000000);\r
+ result := i;\r
+ end;\r
end;\r
\r
-procedure unsettc;\r
+\r
+function unixtimefloat_systemtime:float;\r
var\r
- hprocess,hthread:integer;\r
+ ft:tfiletime;\r
+ i:int64 absolute ft;\r
+begin\r
+ //result := oletounixfloat(now_utc);\r
+\r
+ //this method gives exactly the same result with extended precision, but is less sensitive to float rounding in theory}\r
+ //result := oletounixfloat(int(date_utc+0.5))+time_utc*86400;\r
+\r
+ //new method that is much faster (22 vs 190 ns)\r
+ GetSystemTimeAsFileTime(ft);\r
+ dec(i, 116444736000000000);\r
+ result := i * 0.0000001;\r
+end;\r
+\r
+\r
+function unixtimefloat_coarse:float;\r
begin\r
- hProcess := GetCurrentProcess;\r
- hThread := GetCurrentThread;\r
+ //don't do the coarse method if worse than about 16 ms. on win9x it may be only a 55 ms resolution\r
+ //but i have also seen it is less (like 1 ms)\r
+ //don't call measure_ticks_freq on NT because it is expensive and unnecessary\r
+ init_win_version;\r
+ if not win_isnt then begin\r
+ if not ticks_freq_known then measure_ticks_freq;\r
+ end;\r
+ if win_isnt or (ticks_freq < 0.017) then begin\r
+ result := unixtimefloat_systemtime;\r
+ exit;\r
+ end;\r
\r
- SetPriorityClass(hProcess, ClassPriority);\r
- SetThreadPriority(hThread, ThreadPriority);\r
+ result := unixtimefloat;\r
+end;\r
+\r
+function monotimefloat_coarse:float;\r
+begin\r
+ init_win_version;\r
+ if not win_isnt then begin\r
+ if not ticks_freq_known then measure_ticks_freq;\r
+ end;\r
+ if win_isnt or (ticks_freq < 0.017) then begin\r
+ result := mmtimeint64 * 0.001;\r
+ exit;\r
+ end;\r
+ result := monotimefloat;\r
end;\r
\r
+\r
+//simulate gettimeofday on windows so one can always use gettimeofday if preferred\r
+function gettimeofday(var tv:ttimeval):integer;\r
+var\r
+ e:float;\r
+ i:int64;\r
+begin\r
+ result := -1;\r
+\r
+ if not btimenowin8 then begin\r
+ i := win8time_as_unix_100ns;\r
+ if (i > 0) then begin\r
+ tv.tv_sec := i div 10000000;\r
+ tv.tv_usec := (i mod 10000000) div 10;\r
+ result := 0;\r
+ exit;\r
+ end;\r
+ end;\r
+\r
+ e := unixtimefloat;\r
+ if (e > 0) then result := 0;\r
+ tv.tv_sec := trunc(e);\r
+ tv.tv_usec := trunc(frac(e)*1000000);\r
+end;\r
+\r
+\r
+function btime_gettime(clockid:integer;tp:pbtimespec):integer;\r
+var\r
+ f:float;\r
+ i:int64;\r
+\r
+{$ifdef cpu386}{$ifdef has_extended}{$define itotp_float}{$endif}{$endif}\r
+procedure i100ns_to_tp_and_success;\r
+{$ifdef itotp_float}\r
+var\r
+ f:float;\r
+{$endif}\r
+begin\r
+ //in 32 bits delphi, float is 10 times faster than int64 here (30 vs 300 ns for the conversion)\r
+ //and with extended available, there is no loss of precision\r
+\r
+ {$ifdef itotp_float}\r
+ f := i / 10000000.0;\r
+ tp.tv_sec := trunc(f);\r
+ tp.tv_nsec := round(frac(f) * 1000000000.0);\r
+ {$else}\r
+ tp.tv_sec := i div 10000000;\r
+ tp.tv_nsec := (i mod 10000000) * 100;\r
+ {$endif}\r
+\r
+ result := 0; //success\r
+end;\r
+\r
+procedure f_to_tp_and_success;\r
+begin\r
+ tp.tv_sec := trunc(f);\r
+ tp.tv_nsec := round(frac(f) * 1000000000.0);\r
+ result := 0; //success\r
+end;\r
+\r
+begin\r
+ result := -1; //error\r
+\r
+ case clockid of\r
+ CLOCK_REALTIME: begin\r
+ //implement this case directly for full precision even without extended floats\r
+ if not btimenowin8 then begin\r
+ i := win8time_as_unix_100ns;\r
+ if (i > 0) then begin\r
+ i100ns_to_tp_and_success;\r
+ exit;\r
+ end;\r
+ end;\r
+ f := unixtimefloat;\r
+ f_to_tp_and_success;\r
+ end;\r
+ CLOCK_MONOTONIC: begin\r
+ f := monotimefloat;\r
+ f_to_tp_and_success;\r
+ end;\r
+ CLOCK_REALTIME_COARSE: begin\r
+ f := unixtimefloat_coarse;\r
+ f_to_tp_and_success;\r
+ end;\r
+ CLOCK_MONOTONIC_COARSE: begin\r
+ f := monotimefloat_coarse;\r
+ f_to_tp_and_success;\r
+ end;\r
+ CLOCK_UPTIME: begin\r
+ i := unbiasedtime_100ns;\r
+ if (i > 0) then begin\r
+ i100ns_to_tp_and_success;\r
+ exit;\r
+ end;\r
+ f := qpctimefloat;\r
+ f_to_tp_and_success;\r
+ end;\r
+ end;\r
+end;\r
+\r
+\r
+\r
function unixtimefloat:float;\r
+const\r
+ margin = 0.0012;\r
var\r
f,g,h:float;\r
begin\r
- if timefloatbias = 0 then begin\r
- settc;\r
- f := now_utc;\r
- repeat g := now_utc; h := wintimefloat until g > f;\r
- timefloatbias := oletounixfloat(g)-h;\r
- unsettc;\r
+ if not btimenowin8 then begin\r
+ result := win8time_as_unix_100ns * 0.0000001;\r
+ if (result > 0) then exit;\r
end;\r
- result := wintimefloat+timefloatbias;\r
\r
- {\r
- workaround for QPC jumps\r
- (approach 2: always check "hi res" QPC unixtime against the "guaranteed" systemtime one)\r
- }\r
- f := result-(oletounixfloat(now_utc));\r
- if abs(f) > 0.02 then begin\r
- f := timefloatbias;\r
- timefloatbias := 0;\r
+ result := monotimefloat+timefloatbias;\r
+ f := result-unixtimefloat_systemtime;\r
+ if ((f > ticks_freq2+margin) or (f < -margin)) or (timefloatbias = 0) then begin\r
+ f := unixtimefloat_systemtime;\r
+ settc;\r
+ repeat g := unixtimefloat_systemtime; h := monotimefloat until g > f;\r
+ unsettc;\r
+ timefloatbias := g-h;\r
result := unixtimefloat;\r
- qpcjump := qpcjump + f - timefloatbias;\r
end;\r
\r
- if (result <= lastunixtimefloat) then result := lastunixtimefloat + 0.0000001;\r
+ //for small changes backwards, guarantee no steps backwards\r
+ if (result <= lastunixtimefloat) and (result > lastunixtimefloat-1.5) then result := lastunixtimefloat;\r
lastunixtimefloat := result;\r
end;\r
\r
-function unixtimeint:integer;\r
+function unixtimeint:tunixtimeint;\r
begin\r
result := trunc(unixtimefloat);\r
end;\r
\r
-{$endif}\r
+{$endif} //mswindows\r
{-----------------------------------------------end of platform specific}\r
\r
+function wintimefloat:float;\r
+begin\r
+ result := monotimefloat;\r
+end;\r
+\r
function irctimefloat:float;\r
begin\r
result := unixtimefloat+settimebias;\r
end;\r
\r
-function irctimeint:integer;\r
+function irctimeint:tunixtimeint;\r
begin\r
result := unixtimeint+settimebias;\r
end;\r
\r
\r
-procedure settime(newtime:integer);\r
+procedure settime(newtime:tunixtimeint);\r
var\r
- a:integer;\r
+ a:tunixtimeint;\r
begin\r
a := irctimeint-settimebias;\r
if newtime = 0 then settimebias := 0 else settimebias := newtime-a;\r
begin\r
if unixtime = 0 then init;\r
unixtime := unixtimeint;\r
- irctime := irctimeint;\r
+ irctime := unixtime+settimebias;\r
if unixtime and 63 = 0 then begin\r
{update everything, apply timezone changes, clock changes, etc}\r
gettimezone;\r
end;\r
\r
\r
-procedure gettimezone;\r
+{$ifdef unix}\r
+\r
var\r
+ tzerror:boolean;\r
+ tzfile:ansistring;\r
+\r
+function tzgetfilename:ansistring;\r
+var\r
+ t:textfile;\r
+ a:integer;\r
+ s,tz,tzdir:ansistring;\r
+ ispath:boolean;\r
+begin\r
+ result := '';\r
+ filemode := 0;\r
+\r
+ tz := getenv('TZ');\r
+\r
+ if (tz <> '') then begin\r
+ ispath := false;\r
+ if (copy(tz,1,1) = ':') then begin\r
+ ispath := true;\r
+ tz := copy(tz,2,99999);\r
+ end;\r
+\r
+ if (copy(tz,1,1) <> '/') then begin\r
+ a := pos(',',tz);\r
+ if (a > 1) and not ispath then begin\r
+ tz := copy(tz,1,a-1);\r
+ end;\r
+\r
+ tzdir := getenv('TZDIR');\r
+ if (tzdir = '') then begin\r
+ tzdir := '/usr/share/zoneinfo/';\r
+ end else begin\r
+ if (copy(tzdir,length(tzdir),1) <> '/') then tzdir := tzdir + '/';\r
+ end;\r
+ tz := tzdir + tz;\r
+ end;\r
+\r
+ assignfile(t,tz);\r
+ {$i-}reset(t);{$i+}\r
+ if (ioresult = 0) then begin\r
+ closefile(t);\r
+ result := tz;\r
+ exit;\r
+ end;\r
+\r
+ end;\r
+\r
+ assignfile(t,'/etc/localtime');\r
+ {$i-}reset(t);{$i+}\r
+ if (ioresult = 0) then begin\r
+ closefile(t);\r
+ result := '/etc/localtime';\r
+ exit;\r
+ end;\r
+end;\r
+\r
+type\r
+ dvar=array[0..65535] of byte;\r
+ pdvar=^dvar;\r
+\r
+var\r
+ tzcache:pdvar;\r
+ tzsize:integer;\r
+\r
+procedure tzinvalidate;\r
+begin\r
+ if assigned(tzcache) then freemem(tzcache);\r
+ tzcache := nil;\r
+ tzsize := 0;\r
+ tzfile := '';\r
+ gettimezone;\r
+end;\r
+\r
+\r
+function tzgetoffsetforts(ts:tunixtimeint):integer;\r
+var\r
+ f:file;\r
+ buf:pdvar;\r
+ fs:integer;\r
+ ofs,ofs2:integer;\r
+ mode64:boolean;\r
+ has64:boolean;\r
+ a,index:integer;\r
+ //tzstrofs:integer;\r
+ t:int64;\r
+ tzh_ttisgmtcnt:integer;\r
+ tzh_ttisstdcnt:integer;\r
+ tzh_leapcnt:integer;\r
+ tzh_timecnt:integer;\r
+ tzh_typecnt:integer;\r
+ tzh_charcnt:integer;\r
+\r
+\r
+function getint:integer;\r
+begin\r
+ if (ofs < 0) or ((ofs + 4) > fs) then raise exception.create('getint');\r
+ result := (buf[ofs] shl 24) + (buf[ofs+1] shl 16) + (buf[ofs+2] shl 8) + buf[ofs+3];\r
+ inc(ofs,4);\r
+end;\r
+\r
+function getint64:int64;\r
+begin\r
+ if (ofs < 0) or ((ofs + 8) > fs) then raise exception.create('getint64');\r
+ result := int64(getint) shl 32;\r
+ inc(result,cardinal(getint));\r
+end;\r
+\r
+\r
+function getbyte:byte;\r
+begin\r
+ if (ofs < 0) or ((ofs + 1) > fs) then raise exception.create('getbyte');\r
+ result := buf[ofs];\r
+ inc(ofs);\r
+end;\r
+\r
+begin\r
+ result := 0;\r
+ tzerror := true;\r
+\r
+ if not assigned(tzcache) then begin\r
+\r
+ if (tzfile = '') then tzfile := tzgetfilename;\r
+\r
+ if (tzfile = '') then exit;\r
+\r
+ assignfile(f,tzfile);\r
+ filemode := 0;\r
+ {$i-}reset(f,1);{$i+}\r
+ if (ioresult <> 0) then begin\r
+ exit;\r
+ end;\r
+ tzsize := filesize(f);\r
+ if (tzsize > 65536) then tzsize := 65536;\r
+ getmem(tzcache,tzsize);\r
+ blockread(f,tzcache^,tzsize);\r
+ closefile(f);\r
+ end;\r
+ fs := tzsize;\r
+ buf := tzcache;\r
+ ofs := 0;\r
+ mode64 := false;\r
+\r
+ try\r
+ repeat\r
+ if (getint <> $545a6966) then exit; // 'TZif'\r
+ has64 := getbyte >= $32; // '2'\r
+\r
+ inc(ofs,15);\r
+\r
+ tzh_ttisgmtcnt := getint;\r
+ tzh_ttisstdcnt := getint;\r
+ tzh_leapcnt := getint;\r
+ tzh_timecnt := getint;\r
+ tzh_typecnt := getint;\r
+ tzh_charcnt := getint;\r
+\r
+ if mode64 or (not has64) then break;\r
+ inc(ofs, 5 * tzh_timecnt + 6 * tzh_typecnt + 8 * tzh_leapcnt + tzh_ttisstdcnt + tzh_ttisgmtcnt + tzh_charcnt);\r
+ mode64 := true;\r
+ until false;\r
+ index := 0;\r
+\r
+ if (tzh_timecnt < 0) or (tzh_timecnt > fs) then raise exception.create('tzh_timecnt');\r
+ ofs2 := ofs;\r
+\r
+ if (tzh_timecnt <> 0) then begin\r
+ for a := 0 to tzh_timecnt -1 do begin\r
+ if mode64 then t := getint64 else t := getint;\r
+ if (t > ts) then begin\r
+ index := a - 1;\r
+ break;\r
+ end;\r
+ if (a = tzh_timecnt -1) and (ts >= t) then index := a;\r
+ end;\r
+ ofs := ofs2 + tzh_timecnt * (1 + ord(mode64)) * 4;\r
+\r
+ if (cardinal(ofs + index) >= fs) or (index < 0) then raise exception.create('index');\r
+ index := buf[ofs+index];\r
+ inc(ofs,tzh_timecnt);\r
+ end else begin\r
+ index := 0;\r
+ end;\r
+\r
+ if (index >= tzh_typecnt) then raise exception.create('type');\r
+ ofs2 := ofs;\r
+ // writeln('ofs2 ',inttohex(ofs2,8));\r
+ inc(ofs,6 * index);\r
+ result := getint;\r
+\r
+ //tzisdst := getbyte;\r
+\r
+ //the abbreviation string\r
+ { tzstrofs := getbyte;\r
+ tzstr := '';\r
+ ofs := ofs2 + 6 * tzh_typecnt;\r
+ inc(ofs, tzstrofs);\r
+\r
+ repeat\r
+ a := getbyte;\r
+ if (a <> 0) then tzstr := tzstr + chr(a);\r
+ until (a = 0); }\r
+\r
+ tzerror := false;\r
+ except\r
+\r
+ end;\r
+end;\r
+\r
+{$endif} //unix\r
+\r
+function tzgetoffset:integer;\r
{$ifdef UNIX}\r
{$ifndef ver1_9_4}\r
{$ifndef ver1_0}\r
{$endif}\r
{$endif}\r
{$ifndef above194}\r
+var\r
hh,mm,ss:word;\r
{$endif}\r
+ {$else}\r
+var\r
+ TimeZoneInfo: TIME_ZONE_INFORMATION;\r
+ tztype:cardinal;\r
+ min:integer;\r
{$endif}\r
- l:integer;\r
+\r
begin\r
{$ifdef UNIX}\r
{$ifdef above194}\r
- timezone := tzseconds;\r
+ result := tzgetoffsetforts(unixtimeint);\r
+ //freepascal tzseconds is not 2038 safe\r
{$else}\r
gettime(hh,mm,ss);\r
- timezone := (longint(hh) * 3600 + mm * 60 + ss) - (unixtimeint mod 86400);\r
+ result := (integer(hh) * 3600 + mm * 60 + ss) - (unixtimeint mod 86400);\r
{$endif}\r
{$else}\r
- timezone := round((now-now_utc)*86400);\r
+ tztype := GetTimeZoneInformation(TimeZoneInfo);\r
+ min := TimeZoneInfo.Bias;\r
+ case tztype of\r
+ //TIME_ZONE_ID_UNKNOWN: don't add DST\r
+ TIME_ZONE_ID_STANDARD: inc(min, TimeZoneInfo.StandardBias);\r
+ TIME_ZONE_ID_DAYLIGHT: inc(min, TimeZoneInfo.DaylightBias);\r
+ end;\r
+ result := min * -60;\r
{$endif}\r
\r
- while timezone > 43200 do dec(timezone,86400);\r
- while timezone < -43200 do inc(timezone,86400);\r
+ while result > (14 * 3600) do dec(result,86400);\r
+ while result < -(14 * 3600) do inc(result,86400);\r
+end;\r
+\r
+\r
+procedure gettimezone;\r
+var\r
+ l:integer;\r
+begin\r
+ timezone := tzgetoffset;\r
\r
if timezone >= 0 then timezonestr := '+' else timezonestr := '-';\r
l := abs(timezone) div 60;\r
timezonestr := timezonestr + char(l div 600 mod 10+48)+char(l div 60 mod 10+48)+':'+char(l div 10 mod 6+48)+char(l mod 10+48);\r
end;\r
\r
-function timestrshort(i:integer):string;\r
+function timestrshort(i:tunixtimeint):string;\r
const\r
weekday:array[0..6] of string[4]=('Thu','Fri','Sat','Sun','Mon','Tue','Wed');\r
month:array[0..11] of string[4]=('Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct','Nov','Dec');\r
inttostr(y);\r
end;\r
\r
-function timestring(i:integer):string;\r
+function timestring(i:tunixtimeint):string;\r
const\r
weekday:array[0..6] of string[10]=('Thursday','Friday','Saturday','Sunday','Monday','Tuesday','Wednesday');\r
month:array[0..11] of string[10]=('January','February','March','April','May','June','July','August','September','October','November','December');\r
timezonestr;\r
end;\r
\r
+function timestriso(i:tunixtimeint):string;\r
+var\r
+ y,m,d,h,min,sec,ms:word;\r
+ t:tdatetime;\r
+begin\r
+ t := unixtoole(i+timezone);\r
+ decodedate(t,y,m,d);\r
+ decodetime(t,h,min,sec,ms);\r
+ result := inttostr(y)+'-'+inttostr(m div 10)+inttostr(m mod 10)+'-'+inttostr(d div 10)+inttostr(d mod 10)+' '+inttostr(h div 10)+inttostr(h mod 10)+':'+inttostr(min div 10)+inttostr(min mod 10)+':'+inttostr(sec div 10)+inttostr(sec mod 10);\r
+end;\r
+\r
+function timestrisoutc(i:float):string;\r
+var\r
+ y,m,d,h,min,sec,ms:word;\r
+ t:tdatetime;\r
+ fr:float;\r
+begin\r
+ t := unixtoole(i);\r
+ decodedate(t,y,m,d);\r
+ decodetime(t,h,min,sec,ms);\r
+ result := inttostr(y)+'-'+inttostr(m div 10)+inttostr(m mod 10)+'-'+inttostr(d div 10)+inttostr(d mod 10)+'T'+inttostr(h div 10)+inttostr(h mod 10)+':'+inttostr(min div 10)+inttostr(min mod 10)+':'+inttostr(sec div 10)+inttostr(sec mod 10);\r
+ fr := frac(i);\r
+\r
+ result := result + '.'+\r
+ inttostr(trunc(fr*10) mod 10)+\r
+ inttostr(trunc(fr*100) mod 10)+\r
+ inttostr(trunc(fr*1000) mod 10)+\r
+ inttostr(trunc(fr*10000) mod 10)+\r
+ inttostr(trunc(fr*100000) mod 10)+\r
+ inttostr(trunc(fr*1000000) mod 10)+'Z';\r
+\r
+end;\r
+\r
+procedure beginhightimerrate;\r
+begin\r
+ {$ifdef mswindows}timebeginperiod(1);{$endif}\r
+end;\r
+\r
+procedure endhightimerrate;\r
+begin\r
+ {$ifdef mswindows}timeendperiod(1);{$endif}\r
+end;\r
+\r
procedure init;\r
begin\r
- qpcjump := 0;\r
+ {$ifdef btimehighrate}beginhightimerrate;{$endif}\r
+ fillchar(mmtime_driftavg,sizeof(mmtime_driftavg),0);\r
settimebias := 0;\r
gettimezone;\r
unixtime := unixtimeint;\r
irctime := irctimeint;\r
end;\r
\r
+initialization init;\r
+\r
end.\r
lcore.org gitweb / lcore.git / blobdiff