works on windows/delphi, and on freepascal on unix.\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
type\r
float=extended;\r
+ tunixtimeint={$ifdef ver100}longint;{$else}int64;{$endif}\r
+\r
+const\r
+ colorburst=39375000/11; {3579545.4545....}\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
+ settimebias:tunixtimeint;\r
performancecountfreq:extended;\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
+//monotonic (alias, old function name)\r
function wintimefloat:float;\r
\r
-procedure settime(newtime:integer);\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 qpctimefloat:float;\r
+{$endif}\r
+\r
+{$ifdef mswindows}\r
+procedure gettimeofday(var tv:ttimeval);\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
+ mmtime_last:integer=0;\r
+ mmtime_wrapadd:float;\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
+ mmtime_prev_drift:float;\r
+ mmtime_prev_lastsyncmm:float;\r
+ mmtime_prev_lastsyncqpc:float;\r
\r
implementation\r
\r
-{$ifdef fpc}\r
- {$mode delphi}\r
-{$endif}\r
+\r
\r
uses\r
{$ifdef UNIX}\r
{$ifdef VER1_0}\r
linux,\r
{$else}\r
- baseunix,unix,unixutil,{needed for 2.0.2}\r
+ {$ifdef linux}linux,{$endif} //for clock_gettime\r
+ {$ifdef freebsd}freebsd,{$endif} //for clock_gettime\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
\r
+const\r
+ highdwordconst=65536.0 * 65536.0;\r
+\r
+function utrunc(f:float):integer;\r
+{converts float to integer, in 32 bits unsigned range}\r
+begin\r
+ if f >= (highdwordconst/2) then f := f - highdwordconst;\r
+ result := trunc(f);\r
+end;\r
+\r
+function uinttofloat(i:integer):float;\r
+{converts 32 bits unsigned integer to float}\r
+begin\r
+ result := i;\r
+ if result < 0 then result := result + highdwordconst;\r
+end;\r
+\r
{$ifdef unix}\r
{-----------------------------------------*nix/freepascal code to read time }\r
\r
function unixtimefloat:float;\r
var\r
tv:ttimeval;\r
+ sec:tunixtimeint;\r
begin\r
gettimeofday(tv);\r
- result := tv.tv_sec+(tv.tv_usec/1000000);\r
+ sec := tv.tv_sec;\r
+ {$ifndef cpu64}\r
+ if (sec < -1) then inc(sec,$100000000); //tv_sec is 32 bits. allow -1 for invalid result\r
+ {$endif}\r
+ result := sec+(tv.tv_usec/1000000);\r
end;\r
\r
-function wintimefloat:extended;\r
-begin\r
- result := unixtimefloat;\r
-end;\r
+{$ifdef linux}{$define have_clock_gettime}{$endif}\r
+{$ifdef freebsd}{$define have_clock_gettime}{$endif}\r
+\r
+{$ifdef have_clock_gettime}\r
+ {$define monotimefloat_implemented}\r
+\r
+ function monotimefloat:float;\r
+ var\r
+ ts: ttimespec;\r
+ begin\r
+ if clock_gettime(CLOCK_MONOTONIC, @ts) = 0 then begin\r
+ //note this really returns nanoseconds\r
+ result := ts.tv_sec + ts.tv_nsec / 1000000000.0;\r
+ exit;\r
+ end;\r
+ //fallback\r
+ result := unixtimefloat;\r
+ end;\r
+\r
+\r
+{$endif}\r
\r
-function unixtimeint:integer;\r
+{$ifdef darwin} {mac OS X}\r
+{$define monotimefloat_implemented}\r
+\r
+ type\r
+ tmach_timebase_info = packed record\r
+ numer: longint;\r
+ denom: longint;\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
+\r
+ function monotimefloat:float;\r
+ var\r
+ i:int64;\r
+ begin\r
+ if timebase_info.denom = 0 then begin\r
+ mach_timebase_info(@timebase_info);\r
+ end;\r
+ i := mach_absolute_time;\r
+ result := (i * timebase_info.numer div timebase_info.denom) / 1000000000.0;\r
+ end;\r
+\r
+{$endif} {darwin, mac OS X}\r
+\r
+\r
+{$ifndef monotimefloat_implemented} {fallback}\r
+ \r
+ function monotimefloat:extended;\r
+ begin\r
+ result := unixtimefloat;\r
+ end;\r
+\r
+{$endif} {monotimefloat fallback}\r
+\r
+\r
+function unixtimeint:tunixtimeint;\r
var\r
tv:ttimeval;\r
+ sec:tunixtimeint;\r
begin\r
gettimeofday(tv);\r
- result := tv.tv_sec;\r
+ sec := tv.tv_sec;\r
+ {$ifndef cpu64}\r
+ if (sec < -1) then inc(sec,$100000000); //tv_sec is 32 bits. allow -1 for invalid result\r
+ {$endif}\r
+ result := sec;\r
end;\r
\r
-{$else} {delphi 3}\r
+{------------------------------ end of *nix/freepascal section}\r
+\r
+{$else} {windows}\r
{------------------------------ windows/delphi code to read time}\r
\r
-{ free pascals tsystemtime is incomaptible with windows api calls\r
+\r
+procedure tzinvalidate;\r
+begin\r
+ gettimezone;\r
+end;\r
+\r
+{simulate gettimeofday on windows so one can always use gettimeofday if preferred}\r
+\r
+procedure gettimeofday(var tv:ttimeval);\r
+var\r
+ e:extended;\r
+begin\r
+ e := unixtimefloat;\r
+ tv.tv_sec := round(int(e));\r
+ tv.tv_usec := trunc(frac(e)*1000000);\r
+ {just in case}\r
+ if (tv.tv_usec < 0) then tv.tv_usec := 0;\r
+ if (tv.tv_usec > 999999) then tv.tv_usec := 999999;\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
+note: if called more than once per 49.7 days, 32 bits wrapping is compensated for and it keeps going on.\r
+note: i handle the timestamp as signed integer, but with the wrap compensation that works as well, and is faster\r
+}\r
+\r
+function mmtimefloat:float;\r
+const\r
+ wrapduration=highdwordconst * 0.001;\r
+var\r
+ i:integer;\r
+ temp:float;\r
+begin\r
+ i := gettickcount; {timegettime}\r
+ if i < mmtime_last then begin\r
+ mmtime_wrapadd := mmtime_wrapadd + wrapduration;\r
+ end;\r
+ mmtime_last := i;\r
+ result := mmtime_wrapadd + i * 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
+procedure measure_ticks_freq;\r
+var\r
+ f,g:float;\r
+ o:tosversioninfo;\r
+ isnt:boolean;\r
+{ is9x:boolean;}\r
+ adjust1,adjust2:cardinal;\r
+ adjustbool:longbool;\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
+ fillchar(o,sizeof(o),0);\r
+ o.dwOSVersionInfoSize := sizeof(o);\r
+ getversionex(o);\r
+ isnt := o.dwPlatformId = VER_PLATFORM_WIN32_NT;\r
+{ is9x := o.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS;}\r
+\r
+ ticks_freq2 := f;\r
+ mmtime_synchedqpc := false;\r
+\r
+ if (isnt and (o.dwMajorVersion >= 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
+ 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
+{\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:extended;\r
+var\r
+ p:packed record\r
+ lowpart:longint;\r
+ highpart:longint\r
+ end;\r
+ p2:tlargeinteger absolute p;\r
+ e:extended;\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
+ end;\r
+ queryperformancecounter(p2);\r
+ e := p.lowpart;\r
+ if e < 0 then e := e + highdwordconst;\r
+\r
+ result := ((p.highpart*highdwordconst)+e)/performancecountfreq;\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
+const\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
+ 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
+{ free pascals tsystemtime is incompatible with windows api calls\r
so we declare it ourselves - plugwash\r
}\r
{$ifdef fpc}\r
Result := round(Date_utc) + Time_utc;\r
end;\r
\r
-const\r
- highdwordconst=4294967296.0;\r
+function unixtimefloat_systemtime:float;\r
+begin\r
+ {result := oletounixfloat(now_utc);}\r
\r
-function wintimefloat:extended;\r
-var\r
- p:packed record\r
- lowpart:longint;\r
- highpart:longint\r
- end;\r
- p2:tlargeinteger absolute p;\r
- e:extended;\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
+end;\r
+\r
+function monotimefloat:extended;\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
- end;\r
- queryperformancecounter(p2);\r
- e := p.lowpart;\r
- if e < 0 then e := e + highdwordconst;\r
- result := ((p.highpart*highdwordconst)+e)/performancecountfreq;\r
+ result := mmqpctimefloat;\r
end;\r
\r
-var\r
- classpriority,threadpriority:integer;\r
\r
-procedure settc;\r
+\r
var\r
- hprocess,hthread:integer;\r
-begin\r
- hProcess := GetCurrentProcess;\r
- hThread := GetCurrentThread;\r
+ GetSystemTimePreciseAsFileTime:procedure(var v:tfiletime); stdcall;\r
+ win8inited:boolean;\r
\r
- ClassPriority := GetPriorityClass(hProcess);\r
- ThreadPriority := GetThreadPriority(hThread);\r
+procedure initwin8;\r
+var\r
+ dllhandle:thandle;\r
\r
- SetPriorityClass(hProcess, REALTIME_PRIORITY_CLASS);\r
- SetThreadPriority(hThread, THREAD_PRIORITY_TIME_CRITICAL);\r
+begin\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
-procedure unsettc;\r
+\r
+function unixtimefloat_win8:float;\r
var\r
- hprocess,hthread:integer;\r
+ ft:tfiletime;\r
+ i:int64 absolute ft;\r
begin\r
- hProcess := GetCurrentProcess;\r
- hThread := GetCurrentThread;\r
-\r
- SetPriorityClass(hProcess, ClassPriority);\r
- SetThreadPriority(hThread, ThreadPriority);\r
+ GetSystemTimePreciseAsFileTime(ft);\r
+ {change from windows 1601-01-01 to unix 1970-01-01.\r
+ use integer math for this, to preserve precision}\r
+ dec(i, 116444736000000000);\r
+ result := (i / 10000000);\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
+ if not btimenowin8 then begin\r
+ if not win8inited then initwin8;\r
+ if assigned(@GetSystemTimePreciseAsFileTime) then begin\r
+ result := unixtimefloat_win8;\r
+ exit;\r
+ end; \r
+ end;\r
+\r
+ result := monotimefloat+timefloatbias;\r
+ f := result-unixtimefloat_systemtime;\r
+ if ((f > ticks_freq2+margin) or (f < -margin)) or (timefloatbias = 0) then begin\r
+// writeln('unixtimefloat init');\r
+ f := unixtimefloat_systemtime;\r
settc;\r
- f := now_utc;\r
- repeat g := now_utc; h := wintimefloat until g > f;\r
- timefloatbias := oletounixfloat(g)-h;\r
+ repeat g := unixtimefloat_systemtime; h := monotimefloat until g > f;\r
unsettc;\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
+ 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 + 0.0000001;\r
lastunixtimefloat := result;\r
end;\r
\r
-function unixtimeint:integer;\r
+function unixtimeint:tunixtimeint;\r
begin\r
result := trunc(unixtimefloat);\r
end;\r
{$endif}\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
end;\r
\r
\r
+{$ifdef unix}\r
+\r
+var\r
+ tzerror:boolean;\r
+ tzfile:ansistring;\r
+\r
+function tzgetfilename:ansistring;\r
+var\r
+ t:textfile;\r
+\r
+ s,tz,tzdir:ansistring;\r
+begin\r
+ result := '';\r
+ filemode := 0;\r
+ {$ifdef unix}\r
+ tz := getenv('TZ');\r
+\r
+ if (copy(tz,1,1) = ':') then begin\r
+ tz := copy(tz,2,99999);\r
+\r
+ if (copy(tz,1,1) <> '/') then begin\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
+ {$endif}\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
+\r
+ assignfile(t,'/etc/timezone');\r
+\r
+ s := '';\r
+ {$i-}reset(t);{$i+}\r
+ if (ioresult = 0) then begin\r
+ readln(t,s);\r
+ closefile(t);\r
+ if (s <> '') then begin\r
+ result := '/usr/share/zoneinfo/'+s;\r
+ exit;\r
+ end;\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
+ 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
+\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
+function tzgetoffset:integer;\r
+begin\r
+ tzgetoffsetforts(unixtimeint);\r
+end;\r
+\r
+\r
+{$endif}\r
+\r
+\r
procedure gettimezone;\r
var\r
{$ifdef UNIX}\r
begin\r
{$ifdef UNIX}\r
{$ifdef above194}\r
- timezone := tzseconds;\r
+ timezone := tzgetoffset;\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
timezone := round((now-now_utc)*86400);\r
{$endif}\r
\r
- while timezone > 43200 do dec(timezone,86400);\r
- while timezone < -43200 do inc(timezone,86400);\r
+ while timezone > 50400 do dec(timezone,86400);\r
+ while timezone < -50400 do inc(timezone,86400);\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