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 has several functions for getting unix and monotonic time and UTC offset on both windows and linux/unix\r
   7 \r
   8 this unit aims to work on delphi 6 and later, both x86 and x64, on win95 and later\r
   9 delphi 5 may work (untested).\r
  10 as well as freepascal on linux x86 and x64 and freebsd x64 (tested), windows, and other unixes (untested)\r
  11 \r
  12 provided functions. all are available on both windows and linux/unix:\r
  13 - unix timestamp as a (double or extended) float or integer: unixtimefloat, unixtimeint\r
  14 - monotonic timestamp as float: monotimefloat, wintimefloat (both are equivalent)\r
  15 - _coarse versions of the floats, which can be faster, and precision in the milliseconds.\r
  16 - btime_gettime: a unified function like clock_gettime. less reliant on floats.\r
  17 - tzgetoffset returns the UTC offset (timezone) in seconds\r
  18 \r
  19 - on windows, it provides the legacy function gettimeofday (on unix, use the one provided by the OS units)\r
  20 \r
  21 other things in the interface are often more implementation specific, there for legacy reasons, and not guaranteed stable\r
  22 \r
  23 this unit should be 2038 safe:\r
  24 - seconds are handled as 64 bits\r
  25 - on 32 bits linux, it uses clock_gettime64 if available \r
  26 - for getting the UTC offset on unix, this unit does its own, 64 bits aware, parsing of the zoneinfo file \r
  27 - tested with clock set after 2038\r
  28 }\r
  29 \r
  30 \r
  31 unit btime;\r
  32 {$ifdef fpc}\r
  33   {$mode delphi}\r
  34 {$endif}\r
  35 \r
  36 {$include lcoreconfig.inc}\r
  37 \r
  38 interface\r
  39 \r
  40 {$ifdef mswindows}\r
  41 uses\r
  42   ltimevalstuff;\r
  43 {$endif}\r
  44 \r
  45 {$ifdef linux}\r
  46 uses\r
  47   linux,syscall;\r
  48 {$endif}\r
  49 \r
  50 {$ifdef freebsd}\r
  51 uses\r
  52   freebsd;\r
  53 {$endif}\r
  54 \r
  55 {$ifdef FPC_HAS_TYPE_EXTENDED}{$define has_extended}{$endif}\r
  56 {$ifndef fpc}{$ifdef cpu386}{$define has_extended}{$endif}{$endif}\r
  57 \r
  58 type\r
  59   {$ifdef has_extended}\r
  60   float=extended;\r
  61   {$else}\r
  62   float=double;\r
  63   {$endif}\r
  64   tunixtimeint=int64;\r
  65 \r
  66 const\r
  67   colorburst=39375000/11;  {3579545.4545....}\r
  68 \r
  69   {\r
  70   CLOCK_MONOTONIC is the standard monotonic time offered by the OS, it may or may not include suspend time\r
  71   CLOCK_BOOTTIME includes suspend time.\r
  72   CLOCK_UPTIME excludes suspend time.\r
  73   }\r
  74 \r
  75   {$ifdef mswindows}\r
  76   CLOCK_REALTIME=0;\r
  77   CLOCK_MONOTONIC=1;\r
  78   CLOCK_REALTIME_COARSE=2;\r
  79   CLOCK_MONOTONIC_COARSE=3;\r
  80   CLOCK_BOOTTIME=CLOCK_MONOTONIC;  //GetTickCount\r
  81   CLOCK_UPTIME=4;                  //QueryUnbiasedInterruptTime, fallback to QueryPerformanceCounter\r
  82   CLOCK_UPTIME_FAST=CLOCK_UPTIME;\r
  83   {$endif}\r
  84 \r
  85   {$ifdef linux}\r
  86   CLOCK_REALTIME=linux.CLOCK_REALTIME;\r
  87   CLOCK_MONOTONIC=linux.CLOCK_MONOTONIC;\r
  88   CLOCK_REALTIME_COARSE=linux.CLOCK_REALTIME_COARSE;\r
  89   CLOCK_MONOTONIC_COARSE=linux.CLOCK_MONOTONIC_COARSE;\r
  90   CLOCK_BOOTTIME=7; //linux.CLOCK_BOOTTIME - constant missing in freepascal\r
  91   CLOCK_UPTIME=CLOCK_MONOTONIC;\r
  92   CLOCK_UPTIME_FAST=CLOCK_MONOTONIC_COARSE;\r
  93   {$endif}\r
  94 \r
  95   {$ifdef freebsd}\r
  96   CLOCK_REALTIME=freebsd.CLOCK_REALTIME;\r
  97   CLOCK_MONOTONIC=freebsd.CLOCK_MONOTONIC;\r
  98   CLOCK_REALTIME_COARSE=freebsd.CLOCK_REALTIME_FAST;\r
  99   CLOCK_MONOTONIC_COARSE=freebsd.CLOCK_MONOTONIC_FAST;\r
 100   CLOCK_BOOTTIME=CLOCK_MONOTONIC;\r
 101   CLOCK_UPTIME=freebsd.CLOCK_UPTIME;\r
 102   CLOCK_UPTIME_FAST=freebsd.CLOCK_UPTIME_FAST;\r
 103   {$endif}\r
 104 \r
 105   {$ifdef darwin}\r
 106   CLOCK_REALTIME=0;      //values taken from darwin libc time.h\r
 107   CLOCK_MONOTONIC=6;\r
 108   CLOCK_REALTIME_COARSE=CLOCK_REALTIME;   //darwin lacks these or equivalents\r
 109   CLOCK_MONOTONIC_COARSE=CLOCK_MONOTONIC;\r
 110   CLOCK_BOOTTIME=CLOCK_MONOTONIC;\r
 111   CLOCK_UPTIME_RAW=8;\r
 112   CLOCK_UPTIME=CLOCK_UPTIME_RAW;\r
 113   CLOCK_UPTIME_FAST=CLOCK_UPTIME_RAW;\r
 114   {$endif}\r
 115 \r
 116   CLOCK_REALTIME_FAST=CLOCK_REALTIME_COARSE;\r
 117   CLOCK_MONOTONIC_FAST=CLOCK_MONOTONIC_COARSE;\r
 118 \r
 119 \r
 120 var\r
 121   timezone:integer;\r
 122   timezonestr:string;\r
 123   irctime,unixtime:tunixtimeint;\r
 124   tickcount:integer;\r
 125   settimebias:tunixtimeint;\r
 126   performancecountfreq:int64;\r
 127   performancecountstep:float;\r
 128 \r
 129   btimenowin8:boolean;\r
 130 \r
 131 function irctimefloat:float;\r
 132 function irctimeint:tunixtimeint;\r
 133 \r
 134 //unix timestamp (UTC) float seconds\r
 135 function unixtimefloat:float;\r
 136 function unixtimeint:tunixtimeint;\r
 137 \r
 138 //monotonic float seconds\r
 139 function monotimefloat:float;\r
 140 \r
 141 //coarse float seconds - usually faster, but a resolution in the milliseconds\r
 142 function unixtimefloat_coarse:float;\r
 143 function monotimefloat_coarse:float;\r
 144 \r
 145 //float versions of CLOCK_BOOTTIME and CLOCK_UPTIME\r
 146 function boottimefloat:float;\r
 147 function uptimefloat:float;\r
 148 \r
 149 //monotonic (alias, old function name)\r
 150 function wintimefloat:float;\r
 151 \r
 152 //get localtime vs UTC offset in seconds\r
 153 function tzgetoffset:integer;\r
 154 \r
 155 procedure settime(newtime:tunixtimeint);\r
 156 procedure gettimezone;\r
 157 procedure timehandler;\r
 158 procedure init;\r
 159 \r
 160 function timestring(i:tunixtimeint):string;      // Wednesday August 15 2012 -- 16:21:09 +02:00\r
 161 function timestrshort(i:tunixtimeint):string;    // Wed Aug 15 16:21:09 2012\r
 162 function timestriso(i:tunixtimeint):string;      // 2012-08-15 16:21:09\r
 163 function timestrisoutc(i:float):string;          // 2012-08-15T14:21:09.255553Z\r
 164 \r
 165 procedure beginhightimerrate;\r
 166 procedure endhightimerrate;\r
 167 \r
 168 procedure tzinvalidate;\r
 169 \r
 170 {$ifdef unix}\r
 171 function tzgetoffsetforts(ts:tunixtimeint):integer;\r
 172 {$endif}\r
 173 \r
 174 {$ifdef mswindows}\r
 175 function unixtimefloat_systemtime:float;\r
 176 {$endif}\r
 177 \r
 178 function oletounixfloat(t:float):float;\r
 179 function oletounix(t:tdatetime):tunixtimeint;\r
 180 function unixtoole(i:float):tdatetime;\r
 181 \r
 182 {$ifdef mswindows}\r
 183 function mmtimefloat:float;\r
 184 function mmtimeint64:int64;\r
 185 function qpctimefloat:float;\r
 186 {$endif}\r
 187 \r
 188 {$ifdef mswindows}\r
 189 function gettimeofday(var tv:ttimeval):integer;\r
 190 {$endif}\r
 191 \r
 192 \r
 193 const\r
 194   mmtime_driftavgsize=32;\r
 195   mmtime_warmupnum=4;\r
 196   mmtime_warmupcyclelength=15;\r
 197 var\r
 198   //this flag is to be set when btime has been running long enough to stabilise\r
 199   warmup_finished:boolean;\r
 200 \r
 201   timefloatbias:float;\r
 202   ticks_freq:float=0;\r
 203   ticks_freq2:float=0;\r
 204   ticks_freq_known:boolean=false;\r
 205   lastunixtimefloat:float=0;\r
 206   lastsynctime:float=0;\r
 207   lastsyncbias:float=0;\r
 208 \r
 209   mmtime_last:integer=0;\r
 210   mmtime_wrapadd:int64;\r
 211   mmtime_lastsyncmm:float=0;\r
 212   mmtime_lastsyncqpc:float=0;\r
 213   mmtime_drift:float=1;\r
 214   mmtime_lastresult:float;\r
 215   mmtime_nextdriftcorrection:float;\r
 216   mmtime_driftavg:array[0..mmtime_driftavgsize] of float;\r
 217   mmtime_synchedqpc:boolean;\r
 218 \r
 219   mmtime_prev_drift:float;\r
 220   mmtime_prev_lastsyncmm:float;\r
 221   mmtime_prev_lastsyncqpc:float;\r
 222 \r
 223   gettime64_nosupport_cached:boolean;\r
 224   coarse_nosupport_cached:boolean;\r
 225 \r
 226 type\r
 227   //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
 228   //tbtimespec can't be changed because it is passed as-is to clock_gettime64\r
 229   tbtimespec=packed record\r
 230     tv_sec:int64;\r
 231     tv_nsec:int64;\r
 232   end;\r
 233   pbtimespec=^tbtimespec;\r
 234 \r
 235 \r
 236 //on unix, btime_gettime is the "inner" function that calls the actual OS/library functions, and other functions in btime call it\r
 237 //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
 238 function btime_gettime(clockid:integer;tp:pbtimespec):integer;\r
 239 \r
 240 implementation\r
 241 uses\r
 242   {$ifdef UNIX}\r
 243     {$ifdef VER1_0}\r
 244       linux,\r
 245     {$else}\r
 246       baseunix,unix,unixutil,sockets, {unixutil and sockets needed by unixstuff.inc on some compiler versions}\r
 247     {$endif}\r
 248   {$else}\r
 249     windows,unitsettc,mmsystem,\r
 250   {$endif}\r
 251   sysutils;\r
 252 \r
 253   {$include unixstuff.inc}\r
 254 \r
 255 \r
 256 const\r
 257   daysdifference=25569;\r
 258 \r
 259 function oletounixfloat(t:float):float;\r
 260 begin\r
 261   t := (t - daysdifference) * 86400;\r
 262   result := t;\r
 263 end;\r
 264 \r
 265 function oletounix(t:tdatetime):tunixtimeint;\r
 266 begin\r
 267   result := round(oletounixfloat(t));\r
 268 end;\r
 269 \r
 270 function unixtoole(i:float):tdatetime;\r
 271 begin\r
 272   result := ((i)/86400)+daysdifference;\r
 273 end;\r
 274 \r
 275 {$ifdef unix}\r
 276 {-----------------------------------------*nix/freepascal code to read time }\r
 277 \r
 278 {$ifdef linux}{$define have_clock_gettime}{$endif}\r
 279 {$ifdef freebsd}{$define have_clock_gettime}{$endif}\r
 280 \r
 281 {$ifdef linux}\r
 282   {$ifdef cpu386}{$define use_syscall_gettime64}{$endif}\r
 283   {$ifdef cpu32}{$define use_syscall_gettime64}{$endif}\r
 284 \r
 285   {$ifdef use_syscall_gettime64}\r
 286 const\r
 287   clock_gettime64=403;\r
 288   {$endif}\r
 289 {$endif} //linux\r
 290 \r
 291 \r
 292 \r
 293 {$ifdef darwin} {mac OS X}\r
 294   type\r
 295     tmach_timebase_info = packed record\r
 296       numer: cardinal;\r
 297       denom: cardinal;\r
 298     end;\r
 299     pmach_timebase_info = ^tmach_timebase_info;\r
 300 \r
 301     function mach_absolute_time: int64; cdecl; external;\r
 302     function mach_timebase_info(info: pmach_timebase_info): integer; cdecl; external;\r
 303 \r
 304   var\r
 305     timebase_info: tmach_timebase_info;\r
 306 {$endif} //darwin\r
 307 \r
 308 \r
 309 function btime_gettime(clockid:integer;tp:pbtimespec):integer;\r
 310 var\r
 311 {$ifdef have_clock_gettime}\r
 312   ts: ttimespec;\r
 313 {$endif}\r
 314   tv: ttimeval;\r
 315 {$ifdef darwin}\r
 316   nanos:int64;\r
 317   nanosf:extended;\r
 318 {$endif}\r
 319 \r
 320 begin\r
 321   result := -1; //error\r
 322 \r
 323   {$ifdef darwin}\r
 324   if (clockid = CLOCK_MONOTONIC) or (clockid = CLOCK_MONOTONIC_COARSE) then begin\r
 325     if timebase_info.denom = 0 then begin\r
 326       mach_timebase_info(@timebase_info);\r
 327     end;\r
 328     if (timebase_info.denom > 0) then begin\r
 329       nanos := mach_absolute_time;\r
 330       if (nanos > 0) then begin\r
 331         result := 0; //indicate success\r
 332         if (timebase_info.denom > 10) then begin\r
 333           //on powerpc mac, numer and denom are large numbers such as 1000000000 and 33333335, and extended is available\r
 334           nanosf := nanos;\r
 335           nanosf := (nanosf * timebase_info.numer) / timebase_info.denom;\r
 336           nanos := trunc(nanosf);\r
 337         end else begin\r
 338           //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
 339           nanos := nanos div timebase_info.denom;\r
 340           nanos := nanos * timebase_info.numer;\r
 341         end;\r
 342         tp.tv_sec := nanos div 1000000000;\r
 343         tp.tv_nsec := nanos mod 1000000000;\r
 344         exit;\r
 345       end;\r
 346     end;\r
 347   end;\r
 348   {$endif} //darwin\r
 349 \r
 350   if (coarse_nosupport_cached) then begin\r
 351     if (clockid = CLOCK_REALTIME_COARSE) then clockid := CLOCK_REALTIME;\r
 352     if (clockid = CLOCK_MONOTONIC_COARSE) then clockid := CLOCK_MONOTONIC;\r
 353   end;\r
 354 \r
 355   {$ifdef use_syscall_gettime64}\r
 356   //don't do this for monotonic for performance reasons\r
 357   //the clock_gettime call below has the potential to be handled by libc, and then it is faster\r
 358   //also if it failed, don't call it again to avoid slowdown of doing two calls every time\r
 359   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
 360     result := do_syscall(clock_gettime64,clockid,tsysparam(tp));\r
 361 \r
 362     if ((clockid = CLOCK_REALTIME) or (clockid = CLOCK_REALTIME_COARSE)) and (result <> 0) then gettime64_nosupport_cached := true;\r
 363 \r
 364     if (result = 0) then exit;\r
 365   end;\r
 366   {$endif}\r
 367 \r
 368   {$ifdef have_clock_gettime}\r
 369   result := clock_gettime(clockid, @ts);\r
 370   if (result <> 0) then begin\r
 371     //fallback\r
 372     if (clockid = CLOCK_REALTIME_COARSE) then begin\r
 373       coarse_nosupport_cached := true;\r
 374       result := clock_gettime(CLOCK_REALTIME, @ts);\r
 375     end else\r
 376     if (clockid = CLOCK_MONOTONIC_COARSE) then begin\r
 377       coarse_nosupport_cached := true;\r
 378       result := clock_gettime(CLOCK_MONOTONIC, @ts);\r
 379     end;\r
 380   end;\r
 381   if (result = 0) then begin\r
 382     tp.tv_sec := ts.tv_sec;\r
 383     tp.tv_nsec := ts.tv_nsec;\r
 384 \r
 385     {$ifndef cpu64}\r
 386     if (tp.tv_sec < -1) then inc(tp.tv_sec, $100000000);\r
 387     {$endif}\r
 388 \r
 389     exit;\r
 390   end;\r
 391   {$endif} //have_clock_gettime\r
 392 \r
 393   result := gettimeofday(tv);\r
 394   if (result = 0) then begin\r
 395     tp.tv_sec := tv.tv_sec;\r
 396     tp.tv_nsec := tv.tv_usec * 1000;\r
 397 \r
 398     {$ifndef cpu64}\r
 399     if (tp.tv_sec < -1) then inc(tp.tv_sec, $100000000);\r
 400     {$endif}\r
 401   end;\r
 402 end;\r
 403 \r
 404 \r
 405 function unixtimefloat:float;\r
 406 var\r
 407   ts:tbtimespec;\r
 408 begin\r
 409   btime_gettime(CLOCK_REALTIME, @ts);\r
 410   //doing the below as a division causes a bug in fpc 3.2.0 x64, where the result becomes single precision\r
 411   result := ts.tv_sec + (ts.tv_nsec * 0.000000001);\r
 412 end;\r
 413 \r
 414 \r
 415 function monotimefloat:float;\r
 416 var\r
 417   ts:tbtimespec;\r
 418 begin\r
 419   btime_gettime(CLOCK_MONOTONIC, @ts);\r
 420   result := ts.tv_sec + (ts.tv_nsec * 0.000000001);\r
 421 end;\r
 422 \r
 423 \r
 424 function unixtimefloat_coarse:float;\r
 425 var\r
 426   ts:tbtimespec;\r
 427 begin\r
 428   btime_gettime(CLOCK_REALTIME_COARSE, @ts);\r
 429   result := ts.tv_sec + (ts.tv_nsec * 0.000000001);\r
 430 end;\r
 431 \r
 432 \r
 433 function monotimefloat_coarse:float;\r
 434 var\r
 435   ts:tbtimespec;\r
 436 begin\r
 437   btime_gettime(CLOCK_MONOTONIC_COARSE, @ts);\r
 438   result := ts.tv_sec + (ts.tv_nsec * 0.000000001);\r
 439 end;\r
 440 \r
 441 \r
 442 function boottimefloat:float;\r
 443 var\r
 444   ts:tbtimespec;\r
 445 begin\r
 446   btime_gettime(CLOCK_BOOTTIME, @ts);\r
 447   result := ts.tv_sec + (ts.tv_nsec * 0.000000001);\r
 448 end;\r
 449 \r
 450 \r
 451 function uptimefloat:float;\r
 452 var\r
 453   ts:tbtimespec;\r
 454 begin\r
 455   btime_gettime(CLOCK_UPTIME, @ts);\r
 456   result := ts.tv_sec + (ts.tv_nsec * 0.000000001);\r
 457 end;\r
 458 \r
 459 \r
 460 function unixtimeint:tunixtimeint;\r
 461 var\r
 462   ts:tbtimespec;\r
 463 begin\r
 464   btime_gettime(CLOCK_REALTIME,@ts);\r
 465   result := ts.tv_sec;\r
 466 end;\r
 467 \r
 468 {------------------------------ end of *nix/freepascal section}\r
 469 \r
 470 {$endif}  //unix\r
 471 \r
 472 {$ifdef mswindows}\r
 473 {------------------------------ windows/delphi code to read time}\r
 474 \r
 475 \r
 476 procedure tzinvalidate;\r
 477 begin\r
 478   gettimezone;\r
 479 end;\r
 480 \r
 481 \r
 482 var\r
 483   GetTickCount64:function:int64; stdcall;\r
 484   gettickcount64_inited:boolean;\r
 485 \r
 486 procedure init_gettickcount64;\r
 487 var\r
 488   dllhandle:thandle;\r
 489 begin\r
 490   gettickcount64_inited := true;\r
 491   dllhandle := loadlibrary('kernel32.dll');\r
 492   if (dllhandle <> 0) then begin\r
 493     GetTickCount64 := getprocaddress(dllhandle,'GetTickCount64');\r
 494   end;\r
 495 end;\r
 496 \r
 497 \r
 498 \r
 499 function mmtimeint64:int64;\r
 500 var\r
 501   i:int64;\r
 502 begin\r
 503   if not gettickcount64_inited then init_gettickcount64;\r
 504   if assigned(GetTickCount64) then begin\r
 505     result := GetTickCount64;\r
 506   end else begin\r
 507     i := gettickcount;\r
 508     if i < mmtime_last then begin\r
 509       mmtime_wrapadd := mmtime_wrapadd + $100000000;\r
 510     end;\r
 511     mmtime_last := i;\r
 512     result := mmtime_wrapadd + i;\r
 513   end;\r
 514 end;\r
 515 \r
 516 \r
 517 {\r
 518 time float: gettickcount\r
 519 resolution: 9x: ~55 ms NT: 1/64th of a second\r
 520 guarantees: continuous without any jumps\r
 521 frequency base: same as system clock.\r
 522 epoch: system boot\r
 523 }\r
 524 function mmtimefloat:float;\r
 525 var\r
 526   temp:float;\r
 527 begin\r
 528   result := mmtimeint64 * 0.001;\r
 529 \r
 530   if (ticks_freq <> 0) and ticks_freq_known then begin\r
 531     {the value we get is rounded to 1 ms, but the ticks are not a multiple of 1 ms\r
 532     this makes the value noisy. use the known ticks frequency to restore the original value}\r
 533     temp := int((result / ticks_freq)+0.5) * ticks_freq;\r
 534 \r
 535     {if the known ticks freq is wrong (can happen), disable the un-rounding behavior\r
 536     this will be a bit less accurate but it prevents problems}\r
 537     if abs(temp - result) > 0.002 then begin\r
 538       ticks_freq := 0;\r
 539     end else result := temp;\r
 540   end;\r
 541 end;\r
 542 \r
 543 var\r
 544   win_version_known:boolean;\r
 545   win_isnt:boolean;\r
 546   win_ver_major:integer;\r
 547   win_ver_minor:integer;\r
 548 \r
 549 procedure init_win_version;\r
 550 var\r
 551   o:tosversioninfo;\r
 552 begin\r
 553   if not win_version_known then begin\r
 554     win_version_known := true;\r
 555     fillchar(o,sizeof(o),0);\r
 556     o.dwOSVersionInfoSize := sizeof(o);\r
 557     getversionex(o);\r
 558     win_isnt := o.dwPlatformId = VER_PLATFORM_WIN32_NT;\r
 559     win_ver_major := o.dwMajorVersion;\r
 560     win_ver_minor := o.dwMinorVersion;\r
 561   end;\r
 562 end;\r
 563 \r
 564 procedure measure_ticks_freq;\r
 565 var\r
 566   f,g:float;\r
 567 \r
 568   adjust1,adjust2:cardinal;\r
 569   adjustbool:longbool;\r
 570   win8_or_later:boolean;\r
 571 begin\r
 572   if (performancecountfreq = 0) then qpctimefloat;\r
 573   ticks_freq_known := false;\r
 574   settc;\r
 575   f := mmtimefloat;\r
 576   repeat g := mmtimefloat until g > f;\r
 577   unsettc;\r
 578   f := g - f;\r
 579 \r
 580   init_win_version;\r
 581 \r
 582   ticks_freq2 := f;\r
 583   mmtime_synchedqpc := false;\r
 584 \r
 585   if (win_isnt and (win_ver_major >= 5)) then begin\r
 586     {windows 2000 and later: query tick rate from OS in 100 ns units\r
 587     typical rates: XP: 156250 or 100144, windows 7: 156001}\r
 588     if GetSystemTimeAdjustment(adjust1,adjust2,adjustbool) then begin\r
 589       ticks_freq := adjust1 / 10000000.0;\r
 590       ticks_freq_known := true;\r
 591       mmtime_synchedqpc := false;\r
 592 \r
 593       //windows 8/10/11, 10 MHz time source is invariant TSC. add 64 Hz check for safety.\r
 594       //with manifest, windows 10/11 major.minor will be 10.0 \r
 595       win8_or_later := ((win_ver_major = 6) and (win_ver_minor >= 2)) or (win_ver_major = 10);\r
 596       if (win8_or_later and (performancecountfreq = 10000000) and (adjust1 = 156250)) then begin\r
 597         mmtime_synchedqpc := true;\r
 598       end;\r
 599     end;\r
 600   end;\r
 601 \r
 602   {9x}\r
 603   if (performancecountfreq = 1193182) and (f >= 0.050) and (f <= 0.060) then begin\r
 604     ticks_freq_known := true;\r
 605     ticks_freq := 65536 / (colorburst / 3);\r
 606     mmtime_synchedqpc := true;\r
 607   end;\r
 608   ticks_freq_known := true;\r
 609   if ticks_freq <> 0 then ticks_freq2 := ticks_freq;\r
 610 //  writeln(formatfloat('0.000000',ticks_freq));\r
 611 end;\r
 612 \r
 613 {\r
 614 time float: QueryPerformanceCounter\r
 615 resolution: <1us\r
 616 guarantees: can have forward jumps depending on hardware. can have forward and backwards jitter on dual core.\r
 617 frequency base: on NT, not the system clock, drifts compared to it.\r
 618 epoch: system boot\r
 619 }\r
 620 function qpctimefloat:float;\r
 621 var\r
 622   i64:int64;\r
 623 begin\r
 624   if performancecountfreq = 0 then begin\r
 625     QueryPerformancefrequency(performancecountfreq);\r
 626     performancecountstep := 1.0 / performancecountfreq;\r
 627   end;\r
 628   queryperformancecounter(i64);\r
 629   result := i64 * performancecountstep;\r
 630 end;\r
 631 \r
 632 {\r
 633 time float: QPC locked to gettickcount\r
 634 resolution: <1us\r
 635 guarantees: continuous without any jumps\r
 636 frequency base: same as system clock.\r
 637 epoch: system boot\r
 638 }\r
 639 \r
 640 //function mmqpctimefloat:float;\r
 641 function monotimefloat:float;\r
 642 const\r
 643   maxretries=5;\r
 644   margin=0.002;\r
 645 var\r
 646 {  jump:float;}\r
 647   mm,f,qpc,newdrift:float;\r
 648   qpcjumped:boolean;\r
 649   a,b:integer;\r
 650 {  retrycount:integer;}\r
 651 begin\r
 652   if not ticks_freq_known then measure_ticks_freq;\r
 653 {  retrycount := maxretries;}\r
 654 \r
 655   qpc := qpctimefloat;\r
 656   mm := mmtimefloat;\r
 657   f := (qpc - mmtime_lastsyncqpc) * mmtime_drift + mmtime_lastsyncmm;\r
 658   //writeln('XXXX ',formatfloat('0.000000',qpc-mm));\r
 659   qpcjumped := ((f-mm) > ticks_freq2+margin) or ((f-mm) < -margin);\r
 660 //  if qpcjumped then writeln('qpc jumped ',(f-mm));\r
 661   if ((qpc > mmtime_nextdriftcorrection) and not mmtime_synchedqpc) or qpcjumped then begin\r
 662 \r
 663     mmtime_nextdriftcorrection := qpc + 1;\r
 664     repeat\r
 665       mmtime_prev_drift := mmtime_drift;\r
 666       mmtime_prev_lastsyncmm := mmtime_lastsyncmm;\r
 667       mmtime_prev_lastsyncqpc := mmtime_lastsyncqpc;\r
 668 \r
 669       mm := mmtimefloat;\r
 670     {  dec(retrycount);}\r
 671       settc;\r
 672       result := qpctimefloat;\r
 673       f := mmtimefloat;\r
 674       repeat\r
 675         if f = mm then result := qpctimefloat;\r
 676         f := mmtimefloat\r
 677       until f > mm;\r
 678       qpc := qpctimefloat;\r
 679 \r
 680       unsettc;\r
 681       if (qpc > result + 0.0001) then begin\r
 682         continue;\r
 683       end;\r
 684       mm := f;\r
 685 \r
 686       if (mmtime_lastsyncqpc <> 0) and not qpcjumped then begin\r
 687         newdrift := (mm - mmtime_lastsyncmm) / (qpc - mmtime_lastsyncqpc);\r
 688         mmtime_drift := newdrift;\r
 689      {   writeln('raw drift: ',formatfloat('0.00000000',mmtime_drift));}\r
 690         move(mmtime_driftavg[0],mmtime_driftavg[1],sizeof(mmtime_driftavg[0])*high(mmtime_driftavg));\r
 691         mmtime_driftavg[0] := mmtime_drift;\r
 692 \r
 693 {        write('averaging drift ',formatfloat('0.00000000',mmtime_drift),' -> ');}\r
 694 {        mmtime_drift := 0;}\r
 695         b := 0;\r
 696         for a := 0 to high(mmtime_driftavg) do begin\r
 697           if mmtime_driftavg[a] <> 0 then inc(b);\r
 698 {          mmtime_drift := mmtime_drift + mmtime_driftavg[a];}\r
 699         end;\r
 700 {        mmtime_drift := mmtime_drift / b;}\r
 701         a := 5;\r
 702         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
 703         mmtime_nextdriftcorrection := qpc + a;\r
 704         if (b >= 2) then warmup_finished := true;\r
 705 {        writeln(formatfloat('0.00000000',mmtime_drift));}\r
 706        if mmtime_synchedqpc then mmtime_drift := 1;\r
 707       end;\r
 708 \r
 709       mmtime_lastsyncqpc := qpc;\r
 710       mmtime_lastsyncmm := mm;\r
 711   {   writeln(formatfloat('0.00000000',mmtime_drift));}\r
 712       break;\r
 713     until false;\r
 714 \r
 715 \r
 716     qpc := qpctimefloat;\r
 717 \r
 718     result := (qpc - mmtime_lastsyncqpc) * mmtime_drift + mmtime_lastsyncmm;\r
 719 \r
 720     {f := (qpc - mmtime_prev_lastsyncqpc) * mmtime_prev_drift + mmtime_prev_lastsyncmm;\r
 721     jump := result-f;\r
 722     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
 723 \r
 724     f := result;\r
 725   end;\r
 726 \r
 727   result := f;\r
 728 \r
 729   if (result < mmtime_lastresult) then result := mmtime_lastresult;\r
 730   mmtime_lastresult := result;\r
 731 end;\r
 732 \r
 733 \r
 734 function boottimefloat:float;\r
 735 begin\r
 736   result := monotimefloat;\r
 737 end;\r
 738 \r
 739 var\r
 740   QueryUnbiasedInterruptTime:function(var i:int64):longbool; stdcall;\r
 741   unbiasedinterrupttime_inited:boolean;\r
 742 \r
 743 \r
 744 procedure initunbiasedinterrupttime;\r
 745 var\r
 746   dllhandle:thandle;\r
 747 begin\r
 748   unbiasedinterrupttime_inited := true;\r
 749   dllhandle := loadlibrary('kernel32.dll');\r
 750   if (dllhandle <> 0) then begin\r
 751     QueryUnbiasedInterruptTime := getprocaddress(dllhandle,'QueryUnbiasedInterruptTime');\r
 752   end;\r
 753 end;\r
 754 \r
 755 function unbiasedtime_100ns:int64;\r
 756 begin\r
 757   result := -1;\r
 758   if not unbiasedinterrupttime_inited then initunbiasedinterrupttime;\r
 759   if assigned(@QueryUnbiasedInterruptTime) then begin\r
 760     QueryUnbiasedInterruptTime(result);\r
 761   end;\r
 762 end;\r
 763 \r
 764 function uptimefloat:float;\r
 765 var\r
 766   i:int64;\r
 767 begin\r
 768   i := unbiasedtime_100ns;\r
 769   if (i > 0) then begin\r
 770     result := i * 0.0000001;\r
 771     exit;\r
 772   end;\r
 773   result := qpctimefloat;\r
 774 end;\r
 775 \r
 776 \r
 777 \r
 778 var\r
 779   GetSystemTimePreciseAsFileTime:procedure(var v:tfiletime); stdcall;\r
 780   win8inited:boolean;\r
 781 \r
 782 procedure initwin8;\r
 783 var\r
 784   dllhandle:thandle;\r
 785 \r
 786 begin\r
 787   win8inited := true;\r
 788   dllhandle := loadlibrary('kernel32.dll');\r
 789   if (dllhandle <> 0) then begin\r
 790     GetSystemTimePreciseAsFileTime := getprocaddress(dllhandle,'GetSystemTimePreciseAsFileTime');\r
 791   end;\r
 792 end;\r
 793 \r
 794 \r
 795 function win8time_as_unix_100ns:int64;\r
 796 var\r
 797   ft:tfiletime;\r
 798   i:int64 absolute ft;\r
 799 begin\r
 800   result := -1;\r
 801   if not win8inited then initwin8;\r
 802   if assigned(@GetSystemTimePreciseAsFileTime) then begin\r
 803     GetSystemTimePreciseAsFileTime(ft);\r
 804     //change from windows 1601-01-01 to unix 1970-01-01.\r
 805     dec(i, 116444736000000000);\r
 806     result := i;\r
 807   end;\r
 808 end;\r
 809 \r
 810 \r
 811 function unixtimefloat_systemtime:float;\r
 812 var\r
 813   ft:tfiletime;\r
 814   i:int64 absolute ft;\r
 815 begin\r
 816   //result := oletounixfloat(now_utc);\r
 817 \r
 818   //this method gives exactly the same result with extended precision, but is less sensitive to float rounding in theory}\r
 819   //result := oletounixfloat(int(date_utc+0.5))+time_utc*86400;\r
 820 \r
 821   //new method that is much faster (22 vs 190 ns)\r
 822   GetSystemTimeAsFileTime(ft);\r
 823   dec(i, 116444736000000000);\r
 824   result := i * 0.0000001;\r
 825 end;\r
 826 \r
 827 \r
 828 function unixtimefloat_coarse:float;\r
 829 begin\r
 830   //don't do the coarse method if worse than about 16 ms. on win9x it may be only a 55 ms resolution\r
 831   //but i have also seen it is less (like 1 ms)\r
 832   //don't call measure_ticks_freq on NT because it is expensive and unnecessary\r
 833   init_win_version;\r
 834   if not win_isnt then begin\r
 835     if not ticks_freq_known then measure_ticks_freq;\r
 836   end;\r
 837   if win_isnt or (ticks_freq < 0.017) then begin\r
 838     result := unixtimefloat_systemtime;\r
 839     exit;\r
 840   end;\r
 841 \r
 842   result := unixtimefloat;\r
 843 end;\r
 844 \r
 845 function monotimefloat_coarse:float;\r
 846 begin\r
 847   init_win_version;\r
 848   if not win_isnt then begin\r
 849     if not ticks_freq_known then measure_ticks_freq;\r
 850   end;\r
 851   if win_isnt or (ticks_freq < 0.017) then begin\r
 852     result := mmtimeint64 * 0.001;\r
 853     exit;\r
 854   end;\r
 855   result := monotimefloat;\r
 856 end;\r
 857 \r
 858 \r
 859 //simulate gettimeofday on windows so one can always use gettimeofday if preferred\r
 860 function gettimeofday(var tv:ttimeval):integer;\r
 861 var\r
 862   e:float;\r
 863   i:int64;\r
 864 begin\r
 865   result := -1;\r
 866 \r
 867   if not btimenowin8 then begin\r
 868     i := win8time_as_unix_100ns;\r
 869     if (i > 0) then begin\r
 870       tv.tv_sec := i div 10000000;\r
 871       tv.tv_usec := (i mod 10000000) div 10;\r
 872       result := 0;\r
 873       exit;\r
 874     end;\r
 875   end;\r
 876 \r
 877   e := unixtimefloat;\r
 878   if (e > 0) then result := 0;\r
 879   tv.tv_sec := trunc(e);\r
 880   tv.tv_usec := trunc(frac(e)*1000000);\r
 881 end;\r
 882 \r
 883 \r
 884 function btime_gettime(clockid:integer;tp:pbtimespec):integer;\r
 885 var\r
 886   f:float;\r
 887   i:int64;\r
 888 \r
 889 {$ifdef cpu386}{$ifdef has_extended}{$define itotp_float}{$endif}{$endif}\r
 890 procedure i100ns_to_tp_and_success;\r
 891 {$ifdef itotp_float}\r
 892 var\r
 893   f:float;\r
 894 {$endif}\r
 895 begin\r
 896   //in 32 bits delphi, float is 10 times faster than int64 here (30 vs 300 ns for the conversion)\r
 897   //and with extended available, there is no loss of precision\r
 898 \r
 899   {$ifdef itotp_float}\r
 900   f := i / 10000000.0;\r
 901   tp.tv_sec := trunc(f);\r
 902   tp.tv_nsec := round(frac(f) * 1000000000.0);\r
 903   {$else}\r
 904   tp.tv_sec := i div 10000000;\r
 905   tp.tv_nsec := (i mod 10000000) * 100;\r
 906   {$endif}\r
 907 \r
 908   result := 0; //success\r
 909 end;\r
 910 \r
 911 procedure f_to_tp_and_success;\r
 912 begin\r
 913   tp.tv_sec := trunc(f);\r
 914   tp.tv_nsec := round(frac(f) * 1000000000.0);\r
 915   result := 0; //success\r
 916 end;\r
 917 \r
 918 begin\r
 919   result := -1; //error\r
 920 \r
 921   case clockid of\r
 922     CLOCK_REALTIME: begin\r
 923       //implement this case directly for full precision even without extended floats\r
 924       if not btimenowin8 then begin\r
 925         i := win8time_as_unix_100ns;\r
 926         if (i > 0) then begin\r
 927           i100ns_to_tp_and_success;\r
 928           exit;\r
 929         end;\r
 930       end;\r
 931       f := unixtimefloat;\r
 932       f_to_tp_and_success;\r
 933     end;\r
 934     CLOCK_MONOTONIC: begin\r
 935       f := monotimefloat;\r
 936       f_to_tp_and_success;\r
 937     end;\r
 938     CLOCK_REALTIME_COARSE: begin\r
 939       f := unixtimefloat_coarse;\r
 940       f_to_tp_and_success;\r
 941     end;\r
 942     CLOCK_MONOTONIC_COARSE: begin\r
 943       f := monotimefloat_coarse;\r
 944       f_to_tp_and_success;\r
 945     end;\r
 946     CLOCK_UPTIME: begin\r
 947       i := unbiasedtime_100ns;\r
 948       if (i > 0) then begin\r
 949         i100ns_to_tp_and_success;\r
 950         exit;\r
 951       end;\r
 952       f := qpctimefloat;\r
 953       f_to_tp_and_success;\r
 954     end;\r
 955   end;\r
 956 end;\r
 957 \r
 958 \r
 959 \r
 960 function unixtimefloat:float;\r
 961 const\r
 962   margin = 0.0012;\r
 963 var\r
 964   f,g,h:float;\r
 965 begin\r
 966   if not btimenowin8 then begin\r
 967     result := win8time_as_unix_100ns * 0.0000001;\r
 968     if (result > 0) then exit;\r
 969   end;\r
 970 \r
 971   result := monotimefloat+timefloatbias;\r
 972   f := result-unixtimefloat_systemtime;\r
 973   if ((f > ticks_freq2+margin) or (f < -margin)) or (timefloatbias = 0) then begin\r
 974     f := unixtimefloat_systemtime;\r
 975     settc;\r
 976     repeat g := unixtimefloat_systemtime; h := monotimefloat until g > f;\r
 977     unsettc;\r
 978     timefloatbias := g-h;\r
 979     result := unixtimefloat;\r
 980   end;\r
 981 \r
 982   //for small changes backwards, guarantee no steps backwards\r
 983   if (result <= lastunixtimefloat) and (result > lastunixtimefloat-1.5) then result := lastunixtimefloat;\r
 984   lastunixtimefloat := result;\r
 985 end;\r
 986 \r
 987 function unixtimeint:tunixtimeint;\r
 988 begin\r
 989   result := trunc(unixtimefloat);\r
 990 end;\r
 991 \r
 992 {$endif}  //mswindows\r
 993 {-----------------------------------------------end of platform specific}\r
 994 \r
 995 function wintimefloat:float;\r
 996 begin\r
 997   result := monotimefloat;\r
 998 end;\r
 999 \r
1000 function irctimefloat:float;\r
1001 begin\r
1002   result := unixtimefloat+settimebias;\r
1003 end;\r
1004 \r
1005 function irctimeint:tunixtimeint;\r
1006 begin\r
1007   result := unixtimeint+settimebias;\r
1008 end;\r
1009 \r
1010 \r
1011 procedure settime(newtime:tunixtimeint);\r
1012 var\r
1013   a:tunixtimeint;\r
1014 begin\r
1015   a := irctimeint-settimebias;\r
1016   if newtime = 0 then settimebias := 0 else settimebias := newtime-a;\r
1017 \r
1018   irctime := irctimeint;\r
1019 end;\r
1020 \r
1021 procedure timehandler;\r
1022 begin\r
1023   if unixtime = 0 then init;\r
1024   unixtime := unixtimeint;\r
1025   irctime := unixtime+settimebias;\r
1026   if unixtime and 63 = 0 then begin\r
1027     {update everything, apply timezone changes, clock changes, etc}\r
1028     gettimezone;\r
1029     timefloatbias := 0;\r
1030     unixtime := unixtimeint;\r
1031     irctime := irctimeint;\r
1032   end;\r
1033 end;\r
1034 \r
1035 \r
1036 {$ifdef unix}\r
1037 \r
1038 var\r
1039   tzerror:boolean;\r
1040   tzfile:ansistring;\r
1041 \r
1042 function tzgetfilename:ansistring;\r
1043 var\r
1044   t:textfile;\r
1045   a:integer;\r
1046   s,tz,tzdir:ansistring;\r
1047   ispath:boolean;\r
1048 begin\r
1049   result := '';\r
1050   filemode := 0;\r
1051 \r
1052   tz := getenv('TZ');\r
1053 \r
1054   if (tz <> '') then begin\r
1055     ispath := false;\r
1056     if (copy(tz,1,1) = ':') then begin\r
1057       ispath := true;\r
1058       tz := copy(tz,2,99999);\r
1059     end;\r
1060 \r
1061     if (copy(tz,1,1) <> '/') then begin\r
1062       a := pos(',',tz);\r
1063       if (a > 1) and not ispath then begin\r
1064         tz := copy(tz,1,a-1);\r
1065       end;\r
1066 \r
1067       tzdir := getenv('TZDIR');\r
1068       if (tzdir = '') then begin\r
1069         tzdir := '/usr/share/zoneinfo/';\r
1070       end else begin\r
1071         if (copy(tzdir,length(tzdir),1) <> '/') then tzdir := tzdir + '/';\r
1072       end;\r
1073       tz := tzdir + tz;\r
1074     end;\r
1075 \r
1076     assignfile(t,tz);\r
1077     {$i-}reset(t);{$i+}\r
1078     if (ioresult = 0) then begin\r
1079       closefile(t);\r
1080       result := tz;\r
1081       exit;\r
1082     end;\r
1083 \r
1084   end;\r
1085 \r
1086   assignfile(t,'/etc/localtime');\r
1087   {$i-}reset(t);{$i+}\r
1088   if (ioresult = 0) then begin\r
1089     closefile(t);\r
1090     result := '/etc/localtime';\r
1091     exit;\r
1092   end;\r
1093 end;\r
1094 \r
1095 type\r
1096   dvar=array[0..65535] of byte;\r
1097   pdvar=^dvar;\r
1098 \r
1099 var\r
1100   tzcache:pdvar;\r
1101   tzsize:integer;\r
1102 \r
1103 procedure tzinvalidate;\r
1104 begin\r
1105   if assigned(tzcache) then freemem(tzcache);\r
1106   tzcache := nil;\r
1107   tzsize := 0;\r
1108   tzfile := '';\r
1109   gettimezone;\r
1110 end;\r
1111 \r
1112 \r
1113 function tzgetoffsetforts(ts:tunixtimeint):integer;\r
1114 var\r
1115   f:file;\r
1116   buf:pdvar;\r
1117   fs:integer;\r
1118   ofs,ofs2:integer;\r
1119   mode64:boolean;\r
1120   has64:boolean;\r
1121   a,index:integer;\r
1122   //tzstrofs:integer;\r
1123   t:int64;\r
1124   tzh_ttisgmtcnt:integer;\r
1125   tzh_ttisstdcnt:integer;\r
1126   tzh_leapcnt:integer;\r
1127   tzh_timecnt:integer;\r
1128   tzh_typecnt:integer;\r
1129   tzh_charcnt:integer;\r
1130 \r
1131 \r
1132 function getint:integer;\r
1133 begin\r
1134   if (ofs < 0) or ((ofs + 4) > fs) then raise exception.create('getint');\r
1135   result := (buf[ofs] shl 24) + (buf[ofs+1] shl 16) + (buf[ofs+2] shl 8) + buf[ofs+3];\r
1136   inc(ofs,4);\r
1137 end;\r
1138 \r
1139 function getint64:int64;\r
1140 begin\r
1141   if (ofs < 0) or ((ofs + 8) > fs) then raise exception.create('getint64');\r
1142   result := int64(getint) shl 32;\r
1143   inc(result,cardinal(getint));\r
1144 end;\r
1145 \r
1146 \r
1147 function getbyte:byte;\r
1148 begin\r
1149   if (ofs < 0) or ((ofs + 1) > fs) then raise exception.create('getbyte');\r
1150   result := buf[ofs];\r
1151   inc(ofs);\r
1152 end;\r
1153 \r
1154 begin\r
1155   result := 0;\r
1156   tzerror := true;\r
1157 \r
1158   if not assigned(tzcache) then begin\r
1159 \r
1160     if (tzfile = '') then tzfile := tzgetfilename;\r
1161 \r
1162     if (tzfile = '') then exit;\r
1163 \r
1164     assignfile(f,tzfile);\r
1165     filemode := 0;\r
1166     {$i-}reset(f,1);{$i+}\r
1167     if (ioresult <> 0) then begin\r
1168       exit;\r
1169     end;\r
1170     tzsize := filesize(f);\r
1171     if (tzsize > 65536) then tzsize := 65536;\r
1172     getmem(tzcache,tzsize);\r
1173     blockread(f,tzcache^,tzsize);\r
1174     closefile(f);\r
1175   end;\r
1176   fs := tzsize;\r
1177   buf := tzcache;\r
1178   ofs := 0;\r
1179   mode64 := false;\r
1180 \r
1181  try\r
1182    repeat\r
1183      if (getint <> $545a6966) then exit; // 'TZif'\r
1184      has64 := getbyte >= $32; //  '2'\r
1185 \r
1186      inc(ofs,15);\r
1187 \r
1188      tzh_ttisgmtcnt := getint;\r
1189      tzh_ttisstdcnt := getint;\r
1190      tzh_leapcnt := getint;\r
1191      tzh_timecnt := getint;\r
1192      tzh_typecnt := getint;\r
1193      tzh_charcnt := getint;\r
1194 \r
1195      if mode64 or (not has64) then break;\r
1196      inc(ofs, 5 * tzh_timecnt + 6 * tzh_typecnt + 8 * tzh_leapcnt + tzh_ttisstdcnt + tzh_ttisgmtcnt + tzh_charcnt);\r
1197      mode64 := true;\r
1198    until false;\r
1199    index := 0;\r
1200 \r
1201    if (tzh_timecnt < 0) or (tzh_timecnt > fs) then raise exception.create('tzh_timecnt');\r
1202    ofs2 := ofs;\r
1203 \r
1204    if (tzh_timecnt <> 0) then begin\r
1205      for a := 0 to tzh_timecnt -1 do begin\r
1206        if mode64 then t := getint64 else t := getint;\r
1207        if (t > ts) then begin\r
1208          index := a - 1;\r
1209          break;\r
1210        end;\r
1211        if (a = tzh_timecnt -1) and (ts >= t) then index := a;\r
1212      end;\r
1213      ofs := ofs2 + tzh_timecnt * (1 + ord(mode64)) * 4;\r
1214 \r
1215      if (cardinal(ofs + index) >= fs) or (index < 0) then raise exception.create('index');\r
1216      index := buf[ofs+index];\r
1217      inc(ofs,tzh_timecnt);\r
1218    end else begin\r
1219      index := 0;\r
1220    end;\r
1221 \r
1222    if (index >= tzh_typecnt) then raise exception.create('type');\r
1223    ofs2 := ofs;\r
1224   // writeln('ofs2 ',inttohex(ofs2,8));\r
1225    inc(ofs,6 * index);\r
1226    result := getint;\r
1227 \r
1228    //tzisdst := getbyte;\r
1229 \r
1230   //the abbreviation string\r
1231   { tzstrofs := getbyte;\r
1232    tzstr := '';\r
1233    ofs := ofs2 + 6 * tzh_typecnt;\r
1234    inc(ofs, tzstrofs);\r
1235 \r
1236    repeat\r
1237      a := getbyte;\r
1238      if (a <> 0) then tzstr := tzstr + chr(a);\r
1239    until (a = 0); }\r
1240 \r
1241    tzerror := false;\r
1242  except\r
1243 \r
1244  end;\r
1245 end;\r
1246 \r
1247 {$endif}  //unix\r
1248 \r
1249 function tzgetoffset:integer;\r
1250   {$ifdef UNIX}\r
1251     {$ifndef ver1_9_4}\r
1252       {$ifndef ver1_0}\r
1253         {$define above194}\r
1254       {$endif}\r
1255     {$endif}\r
1256     {$ifndef above194}\r
1257 var\r
1258       hh,mm,ss:word;\r
1259     {$endif}\r
1260   {$else}\r
1261 var\r
1262   TimeZoneInfo: TIME_ZONE_INFORMATION;\r
1263   tztype:cardinal;\r
1264   min:integer;\r
1265   {$endif}\r
1266 \r
1267 begin\r
1268   {$ifdef UNIX}\r
1269     {$ifdef above194}\r
1270       result := tzgetoffsetforts(unixtimeint);\r
1271       //freepascal tzseconds is not 2038 safe\r
1272     {$else}\r
1273       gettime(hh,mm,ss);\r
1274       result := (integer(hh) * 3600 + mm * 60 + ss) - (unixtimeint mod 86400);\r
1275     {$endif}\r
1276   {$else}\r
1277     tztype := GetTimeZoneInformation(TimeZoneInfo);\r
1278     min := TimeZoneInfo.Bias;\r
1279     case tztype of\r
1280       //TIME_ZONE_ID_UNKNOWN: don't add DST\r
1281       TIME_ZONE_ID_STANDARD: inc(min, TimeZoneInfo.StandardBias);\r
1282       TIME_ZONE_ID_DAYLIGHT: inc(min, TimeZoneInfo.DaylightBias);\r
1283     end;\r
1284     result := min * -60;\r
1285   {$endif}\r
1286 \r
1287   while result > (14 * 3600) do dec(result,86400);\r
1288   while result < -(14 * 3600) do inc(result,86400);\r
1289 end;\r
1290 \r
1291 \r
1292 procedure gettimezone;\r
1293 var\r
1294   l:integer;\r
1295 begin\r
1296   timezone := tzgetoffset;\r
1297 \r
1298   if timezone >= 0 then timezonestr := '+' else timezonestr := '-';\r
1299   l := abs(timezone) div 60;\r
1300   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
1301 end;\r
1302 \r
1303 function timestrshort(i:tunixtimeint):string;\r
1304 const\r
1305   weekday:array[0..6] of string[4]=('Thu','Fri','Sat','Sun','Mon','Tue','Wed');\r
1306   month:array[0..11] of string[4]=('Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct','Nov','Dec');\r
1307 var\r
1308   y,m,d,h,min,sec,ms:word;\r
1309   t:tdatetime;\r
1310 begin\r
1311   t := unixtoole(i+timezone);\r
1312   decodedate(t,y,m,d);\r
1313   decodetime(t,h,min,sec,ms);\r
1314   result := weekday[(i+timezone) div 86400 mod 7]+' '+month[m-1]+' '+inttostr(d)+' '+\r
1315   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
1316   inttostr(y);\r
1317 end;\r
1318 \r
1319 function timestring(i:tunixtimeint):string;\r
1320 const\r
1321   weekday:array[0..6] of string[10]=('Thursday','Friday','Saturday','Sunday','Monday','Tuesday','Wednesday');\r
1322   month:array[0..11] of string[10]=('January','February','March','April','May','June','July','August','September','October','November','December');\r
1323 var\r
1324   y,m,d,h,min,sec,ms:word;\r
1325   t:tdatetime;\r
1326 begin\r
1327   t := unixtoole(i+timezone);\r
1328   decodedate(t,y,m,d);\r
1329   decodetime(t,h,min,sec,ms);\r
1330   result := weekday[(i+timezone) div 86400 mod 7]+' '+month[m-1]+' '+inttostr(d)+' '+inttostr(y)+' -- '+\r
1331   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
1332   timezonestr;\r
1333 end;\r
1334 \r
1335 function timestriso(i:tunixtimeint):string;\r
1336 var\r
1337   y,m,d,h,min,sec,ms:word;\r
1338   t:tdatetime;\r
1339 begin\r
1340   t := unixtoole(i+timezone);\r
1341   decodedate(t,y,m,d);\r
1342   decodetime(t,h,min,sec,ms);\r
1343   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
1344 end;\r
1345 \r
1346 function timestrisoutc(i:float):string;\r
1347 var\r
1348   y,m,d,h,min,sec,ms:word;\r
1349   t:tdatetime;\r
1350   fr:float;\r
1351 begin\r
1352   t := unixtoole(i);\r
1353   decodedate(t,y,m,d);\r
1354   decodetime(t,h,min,sec,ms);\r
1355   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
1356   fr := frac(i);\r
1357 \r
1358   result := result + '.'+\r
1359   inttostr(trunc(fr*10) mod 10)+\r
1360   inttostr(trunc(fr*100) mod 10)+\r
1361   inttostr(trunc(fr*1000) mod 10)+\r
1362   inttostr(trunc(fr*10000) mod 10)+\r
1363   inttostr(trunc(fr*100000) mod 10)+\r
1364   inttostr(trunc(fr*1000000) mod 10)+'Z';\r
1365 \r
1366 end;\r
1367 \r
1368 procedure beginhightimerrate;\r
1369 begin\r
1370   {$ifdef mswindows}timebeginperiod(1);{$endif}\r
1371 end;\r
1372 \r
1373 procedure endhightimerrate;\r
1374 begin\r
1375   {$ifdef mswindows}timeendperiod(1);{$endif}\r
1376 end;\r
1377 \r
1378 procedure init;\r
1379 begin\r
1380   {$ifdef btimehighrate}beginhightimerrate;{$endif}\r
1381   fillchar(mmtime_driftavg,sizeof(mmtime_driftavg),0);\r
1382   settimebias := 0;\r
1383   gettimezone;\r
1384   unixtime := unixtimeint;\r
1385   irctime := irctimeint;\r
1386 end;\r
1387 \r
1388 initialization init;\r
1389 \r
1390 end.\r