btime.pas

   1 { Copyright (C) 2005 Bas Steendijk and Peter Green\r
   2   For conditions of distribution and use, see copyright notice in zlib_license.txt\r
   3   which is included in the package\r
   4   ----------------------------------------------------------------------------- }\r
   5 {\r
   6 this unit returns unix timestamp with seconds and microseconds (as float)\r
   7 works on windows/delphi, and on freepascal on unix.\r
   8 }\r
   9 \r
  10 \r
  11 unit btime;\r
  12 {$ifdef fpc}\r
  13   {$mode delphi}\r
  14 {$endif}\r
  15 \r
  16 {$include lcoreconfig.inc}\r
  17 \r
  18 interface\r
  19 \r
  20 {$ifdef mswindows}\r
  21 uses\r
  22   ltimevalstuff;\r
  23 {$endif}  \r
  24 \r
  25 type\r
  26   float=extended;\r
  27   tunixtimeint={$ifdef ver100}longint;{$else}int64;{$endif}\r
  28 \r
  29 const\r
  30   colorburst=39375000/11;  {3579545.4545....}\r
  31 \r
  32 var\r
  33   timezone:integer;\r
  34   timezonestr:string;\r
  35   irctime,unixtime:tunixtimeint;\r
  36   tickcount:integer;\r
  37   settimebias:tunixtimeint;\r
  38   performancecountfreq:extended;\r
  39   btimenowin8:boolean;\r
  40 \r
  41 function irctimefloat:float;\r
  42 function irctimeint:tunixtimeint;\r
  43 \r
  44 //unix timestamp (UTC) float seconds\r
  45 function unixtimefloat:float;\r
  46 function unixtimeint:tunixtimeint;\r
  47 \r
  48 //monotonic float seconds\r
  49 function monotimefloat:float;\r
  50 \r
  51 //monotonic (alias, old function name)\r
  52 function wintimefloat:float;\r
  53 \r
  54 procedure settime(newtime:tunixtimeint);\r
  55 procedure gettimezone;\r
  56 procedure timehandler;\r
  57 procedure init;\r
  58 \r
  59 function timestring(i:tunixtimeint):string;      // Wednesday August 15 2012 -- 16:21:09 +02:00\r
  60 function timestrshort(i:tunixtimeint):string;    // Wed Aug 15 16:21:09 2012\r
  61 function timestriso(i:tunixtimeint):string;      // 2012-08-15 16:21:09\r
  62 function timestrisoutc(i:float):string;          // 2012-08-15T14:21:09.255553Z\r
  63 \r
  64 procedure beginhightimerrate;\r
  65 procedure endhightimerrate;\r
  66 \r
  67 procedure tzinvalidate;\r
  68 \r
  69 {$ifdef unix}\r
  70 function tzgetoffsetforts(ts:tunixtimeint):integer;\r
  71 {$endif}\r
  72 \r
  73 {$ifdef mswindows}\r
  74 function unixtimefloat_systemtime:float;\r
  75 {$endif}\r
  76 \r
  77 function oletounixfloat(t:float):float;\r
  78 function oletounix(t:tdatetime):tunixtimeint;\r
  79 function unixtoole(i:float):tdatetime;\r
  80 \r
  81 {$ifdef mswindows}\r
  82 function mmtimefloat:float;\r
  83 function qpctimefloat:float;\r
  84 {$endif}\r
  85 \r
  86 {$ifdef mswindows}\r
  87 procedure gettimeofday(var tv:ttimeval);\r
  88 {$endif}\r
  89 \r
  90 \r
  91 const\r
  92   mmtime_driftavgsize=32;\r
  93   mmtime_warmupnum=4;\r
  94   mmtime_warmupcyclelength=15;\r
  95 var\r
  96   //this flag is to be set when btime has been running long enough to stabilise\r
  97   warmup_finished:boolean;\r
  98 \r
  99   timefloatbias:float;\r
 100   ticks_freq:float=0;\r
 101   ticks_freq2:float=0;\r
 102   ticks_freq_known:boolean=false;\r
 103   lastunixtimefloat:float=0;\r
 104   lastsynctime:float=0;\r
 105   lastsyncbias:float=0;\r
 106 \r
 107   mmtime_last:integer=0;\r
 108   mmtime_wrapadd:float;\r
 109   mmtime_lastsyncmm:float=0;\r
 110   mmtime_lastsyncqpc:float=0;\r
 111   mmtime_drift:float=1;\r
 112   mmtime_lastresult:float;\r
 113   mmtime_nextdriftcorrection:float;\r
 114   mmtime_driftavg:array[0..mmtime_driftavgsize] of float;\r
 115   mmtime_synchedqpc:boolean;\r
 116 \r
 117   mmtime_prev_drift:float;\r
 118   mmtime_prev_lastsyncmm:float;\r
 119   mmtime_prev_lastsyncqpc:float;\r
 120 \r
 121 implementation\r
 122 \r
 123 \r
 124 \r
 125 uses\r
 126   {$ifdef UNIX}\r
 127     {$ifdef VER1_0}\r
 128       linux,\r
 129     {$else}\r
 130       {$ifdef linux}linux,{$endif} //for clock_gettime\r
 131       {$ifdef freebsd}freebsd,{$endif} //for clock_gettime\r
 132       baseunix,unix,unixutil,sockets, {unixutil and sockets needed by unixstuff.inc on some compiler versions}\r
 133     {$endif}\r
 134   {$else}\r
 135     windows,unitsettc,mmsystem,\r
 136   {$endif}\r
 137   sysutils;\r
 138 \r
 139   {$include unixstuff.inc}\r
 140 \r
 141 \r
 142 const\r
 143   daysdifference=25569;\r
 144 \r
 145 function oletounixfloat(t:float):float;\r
 146 begin\r
 147   t := (t - daysdifference) * 86400;\r
 148   result := t;\r
 149 end;\r
 150 \r
 151 function oletounix(t:tdatetime):tunixtimeint;\r
 152 begin\r
 153   result := round(oletounixfloat(t));\r
 154 end;\r
 155 \r
 156 function unixtoole(i:float):tdatetime;\r
 157 begin\r
 158   result := ((i)/86400)+daysdifference;\r
 159 end;\r
 160 \r
 161 const\r
 162   highdwordconst=65536.0 * 65536.0;\r
 163 \r
 164 function utrunc(f:float):integer;\r
 165 {converts float to integer, in 32 bits unsigned range}\r
 166 begin\r
 167   if f >= (highdwordconst/2) then f := f - highdwordconst;\r
 168   result := trunc(f);\r
 169 end;\r
 170 \r
 171 function uinttofloat(i:integer):float;\r
 172 {converts 32 bits unsigned integer to float}\r
 173 begin\r
 174   result := i;\r
 175   if result < 0 then result := result + highdwordconst;\r
 176 end;\r
 177 \r
 178 {$ifdef unix}\r
 179 {-----------------------------------------*nix/freepascal code to read time }\r
 180 \r
 181 function unixtimefloat:float;\r
 182 var\r
 183   tv:ttimeval;\r
 184   sec:tunixtimeint;\r
 185 begin\r
 186   gettimeofday(tv);\r
 187   sec := tv.tv_sec;\r
 188   {$ifndef cpu64}\r
 189   if (sec < -1) then inc(sec,$100000000); //tv_sec is 32 bits. allow -1 for invalid result\r
 190   {$endif}\r
 191   result := sec+(tv.tv_usec/1000000);\r
 192 end;\r
 193 \r
 194 {$ifdef linux}{$define have_clock_gettime}{$endif}\r
 195 {$ifdef freebsd}{$define have_clock_gettime}{$endif}\r
 196 \r
 197 {$ifdef have_clock_gettime}\r
 198   {$define monotimefloat_implemented}\r
 199 \r
 200   function monotimefloat:float;\r
 201   var\r
 202     ts: ttimespec;\r
 203   begin\r
 204     if clock_gettime(CLOCK_MONOTONIC, @ts) = 0 then begin\r
 205       //note this really returns nanoseconds\r
 206       result := ts.tv_sec + ts.tv_nsec / 1000000000.0;\r
 207       exit;\r
 208     end;\r
 209     //fallback\r
 210     result := unixtimefloat;\r
 211   end;\r
 212 \r
 213 \r
 214 {$endif}\r
 215 \r
 216 {$ifdef darwin} {mac OS X}\r
 217 {$define monotimefloat_implemented}\r
 218 \r
 219   type\r
 220     tmach_timebase_info = packed record\r
 221       numer: longint;\r
 222       denom: longint;\r
 223     end;\r
 224     pmach_timebase_info = ^tmach_timebase_info;\r
 225      \r
 226     function mach_absolute_time: int64; cdecl; external;\r
 227     function mach_timebase_info(info: pmach_timebase_info): integer; cdecl; external;\r
 228 \r
 229   var\r
 230     timebase_info: tmach_timebase_info;\r
 231 \r
 232   function monotimefloat:float;\r
 233   var\r
 234     i:int64;\r
 235   begin\r
 236     if timebase_info.denom = 0 then begin\r
 237       mach_timebase_info(@timebase_info);\r
 238     end;\r
 239     i := mach_absolute_time;\r
 240     result := (i * timebase_info.numer div timebase_info.denom) / 1000000000.0;\r
 241   end;\r
 242 \r
 243 {$endif} {darwin, mac OS X}\r
 244 \r
 245 \r
 246 {$ifndef monotimefloat_implemented} {fallback}\r
 247   \r
 248   function monotimefloat:extended;\r
 249   begin\r
 250     result := unixtimefloat;\r
 251   end;\r
 252 \r
 253 {$endif} {monotimefloat fallback}\r
 254 \r
 255 \r
 256 function unixtimeint:tunixtimeint;\r
 257 var\r
 258   tv:ttimeval;\r
 259   sec:tunixtimeint;\r
 260 begin\r
 261   gettimeofday(tv);\r
 262   sec := tv.tv_sec;\r
 263   {$ifndef cpu64}\r
 264   if (sec < -1) then inc(sec,$100000000); //tv_sec is 32 bits. allow -1 for invalid result\r
 265   {$endif}\r
 266   result := sec;\r
 267 end;\r
 268 \r
 269 {------------------------------ end of *nix/freepascal section}\r
 270 \r
 271 {$else} {windows}\r
 272 {------------------------------ windows/delphi code to read time}\r
 273 \r
 274 \r
 275 procedure tzinvalidate;\r
 276 begin\r
 277   gettimezone;\r
 278 end;\r
 279 \r
 280 {simulate gettimeofday on windows so one can always use gettimeofday if preferred}\r
 281 \r
 282 procedure gettimeofday(var tv:ttimeval);\r
 283 var\r
 284   e:extended;\r
 285 begin\r
 286   e := unixtimefloat;\r
 287   tv.tv_sec := round(int(e));\r
 288   tv.tv_usec := trunc(frac(e)*1000000);\r
 289   {just in case}\r
 290   if (tv.tv_usec < 0) then tv.tv_usec := 0;\r
 291   if (tv.tv_usec > 999999) then tv.tv_usec := 999999;\r
 292 end;\r
 293 \r
 294 \r
 295 {\r
 296 time float: gettickcount\r
 297 resolution: 9x: ~55 ms NT: 1/64th of a second\r
 298 guarantees: continuous without any jumps\r
 299 frequency base: same as system clock.\r
 300 epoch: system boot\r
 301 note: if called more than once per 49.7 days, 32 bits wrapping is compensated for and it keeps going on.\r
 302 note: i handle the timestamp as signed integer, but with the wrap compensation that works as well, and is faster\r
 303 }\r
 304 \r
 305 function mmtimefloat:float;\r
 306 const\r
 307   wrapduration=highdwordconst * 0.001;\r
 308 var\r
 309   i:integer;\r
 310   temp:float;\r
 311 begin\r
 312   i := gettickcount; {timegettime}\r
 313   if i < mmtime_last then begin\r
 314     mmtime_wrapadd := mmtime_wrapadd + wrapduration;\r
 315   end;\r
 316   mmtime_last := i;\r
 317   result := mmtime_wrapadd + i * 0.001;\r
 318 \r
 319   if (ticks_freq <> 0) and ticks_freq_known then begin\r
 320     {the value we get is rounded to 1 ms, but the ticks are not a multiple of 1 ms\r
 321     this makes the value noisy. use the known ticks frequency to restore the original value}\r
 322     temp := int((result / ticks_freq)+0.5) * ticks_freq;\r
 323 \r
 324     {if the known ticks freq is wrong (can happen), disable the un-rounding behavior\r
 325     this will be a bit less accurate but it prevents problems}\r
 326     if abs(temp - result) > 0.002 then begin\r
 327       ticks_freq := 0;\r
 328     end else result := temp;\r
 329   end;\r
 330 end;\r
 331 \r
 332 procedure measure_ticks_freq;\r
 333 var\r
 334   f,g:float;\r
 335   o:tosversioninfo;\r
 336   isnt:boolean;\r
 337 {  is9x:boolean;}\r
 338   adjust1,adjust2:cardinal;\r
 339   adjustbool:longbool;\r
 340 begin\r
 341   if (performancecountfreq = 0) then qpctimefloat;\r
 342   ticks_freq_known := false;\r
 343   settc;\r
 344   f := mmtimefloat;\r
 345   repeat g := mmtimefloat until g > f;\r
 346   unsettc;\r
 347   f := g - f;\r
 348   fillchar(o,sizeof(o),0);\r
 349   o.dwOSVersionInfoSize := sizeof(o);\r
 350   getversionex(o);\r
 351   isnt := o.dwPlatformId = VER_PLATFORM_WIN32_NT;\r
 352 {  is9x := o.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS;}\r
 353 \r
 354   ticks_freq2 := f;\r
 355   mmtime_synchedqpc := false;\r
 356 \r
 357   if (isnt and (o.dwMajorVersion >= 5)) then begin\r
 358     {windows 2000 and later: query tick rate from OS in 100 ns units\r
 359     typical rates: XP: 156250 or 100144, windows 7: 156001}\r
 360     if GetSystemTimeAdjustment(adjust1,adjust2,adjustbool) then begin\r
 361       ticks_freq := adjust1 / 10000000.0;\r
 362       ticks_freq_known := true;\r
 363       mmtime_synchedqpc := false;\r
 364     end;\r
 365   end;\r
 366 \r
 367   {9x}\r
 368   if (performancecountfreq = 1193182) and (f >= 0.050) and (f <= 0.060) then begin\r
 369     ticks_freq_known := true;\r
 370     ticks_freq := 65536 / (colorburst / 3);\r
 371     mmtime_synchedqpc := true;\r
 372   end;\r
 373   ticks_freq_known := true;\r
 374   if ticks_freq <> 0 then ticks_freq2 := ticks_freq;\r
 375 //  writeln(formatfloat('0.000000',ticks_freq));\r
 376 end;\r
 377 \r
 378 {\r
 379 time float: QueryPerformanceCounter\r
 380 resolution: <1us\r
 381 guarantees: can have forward jumps depending on hardware. can have forward and backwards jitter on dual core.\r
 382 frequency base: on NT, not the system clock, drifts compared to it.\r
 383 epoch: system boot\r
 384 }\r
 385 function qpctimefloat:extended;\r
 386 var\r
 387   p:packed record\r
 388     lowpart:longint;\r
 389     highpart:longint\r
 390   end;\r
 391   p2:tlargeinteger absolute p;\r
 392   e:extended;\r
 393 begin\r
 394   if performancecountfreq = 0 then begin\r
 395     QueryPerformancefrequency(p2);\r
 396     e := p.lowpart;\r
 397     if e < 0 then e := e + highdwordconst;\r
 398     performancecountfreq := ((p.highpart*highdwordconst)+e);\r
 399   end;\r
 400   queryperformancecounter(p2);\r
 401   e := p.lowpart;\r
 402   if e < 0 then e := e + highdwordconst;\r
 403 \r
 404   result := ((p.highpart*highdwordconst)+e)/performancecountfreq;\r
 405 end;\r
 406 \r
 407 {\r
 408 time float: QPC locked to gettickcount\r
 409 resolution: <1us\r
 410 guarantees: continuous without any jumps\r
 411 frequency base: same as system clock.\r
 412 epoch: system boot\r
 413 }\r
 414 \r
 415 function mmqpctimefloat:float;\r
 416 const\r
 417   maxretries=5;\r
 418   margin=0.002;\r
 419 var\r
 420 {  jump:float;}\r
 421   mm,f,qpc,newdrift:float;\r
 422   qpcjumped:boolean;\r
 423   a,b:integer;\r
 424 {  retrycount:integer;}\r
 425 begin\r
 426   if not ticks_freq_known then measure_ticks_freq;\r
 427 {  retrycount := maxretries;}\r
 428 \r
 429   qpc := qpctimefloat;\r
 430   mm := mmtimefloat;\r
 431   f := (qpc - mmtime_lastsyncqpc) * mmtime_drift + mmtime_lastsyncmm;\r
 432   //writeln('XXXX ',formatfloat('0.000000',qpc-mm));\r
 433   qpcjumped := ((f-mm) > ticks_freq2+margin) or ((f-mm) < -margin);\r
 434 //  if qpcjumped then writeln('qpc jumped ',(f-mm));\r
 435   if ((qpc > mmtime_nextdriftcorrection) and not mmtime_synchedqpc) or qpcjumped then begin\r
 436 \r
 437     mmtime_nextdriftcorrection := qpc + 1;\r
 438     repeat\r
 439       mmtime_prev_drift := mmtime_drift;\r
 440       mmtime_prev_lastsyncmm := mmtime_lastsyncmm;\r
 441       mmtime_prev_lastsyncqpc := mmtime_lastsyncqpc;\r
 442 \r
 443       mm := mmtimefloat;\r
 444     {  dec(retrycount);}\r
 445       settc;\r
 446       result := qpctimefloat;\r
 447       f := mmtimefloat;\r
 448       repeat\r
 449         if f = mm then result := qpctimefloat;\r
 450         f := mmtimefloat\r
 451       until f > mm;\r
 452       qpc := qpctimefloat;\r
 453 \r
 454       unsettc;\r
 455       if (qpc > result + 0.0001) then begin\r
 456         continue;\r
 457       end;\r
 458       mm := f;\r
 459 \r
 460       if (mmtime_lastsyncqpc <> 0) and not qpcjumped then begin\r
 461         newdrift := (mm - mmtime_lastsyncmm) / (qpc - mmtime_lastsyncqpc);\r
 462         mmtime_drift := newdrift;\r
 463      {   writeln('raw drift: ',formatfloat('0.00000000',mmtime_drift));}\r
 464         move(mmtime_driftavg[0],mmtime_driftavg[1],sizeof(mmtime_driftavg[0])*high(mmtime_driftavg));\r
 465         mmtime_driftavg[0] := mmtime_drift;\r
 466 \r
 467 {        write('averaging drift ',formatfloat('0.00000000',mmtime_drift),' -> ');}\r
 468 {        mmtime_drift := 0;}\r
 469         b := 0;\r
 470         for a := 0 to high(mmtime_driftavg) do begin\r
 471           if mmtime_driftavg[a] <> 0 then inc(b);\r
 472 {          mmtime_drift := mmtime_drift + mmtime_driftavg[a];}\r
 473         end;\r
 474 {        mmtime_drift := mmtime_drift / b;}\r
 475         a := 5;\r
 476         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
 477         mmtime_nextdriftcorrection := qpc + a;\r
 478         if (b >= 2) then warmup_finished := true;\r
 479 {        writeln(formatfloat('0.00000000',mmtime_drift));}\r
 480        if mmtime_synchedqpc then mmtime_drift := 1;\r
 481       end;\r
 482 \r
 483       mmtime_lastsyncqpc := qpc;\r
 484       mmtime_lastsyncmm := mm;\r
 485   {   writeln(formatfloat('0.00000000',mmtime_drift));}\r
 486       break;\r
 487     until false;\r
 488 \r
 489 \r
 490     qpc := qpctimefloat;\r
 491 \r
 492     result := (qpc - mmtime_lastsyncqpc) * mmtime_drift + mmtime_lastsyncmm;\r
 493 \r
 494     {f := (qpc - mmtime_prev_lastsyncqpc) * mmtime_prev_drift + mmtime_prev_lastsyncmm;\r
 495     jump := result-f;\r
 496     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
 497 \r
 498     f := result;\r
 499   end;\r
 500 \r
 501   result := f;\r
 502 \r
 503   if (result < mmtime_lastresult) then result := mmtime_lastresult;\r
 504   mmtime_lastresult := result;\r
 505 end;\r
 506 \r
 507 { free pascals tsystemtime is incompatible with windows api calls\r
 508  so we declare it ourselves - plugwash\r
 509 }\r
 510 {$ifdef fpc}\r
 511 type\r
 512   TSystemTime = record\r
 513      wYear: Word;\r
 514      wMonth: Word;\r
 515      wDayOfWeek: Word;\r
 516      wDay: Word;\r
 517      wHour: Word;\r
 518      wMinute: Word;\r
 519      wSecond: Word;\r
 520      wMilliseconds: Word;\r
 521   end;\r
 522  {$endif}\r
 523 function Date_utc: extended;\r
 524 var\r
 525   SystemTime: TSystemTime;\r
 526 begin\r
 527   {$ifdef fpc}\r
 528     GetsystemTime(@SystemTime);\r
 529   {$else}\r
 530     GetsystemTime(SystemTime);\r
 531   {$endif}\r
 532   with SystemTime do Result := EncodeDate(wYear, wMonth, wDay);\r
 533 end;\r
 534 \r
 535 function Time_utc: extended;\r
 536 var\r
 537   SystemTime: TSystemTime;\r
 538 begin\r
 539   {$ifdef fpc}\r
 540     GetsystemTime(@SystemTime);\r
 541   {$else}\r
 542     GetsystemTime(SystemTime);\r
 543   {$endif}\r
 544   with SystemTime do\r
 545     Result := EncodeTime(wHour, wMinute, wSecond, wMilliSeconds);\r
 546 end;\r
 547 \r
 548 function Now_utc: extended;\r
 549 begin\r
 550   Result := round(Date_utc) + Time_utc;\r
 551 end;\r
 552 \r
 553 function unixtimefloat_systemtime:float;\r
 554 begin\r
 555   {result := oletounixfloat(now_utc);}\r
 556 \r
 557   {this method gives exactly the same result with extended precision, but is less sensitive to float rounding in theory}\r
 558   result := oletounixfloat(int(date_utc+0.5))+time_utc*86400;\r
 559 end;\r
 560 \r
 561 function monotimefloat:extended;\r
 562 begin\r
 563   result := mmqpctimefloat;\r
 564 end;\r
 565 \r
 566 \r
 567 \r
 568 var\r
 569   GetSystemTimePreciseAsFileTime:procedure(var v:tfiletime); stdcall;\r
 570   win8inited:boolean;\r
 571 \r
 572 procedure initwin8;\r
 573 var\r
 574   dllhandle:thandle;\r
 575 \r
 576 begin\r
 577   win8inited := true;\r
 578   dllhandle := loadlibrary('kernel32.dll');\r
 579   if (dllhandle <> 0) then begin\r
 580     GetSystemTimePreciseAsFileTime := getprocaddress(dllhandle,'GetSystemTimePreciseAsFileTime');\r
 581   end;\r
 582 end;\r
 583 \r
 584 \r
 585 function unixtimefloat_win8:float;\r
 586 var\r
 587   ft:tfiletime;\r
 588   i:int64 absolute ft;\r
 589 begin\r
 590   GetSystemTimePreciseAsFileTime(ft);\r
 591   {change from windows 1601-01-01 to unix 1970-01-01.\r
 592   use integer math for this, to preserve precision}\r
 593   dec(i, 116444736000000000);\r
 594   result := (i / 10000000);\r
 595 end;\r
 596 \r
 597 \r
 598 \r
 599 function unixtimefloat:float;\r
 600 const\r
 601   margin = 0.0012;\r
 602 var\r
 603   f,g,h:float;\r
 604 begin\r
 605   if not btimenowin8 then begin\r
 606     if not win8inited then initwin8;\r
 607     if assigned(@GetSystemTimePreciseAsFileTime) then begin\r
 608       result := unixtimefloat_win8;\r
 609       exit;\r
 610     end;  \r
 611   end;\r
 612 \r
 613   result := monotimefloat+timefloatbias;\r
 614   f := result-unixtimefloat_systemtime;\r
 615   if ((f > ticks_freq2+margin) or (f < -margin)) or (timefloatbias = 0) then begin\r
 616 //    writeln('unixtimefloat init');\r
 617     f := unixtimefloat_systemtime;\r
 618     settc;\r
 619     repeat g := unixtimefloat_systemtime; h := monotimefloat until g > f;\r
 620     unsettc;\r
 621     timefloatbias := g-h;\r
 622     result := unixtimefloat;\r
 623   end;\r
 624 \r
 625   {for small changes backwards, guarantee no steps backwards}\r
 626   if (result <= lastunixtimefloat) and (result > lastunixtimefloat-1.5) then result := lastunixtimefloat + 0.0000001;\r
 627   lastunixtimefloat := result;\r
 628 end;\r
 629 \r
 630 function unixtimeint:tunixtimeint;\r
 631 begin\r
 632   result := trunc(unixtimefloat);\r
 633 end;\r
 634 \r
 635 {$endif}\r
 636 {-----------------------------------------------end of platform specific}\r
 637 \r
 638 function wintimefloat:float;\r
 639 begin\r
 640   result := monotimefloat;\r
 641 end;\r
 642 \r
 643 function irctimefloat:float;\r
 644 begin\r
 645   result := unixtimefloat+settimebias;\r
 646 end;\r
 647 \r
 648 function irctimeint:tunixtimeint;\r
 649 begin\r
 650   result := unixtimeint+settimebias;\r
 651 end;\r
 652 \r
 653 \r
 654 procedure settime(newtime:tunixtimeint);\r
 655 var\r
 656   a:tunixtimeint;\r
 657 begin\r
 658   a := irctimeint-settimebias;\r
 659   if newtime = 0 then settimebias := 0 else settimebias := newtime-a;\r
 660 \r
 661   irctime := irctimeint;\r
 662 end;\r
 663 \r
 664 procedure timehandler;\r
 665 begin\r
 666   if unixtime = 0 then init;\r
 667   unixtime := unixtimeint;\r
 668   irctime := irctimeint;\r
 669   if unixtime and 63 = 0 then begin\r
 670     {update everything, apply timezone changes, clock changes, etc}\r
 671     gettimezone;\r
 672     timefloatbias := 0;\r
 673     unixtime := unixtimeint;\r
 674     irctime := irctimeint;\r
 675   end;\r
 676 end;\r
 677 \r
 678 \r
 679 {$ifdef unix}\r
 680 \r
 681 var\r
 682   tzerror:boolean;\r
 683   tzfile:ansistring;\r
 684 \r
 685 function tzgetfilename:ansistring;\r
 686 var\r
 687   t:textfile;\r
 688 \r
 689   s,tz,tzdir:ansistring;\r
 690 begin\r
 691   result := '';\r
 692   filemode := 0;\r
 693   {$ifdef unix}\r
 694   tz := getenv('TZ');\r
 695 \r
 696   if (copy(tz,1,1) = ':') then begin\r
 697     tz := copy(tz,2,99999);\r
 698 \r
 699     if (copy(tz,1,1) <> '/') then begin\r
 700       tzdir := getenv('TZDIR');\r
 701       if (tzdir = '') then begin\r
 702         tzdir := '/usr/share/zoneinfo/';\r
 703       end else begin\r
 704         if (copy(tzdir,length(tzdir),1) <> '/') then tzdir := tzdir + '/';\r
 705       end;\r
 706       tz := tzdir + tz;\r
 707     end;\r
 708 \r
 709     assignfile(t,tz);\r
 710     {$i-}reset(t);{$i+}\r
 711     if (ioresult = 0) then begin\r
 712       closefile(t);\r
 713       result := tz;\r
 714       exit;\r
 715     end;\r
 716 \r
 717   end;\r
 718   {$endif}\r
 719   \r
 720   assignfile(t,'/etc/localtime');\r
 721   {$i-}reset(t);{$i+}\r
 722   if (ioresult = 0) then begin\r
 723     closefile(t);\r
 724     result := '/etc/localtime';\r
 725     exit;\r
 726   end;\r
 727 \r
 728   assignfile(t,'/etc/timezone');\r
 729 \r
 730   s := '';\r
 731   {$i-}reset(t);{$i+}\r
 732   if (ioresult = 0) then begin\r
 733     readln(t,s);\r
 734     closefile(t);\r
 735     if (s <> '') then begin\r
 736       result := '/usr/share/zoneinfo/'+s;\r
 737       exit;\r
 738     end;\r
 739   end;\r
 740 end;\r
 741 \r
 742 type\r
 743   dvar=array[0..65535] of byte;\r
 744   pdvar=^dvar;\r
 745 \r
 746 var\r
 747   tzcache:pdvar;\r
 748   tzsize:integer;\r
 749 \r
 750 procedure tzinvalidate;\r
 751 begin\r
 752   if assigned(tzcache) then freemem(tzcache);\r
 753   tzcache := nil;\r
 754   tzsize := 0;\r
 755   tzfile := '';\r
 756   gettimezone;\r
 757 end;\r
 758 \r
 759 \r
 760 function tzgetoffsetforts(ts:tunixtimeint):integer;\r
 761 var\r
 762   f:file;\r
 763   buf:pdvar;\r
 764   fs:integer;\r
 765   ofs,ofs2:integer;\r
 766   mode64:boolean;\r
 767   has64:boolean;\r
 768   a,index:integer;\r
 769   //tzstrofs:integer;\r
 770   t:int64;\r
 771   tzh_ttisgmtcnt:integer;\r
 772   tzh_ttisstdcnt:integer;\r
 773   tzh_leapcnt:integer;\r
 774   tzh_timecnt:integer;\r
 775   tzh_typecnt:integer;\r
 776   tzh_charcnt:integer;\r
 777 \r
 778 \r
 779 function getint:integer;\r
 780 begin\r
 781   if (ofs < 0) or ((ofs + 4) > fs) then raise exception.create('getint');\r
 782   result := (buf[ofs] shl 24) + (buf[ofs+1] shl 16) + (buf[ofs+2] shl 8) + buf[ofs+3];\r
 783   inc(ofs,4);\r
 784 end;\r
 785 \r
 786 function getint64:int64;\r
 787 begin\r
 788   if (ofs < 0) or ((ofs + 8) > fs) then raise exception.create('getint64');\r
 789   result := int64(getint) shl 32;\r
 790   inc(result,cardinal(getint));\r
 791 end;\r
 792 \r
 793 \r
 794 function getbyte:byte;\r
 795 begin\r
 796   if (ofs < 0) or ((ofs + 1) > fs) then raise exception.create('getbyte');\r
 797   result := buf[ofs];\r
 798   inc(ofs);\r
 799 end;\r
 800 \r
 801 begin\r
 802   result := 0;\r
 803   tzerror := true;\r
 804 \r
 805   if not assigned(tzcache) then begin\r
 806 \r
 807     if (tzfile = '') then tzfile := tzgetfilename;\r
 808 \r
 809     if (tzfile = '') then exit;\r
 810 \r
 811     assignfile(f,tzfile);\r
 812     filemode := 0;\r
 813     {$i-}reset(f,1);{$i+}\r
 814     if (ioresult <> 0) then begin\r
 815       exit;\r
 816     end;\r
 817     tzsize := filesize(f);\r
 818     if (tzsize > 65536) then tzsize := 65536;\r
 819     getmem(tzcache,tzsize);\r
 820     blockread(f,tzcache^,tzsize);\r
 821     closefile(f);\r
 822   end;\r
 823   fs := tzsize;\r
 824   buf := tzcache;\r
 825   ofs := 0;\r
 826   mode64 := false;\r
 827 \r
 828  try\r
 829    repeat\r
 830      if (getint <> $545a6966) then exit; // 'TZif'\r
 831      has64 := getbyte >= $32; //  '2'\r
 832 \r
 833      inc(ofs,15);\r
 834 \r
 835      tzh_ttisgmtcnt := getint;\r
 836      tzh_ttisstdcnt := getint;\r
 837      tzh_leapcnt := getint;\r
 838      tzh_timecnt := getint;\r
 839      tzh_typecnt := getint;\r
 840      tzh_charcnt := getint;\r
 841 \r
 842      if mode64 or (not has64) then break;\r
 843      inc(ofs, 5 * tzh_timecnt + 6 * tzh_typecnt + 8 * tzh_leapcnt + tzh_ttisstdcnt + tzh_ttisgmtcnt + tzh_charcnt);\r
 844      mode64 := true;\r
 845    until false;\r
 846    index := 0;\r
 847 \r
 848    if (tzh_timecnt < 0) or (tzh_timecnt > fs) then raise exception.create('tzh_timecnt');\r
 849    ofs2 := ofs;\r
 850 \r
 851    for a := 0 to tzh_timecnt -1 do begin\r
 852      if mode64 then t := getint64 else t := getint;\r
 853      if (t > ts) then begin\r
 854        index := a - 1;\r
 855        break;\r
 856      end;\r
 857      if (a = tzh_timecnt -1) and (ts >= t) then index := a;\r
 858    end;\r
 859    ofs := ofs2 + tzh_timecnt * (1 + ord(mode64)) * 4;\r
 860 \r
 861    if (cardinal(ofs + index) >= fs) or (index < 0) then raise exception.create('index');\r
 862    index := buf[ofs+index];\r
 863    inc(ofs,tzh_timecnt);\r
 864 \r
 865    if (index >= tzh_typecnt) then raise exception.create('type');\r
 866    ofs2 := ofs;\r
 867   // writeln('ofs2 ',inttohex(ofs2,8));\r
 868    inc(ofs,6 * index);\r
 869    result := getint;\r
 870 \r
 871    //tzisdst := getbyte;\r
 872 \r
 873   //the abbreviation string\r
 874   { tzstrofs := getbyte;\r
 875    tzstr := '';\r
 876    ofs := ofs2 + 6 * tzh_typecnt;\r
 877    inc(ofs, tzstrofs);\r
 878 \r
 879    repeat\r
 880      a := getbyte;\r
 881      if (a <> 0) then tzstr := tzstr + chr(a);\r
 882    until (a = 0); }\r
 883 \r
 884    tzerror := false;\r
 885  except\r
 886 \r
 887  end;\r
 888 end;\r
 889 \r
 890 function tzgetoffset:integer;\r
 891 begin\r
 892   tzgetoffsetforts(unixtimeint);\r
 893 end;\r
 894 \r
 895 \r
 896 {$endif}\r
 897 \r
 898 \r
 899 procedure gettimezone;\r
 900 var\r
 901   {$ifdef UNIX}\r
 902     {$ifndef ver1_9_4}\r
 903       {$ifndef ver1_0}\r
 904         {$define above194}\r
 905       {$endif}\r
 906     {$endif}\r
 907     {$ifndef above194}\r
 908       hh,mm,ss:word;\r
 909     {$endif}\r
 910   {$endif}\r
 911   l:integer;\r
 912 begin\r
 913   {$ifdef UNIX}\r
 914     {$ifdef above194}\r
 915       timezone := tzgetoffset;\r
 916       //freepascal tzseconds is not 2038 safe\r
 917     {$else}\r
 918       gettime(hh,mm,ss);\r
 919       timezone := (longint(hh) * 3600 + mm * 60 + ss) - (unixtimeint mod 86400);\r
 920     {$endif}\r
 921   {$else}\r
 922   timezone := round((now-now_utc)*86400);\r
 923   {$endif}\r
 924 \r
 925   while timezone > 50400 do dec(timezone,86400);\r
 926   while timezone < -50400 do inc(timezone,86400);\r
 927 \r
 928   if timezone >= 0 then timezonestr := '+' else timezonestr := '-';\r
 929   l := abs(timezone) div 60;\r
 930   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
 931 end;\r
 932 \r
 933 function timestrshort(i:tunixtimeint):string;\r
 934 const\r
 935   weekday:array[0..6] of string[4]=('Thu','Fri','Sat','Sun','Mon','Tue','Wed');\r
 936   month:array[0..11] of string[4]=('Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct','Nov','Dec');\r
 937 var\r
 938   y,m,d,h,min,sec,ms:word;\r
 939   t:tdatetime;\r
 940 begin\r
 941   t := unixtoole(i+timezone);\r
 942   decodedate(t,y,m,d);\r
 943   decodetime(t,h,min,sec,ms);\r
 944   result := weekday[(i+timezone) div 86400 mod 7]+' '+month[m-1]+' '+inttostr(d)+' '+\r
 945   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
 946   inttostr(y);\r
 947 end;\r
 948 \r
 949 function timestring(i:tunixtimeint):string;\r
 950 const\r
 951   weekday:array[0..6] of string[10]=('Thursday','Friday','Saturday','Sunday','Monday','Tuesday','Wednesday');\r
 952   month:array[0..11] of string[10]=('January','February','March','April','May','June','July','August','September','October','November','December');\r
 953 var\r
 954   y,m,d,h,min,sec,ms:word;\r
 955   t:tdatetime;\r
 956 begin\r
 957   t := unixtoole(i+timezone);\r
 958   decodedate(t,y,m,d);\r
 959   decodetime(t,h,min,sec,ms);\r
 960   result := weekday[(i+timezone) div 86400 mod 7]+' '+month[m-1]+' '+inttostr(d)+' '+inttostr(y)+' -- '+\r
 961   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
 962   timezonestr;\r
 963 end;\r
 964 \r
 965 function timestriso(i:tunixtimeint):string;\r
 966 var\r
 967   y,m,d,h,min,sec,ms:word;\r
 968   t:tdatetime;\r
 969 begin\r
 970   t := unixtoole(i+timezone);\r
 971   decodedate(t,y,m,d);\r
 972   decodetime(t,h,min,sec,ms);\r
 973   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
 974 end;\r
 975 \r
 976 function timestrisoutc(i:float):string;\r
 977 var\r
 978   y,m,d,h,min,sec,ms:word;\r
 979   t:tdatetime;\r
 980   fr:float;\r
 981 begin\r
 982   t := unixtoole(i);\r
 983   decodedate(t,y,m,d);\r
 984   decodetime(t,h,min,sec,ms);\r
 985   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
 986   fr := frac(i);\r
 987 \r
 988   result := result + '.'+\r
 989   inttostr(trunc(fr*10) mod 10)+\r
 990   inttostr(trunc(fr*100) mod 10)+\r
 991   inttostr(trunc(fr*1000) mod 10)+\r
 992   inttostr(trunc(fr*10000) mod 10)+\r
 993   inttostr(trunc(fr*100000) mod 10)+\r
 994   inttostr(trunc(fr*1000000) mod 10)+'Z';\r
 995 \r
 996 end;\r
 997 \r
 998 procedure beginhightimerrate;\r
 999 begin\r
1000   {$ifdef mswindows}timebeginperiod(1);{$endif}\r
1001 end;\r
1002 \r
1003 procedure endhightimerrate;\r
1004 begin\r
1005   {$ifdef mswindows}timeendperiod(1);{$endif}\r
1006 end;\r
1007 \r
1008 procedure init;\r
1009 begin\r
1010   {$ifdef btimehighrate}beginhightimerrate;{$endif}\r
1011   fillchar(mmtime_driftavg,sizeof(mmtime_driftavg),0);\r
1012   settimebias := 0;\r
1013   gettimezone;\r
1014   unixtime := unixtimeint;\r
1015   irctime := irctimeint;\r
1016 end;\r
1017 \r
1018 initialization init;\r
1019 \r
1020 end.\r