\r
\r
unit btime;\r
+{$ifdef fpc}\r
+ {$mode delphi}\r
+{$endif}\r
+\r
+{$include lcoreconfig.inc}\r
\r
interface\r
\r
tickcount:integer;\r
settimebias:tunixtimeint;\r
performancecountfreq:extended;\r
+ btimenowin8:boolean;\r
\r
function irctimefloat:float;\r
function irctimeint:tunixtimeint;\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
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
+ {$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
- {$ifdef linux}\r
- dl,\r
- {$endif}\r
{$else}\r
windows,unitsettc,mmsystem,\r
{$endif}\r
\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:float):tdatetime;\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
-{$ifdef linux}\r
- {$define monotimefloat_implemented}\r
- const\r
- CLOCK_MONOTONIC = 1;\r
- type \r
- ptimeval = ^ttimeval;\r
- tclock_gettime = function(clk_id: integer; tp: ptimeval): integer; cdecl;\r
+{$ifdef linux}{$define have_clock_gettime}{$endif}\r
+{$ifdef freebsd}{$define have_clock_gettime}{$endif}\r
\r
- var\r
- librt_handle:pointer;\r
- librt_inited:boolean;\r
- clock_gettime: tclock_gettime;\r
+{$ifdef have_clock_gettime}\r
+ {$define monotimefloat_implemented}\r
\r
function monotimefloat:float;\r
var\r
- ts: ttimeval;\r
+ ts: ttimespec;\r
begin\r
- if not librt_inited then begin\r
- librt_inited := true;\r
- clock_gettime := nil;\r
- librt_handle := dlopen('librt.so', RTLD_LAZY);\r
- if assigned(librt_handle) then begin\r
- clock_gettime := dlsym(librt_handle, 'clock_gettime');\r
- end;\r
- end;\r
- if assigned(clock_gettime) then begin\r
- if clock_gettime(CLOCK_MONOTONIC, @ts) = 0 then begin\r
- //note this really returns nanoseconds\r
- result := ts.tv_sec + ts.tv_usec / 1000000000.0;\r
- exit;\r
- end;\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} {linux}\r
+{$endif}\r
\r
{$ifdef darwin} {mac OS X}\r
{$define monotimefloat_implemented}\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
{------------------------------ end of *nix/freepascal section}\r
\r
-{$else} {delphi 3}\r
+{$else} {windows}\r
{------------------------------ windows/delphi code to read time}\r
\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
f,g,h:float;\r
begin\r
- if not win8inited then initwin8;\r
- if assigned(@GetSystemTimePreciseAsFileTime) then begin\r
- result := unixtimefloat_win8;\r
- exit;\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
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
\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
- {$ifdef mswindows}timebeginperiod(1);{$endif} //ensure stable unchanging clock\r
+ {$ifdef btimehighrate}beginhightimerrate;{$endif}\r
fillchar(mmtime_driftavg,sizeof(mmtime_driftavg),0);\r
settimebias := 0;\r
gettimezone;\r
lcore.org gitweb / lcore.git / blobdiff