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 \r
  13 interface\r
  14 \r
  15 type\r
  16   float=extended;\r
  17 \r
  18 const\r
  19   colorburst=39375000/11;  {3579545.4545....}\r
  20 \r
  21 var\r
  22   timezone:integer;\r
  23   timezonestr:ansistring;\r
  24   irctime,unixtime:integer;\r
  25   tickcount:integer;\r
  26   settimebias:integer;\r
  27   performancecountfreq:extended;\r
  28 \r
  29 function irctimefloat:float;\r
  30 function irctimeint:integer;\r
  31 \r
  32 function unixtimefloat:float;\r
  33 function unixtimeint:integer;\r
  34 \r
  35 function wintimefloat:float;\r
  36 \r
  37 procedure settime(newtime:integer);\r
  38 procedure gettimezone;\r
  39 procedure timehandler;\r
  40 procedure init;\r
  41 \r
  42 function timestring(i:integer):ansistring;\r
  43 function timestrshort(i:integer):ansistring;\r
  44 \r
  45 {$ifdef win32}\r
  46 function unixtimefloat_systemtime:float;\r
  47 {$endif}\r
  48 \r
  49 function oletounixfloat(t:float):float;\r
  50 function oletounix(t:tdatetime):integer;\r
  51 function unixtoole(i:integer):tdatetime;\r
  52 \r
  53 {$ifdef win32}\r
  54 function mmtimefloat:float;\r
  55 function qpctimefloat:float;\r
  56 {$endif}\r
  57 \r
  58 const\r
  59   mmtime_driftavgsize=32;\r
  60   mmtime_warmupnum=4;\r
  61   mmtime_warmupcyclelength=15;\r
  62 var\r
  63   //this flag is to be set when btime has been running long enough to stabilise\r
  64   warmup_finished:boolean;\r
  65 \r
  66   timefloatbias:float;\r
  67   ticks_freq:float=0;\r
  68   ticks_freq2:float=0;\r
  69   ticks_freq_known:boolean=false;\r
  70   lastunixtimefloat:float=0;\r
  71   lastsynctime:float=0;\r
  72   lastsyncbias:float=0;\r
  73 \r
  74   mmtime_last:integer=0;\r
  75   mmtime_wrapadd:float;\r
  76   mmtime_lastsyncmm:float=0;\r
  77   mmtime_lastsyncqpc:float=0;\r
  78   mmtime_drift:float=1;\r
  79   mmtime_lastresult:float;\r
  80   mmtime_nextdriftcorrection:float;\r
  81   mmtime_driftavg:array[0..mmtime_driftavgsize] of float;\r
  82   mmtime_synchedqpc:boolean;\r
  83 \r
  84   mmtime_prev_drift:float;\r
  85   mmtime_prev_lastsyncmm:float;\r
  86   mmtime_prev_lastsyncqpc:float;\r
  87 \r
  88 implementation\r
  89 \r
  90 {$ifdef fpc}\r
  91   {$mode delphi}\r
  92 {$endif}\r
  93 \r
  94 uses\r
  95   {$ifdef UNIX}\r
  96     {$ifdef VER1_0}\r
  97       linux,\r
  98     {$else}\r
  99       baseunix,unix,unixutil,sockets, {unixutil and sockets needed by unixstuff.inc on some compiler versions}\r
 100     {$endif}\r
 101   {$else}\r
 102     windows,unitsettc,mmsystem,\r
 103   {$endif}\r
 104   sysutils;\r
 105 \r
 106   {$include unixstuff.inc}\r
 107 \r
 108 \r
 109 const\r
 110   daysdifference=25569;\r
 111 \r
 112 function oletounixfloat(t:float):float;\r
 113 begin\r
 114   t := (t - daysdifference) * 86400;\r
 115   result := t;\r
 116 end;\r
 117 \r
 118 function oletounix(t:tdatetime):integer;\r
 119 begin\r
 120   result := trunc(oletounixfloat(t));\r
 121 end;\r
 122 \r
 123 function unixtoole(i:integer):tdatetime;\r
 124 begin\r
 125   result := ((i)/86400)+daysdifference;\r
 126 end;\r
 127 \r
 128 const\r
 129   highdwordconst=65536.0 * 65536.0;\r
 130 \r
 131 function utrunc(f:float):integer;\r
 132 {converts float to integer, in 32 bits unsigned range}\r
 133 begin\r
 134   if f >= (highdwordconst/2) then f := f - highdwordconst;\r
 135   result := trunc(f);\r
 136 end;\r
 137 \r
 138 function uinttofloat(i:integer):float;\r
 139 {converts 32 bits unsigned integer to float}\r
 140 begin\r
 141   result := i;\r
 142   if result < 0 then result := result + highdwordconst;\r
 143 end;\r
 144 \r
 145 {$ifdef unix}\r
 146 {-----------------------------------------*nix/freepascal code to read time }\r
 147 \r
 148 function unixtimefloat:float;\r
 149 var\r
 150   tv:ttimeval;\r
 151 begin\r
 152   gettimeofday(tv);\r
 153   result := tv.tv_sec+(tv.tv_usec/1000000);\r
 154 end;\r
 155 \r
 156 function wintimefloat:extended;\r
 157 begin\r
 158   result := unixtimefloat;\r
 159 end;\r
 160 \r
 161 function unixtimeint:integer;\r
 162 var\r
 163   tv:ttimeval;\r
 164 begin\r
 165   gettimeofday(tv);\r
 166   result := tv.tv_sec;\r
 167 end;\r
 168 \r
 169 {$else} {delphi 3}\r
 170 {------------------------------ windows/delphi code to read time}\r
 171 \r
 172 {\r
 173 time float: gettickcount\r
 174 resolution: 9x: ~55 ms NT: 1/64th of a second\r
 175 guarantees: continuous without any jumps\r
 176 frequency base: same as system clock.\r
 177 epoch: system boot\r
 178 note: if called more than once per 49.7 days, 32 bits wrapping is compensated for and it keeps going on.\r
 179 note: i handle the timestamp as signed integer, but with the wrap compensation that works as well, and is faster\r
 180 }\r
 181 \r
 182 function mmtimefloat:float;\r
 183 const\r
 184   wrapduration=highdwordconst * 0.001;\r
 185 var\r
 186   i:integer;\r
 187 begin\r
 188   i := gettickcount; {timegettime}\r
 189   if i < mmtime_last then begin\r
 190     mmtime_wrapadd := mmtime_wrapadd + wrapduration;\r
 191   end;\r
 192   mmtime_last := i;\r
 193   result := mmtime_wrapadd + i * 0.001;\r
 194 \r
 195   if (ticks_freq <> 0) and ticks_freq_known then result := int((result / ticks_freq)+0.5) * ticks_freq; //turn the float into an exact multiple of 1/64th sec to improve accuracy of things using this\r
 196 end;\r
 197 \r
 198 procedure measure_ticks_freq;\r
 199 var\r
 200   f,g:float;\r
 201   o:tosversioninfo;\r
 202   isnt:boolean;\r
 203   is9x:boolean;\r
 204 begin\r
 205   if (performancecountfreq = 0) then qpctimefloat;\r
 206   ticks_freq_known := false;\r
 207   settc;\r
 208   f := mmtimefloat;\r
 209   repeat g := mmtimefloat until g > f;\r
 210   unsettc;\r
 211   f := g - f;\r
 212   fillchar(o,sizeof(o),0);\r
 213   o.dwOSVersionInfoSize := sizeof(o);\r
 214   getversionex(o);\r
 215   isnt := o.dwPlatformId = VER_PLATFORM_WIN32_NT;\r
 216   is9x := o.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS;\r
 217 \r
 218   ticks_freq2 := f;\r
 219   mmtime_synchedqpc := false;\r
 220   {\r
 221   NT 64 Hz\r
 222   identify mode as: nt64\r
 223   QPC rate: either 3579545 or TSC freq\r
 224   QPC synched to gettickcount: no\r
 225   duration between 2 ticks is constant: yes\r
 226   gettickcount tick duration: 64 Hz\r
 227   }\r
 228   if (f >= 0.014) and (f <= 0.018) and isnt then begin\r
 229     ticks_freq_known := true;\r
 230     ticks_freq := 1/64;\r
 231     mmtime_synchedqpc := false;\r
 232   end;\r
 233 \r
 234   {\r
 235   NT 100 Hz\r
 236   identify mode as: nt100\r
 237   QPC rate: 1193182\r
 238   QPC synched to gettickcount: yes\r
 239   duration between 2 ticks is constant: no?\r
 240   gettickcount tick duration: ~99.85 Hz\r
 241   }\r
 242   if (performancecountfreq = 1193182) and (f >= 0.008) and (f <= 0.012) and isnt then begin\r
 243     ticks_freq_known := true;\r
 244     ticks_freq2 := 11949 / (colorburst / 3);\r
 245    //  ticks_freq2 := 11949 / 1193182;\r
 246     ticks_freq := 0;\r
 247     {the ticks freq should be very close to the real one but if it's not exact, it will cause drift and correction jumps}\r
 248     mmtime_synchedqpc := true;\r
 249   end;\r
 250 \r
 251   {9x}\r
 252   if (performancecountfreq = 1193182) and (g >= 0.050) and (g <= 0.060) then begin\r
 253     ticks_freq_known := true;\r
 254     ticks_freq := 65536 / (colorburst / 3);\r
 255     mmtime_synchedqpc := true;\r
 256   end;\r
 257   ticks_freq_known := true;\r
 258   if ticks_freq <> 0 then ticks_freq2 := ticks_freq;\r
 259 //  writeln(formatfloat('0.000000',ticks_freq));\r
 260 end;\r
 261 \r
 262 {\r
 263 time float: QueryPerformanceCounter\r
 264 resolution: <1us\r
 265 guarantees: can have forward jumps depending on hardware. can have forward and backwards jitter on dual core.\r
 266 frequency base: on NT, not the system clock, drifts compared to it.\r
 267 epoch: system boot\r
 268 }\r
 269 function qpctimefloat:extended;\r
 270 var\r
 271   p:packed record\r
 272     lowpart:longint;\r
 273     highpart:longint\r
 274   end;\r
 275   p2:tlargeinteger absolute p;\r
 276   e:extended;\r
 277 begin\r
 278   if performancecountfreq = 0 then begin\r
 279     QueryPerformancefrequency(p2);\r
 280     e := p.lowpart;\r
 281     if e < 0 then e := e + highdwordconst;\r
 282     performancecountfreq := ((p.highpart*highdwordconst)+e);\r
 283   end;\r
 284   queryperformancecounter(p2);\r
 285   e := p.lowpart;\r
 286   if e < 0 then e := e + highdwordconst;\r
 287 \r
 288   result := ((p.highpart*highdwordconst)+e)/performancecountfreq;\r
 289 end;\r
 290 \r
 291 {\r
 292 time float: QPC locked to gettickcount\r
 293 resolution: <1us\r
 294 guarantees: continuous without any jumps\r
 295 frequency base: same as system clock.\r
 296 epoch: system boot\r
 297 }\r
 298 \r
 299 function mmqpctimefloat:float;\r
 300 const\r
 301   maxretries=5;\r
 302   margin=0.002;\r
 303 var\r
 304   jump:float;\r
 305   mm,f,qpc,newdrift,f1,f2:float;\r
 306   qpcjumped:boolean;\r
 307   a,b,c:integer;\r
 308   retrycount:integer;\r
 309 begin\r
 310   if not ticks_freq_known then measure_ticks_freq;\r
 311   retrycount := maxretries;\r
 312 \r
 313   qpc := qpctimefloat;\r
 314   mm := mmtimefloat;\r
 315   f := (qpc - mmtime_lastsyncqpc) * mmtime_drift + mmtime_lastsyncmm;\r
 316   //writeln('XXXX ',formatfloat('0.000000',qpc-mm));\r
 317   qpcjumped := ((f-mm) > ticks_freq2+margin) or ((f-mm) < -margin);\r
 318 //  if qpcjumped then writeln('qpc jumped ',(f-mm));\r
 319   if ((qpc > mmtime_nextdriftcorrection) and not mmtime_synchedqpc) or qpcjumped then begin\r
 320 \r
 321     mmtime_nextdriftcorrection := qpc + 1;\r
 322     repeat\r
 323       mmtime_prev_drift := mmtime_drift;\r
 324       mmtime_prev_lastsyncmm := mmtime_lastsyncmm;\r
 325       mmtime_prev_lastsyncqpc := mmtime_lastsyncqpc;\r
 326 \r
 327       mm := mmtimefloat;\r
 328       dec(retrycount);\r
 329       settc;\r
 330       result := qpctimefloat;\r
 331       f := mmtimefloat;\r
 332       repeat\r
 333         if f = mm then result := qpctimefloat;\r
 334         f := mmtimefloat\r
 335       until f > mm;\r
 336       qpc := qpctimefloat;\r
 337 \r
 338       unsettc;\r
 339       if (qpc > result + 0.0001) then begin\r
 340         continue;\r
 341       end;\r
 342       mm := f;\r
 343 \r
 344       if (mmtime_lastsyncqpc <> 0) and not qpcjumped then begin\r
 345         newdrift := (mm - mmtime_lastsyncmm) / (qpc - mmtime_lastsyncqpc);\r
 346         mmtime_drift := newdrift;\r
 347      {   writeln('raw drift: ',formatfloat('0.00000000',mmtime_drift));}\r
 348         move(mmtime_driftavg[0],mmtime_driftavg[1],sizeof(mmtime_driftavg[0])*high(mmtime_driftavg));\r
 349         mmtime_driftavg[0] := mmtime_drift;\r
 350 \r
 351 {        write('averaging drift ',formatfloat('0.00000000',mmtime_drift),' -> ');}\r
 352 {        mmtime_drift := 0;}\r
 353         b := 0;\r
 354         for a := 0 to high(mmtime_driftavg) do begin\r
 355           if mmtime_driftavg[a] <> 0 then inc(b);\r
 356 {          mmtime_drift := mmtime_drift + mmtime_driftavg[a];}\r
 357         end;\r
 358 {        mmtime_drift := mmtime_drift / b;}\r
 359         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
 360         mmtime_nextdriftcorrection := qpc + a;\r
 361         if (b >= 2) then warmup_finished := true;\r
 362 {        writeln(formatfloat('0.00000000',mmtime_drift));}\r
 363        if mmtime_synchedqpc then mmtime_drift := 1;\r
 364       end;\r
 365 \r
 366       mmtime_lastsyncqpc := qpc;\r
 367       mmtime_lastsyncmm := mm;\r
 368   {   writeln(formatfloat('0.00000000',mmtime_drift));}\r
 369       break;\r
 370     until false;\r
 371 \r
 372 \r
 373     qpc := qpctimefloat;\r
 374 \r
 375     result := (qpc - mmtime_lastsyncqpc) * mmtime_drift + mmtime_lastsyncmm;\r
 376     f := (qpc - mmtime_prev_lastsyncqpc) * mmtime_prev_drift + mmtime_prev_lastsyncmm;\r
 377 \r
 378     jump := result-f;\r
 379     {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
 380 \r
 381     f := result;\r
 382   end;\r
 383 \r
 384   result := f;\r
 385 \r
 386   if (result < mmtime_lastresult) then result := mmtime_lastresult + 0.000001;\r
 387   mmtime_lastresult := result;\r
 388 end;\r
 389 \r
 390 { free pascals tsystemtime is incomaptible with windows api calls\r
 391  so we declare it ourselves - plugwash\r
 392 }\r
 393 {$ifdef fpc}\r
 394 type\r
 395   TSystemTime = record\r
 396      wYear: Word;\r
 397      wMonth: Word;\r
 398      wDayOfWeek: Word;\r
 399      wDay: Word;\r
 400      wHour: Word;\r
 401      wMinute: Word;\r
 402      wSecond: Word;\r
 403      wMilliseconds: Word;\r
 404   end;\r
 405  {$endif}\r
 406 function Date_utc: extended;\r
 407 var\r
 408   SystemTime: TSystemTime;\r
 409 begin\r
 410   {$ifdef fpc}\r
 411     GetsystemTime(@SystemTime);\r
 412   {$else}\r
 413     GetsystemTime(SystemTime);\r
 414   {$endif}\r
 415   with SystemTime do Result := EncodeDate(wYear, wMonth, wDay);\r
 416 end;\r
 417 \r
 418 function Time_utc: extended;\r
 419 var\r
 420   SystemTime: TSystemTime;\r
 421 begin\r
 422   {$ifdef fpc}\r
 423     GetsystemTime(@SystemTime);\r
 424   {$else}\r
 425     GetsystemTime(SystemTime);\r
 426   {$endif}\r
 427   with SystemTime do\r
 428     Result := EncodeTime(wHour, wMinute, wSecond, wMilliSeconds);\r
 429 end;\r
 430 \r
 431 function Now_utc: extended;\r
 432 begin\r
 433   Result := round(Date_utc) + Time_utc;\r
 434 end;\r
 435 \r
 436 function unixtimefloat_systemtime:float;\r
 437 begin\r
 438   {result := oletounixfloat(now_utc);}\r
 439 \r
 440   {this method gives exactly the same result with extended precision, but is less sensitive to float rounding in theory}\r
 441   result := oletounixfloat(int(date_utc+0.5))+time_utc*86400;\r
 442 end;\r
 443 \r
 444 function wintimefloat:extended;\r
 445 begin\r
 446   result := mmqpctimefloat;\r
 447 end;\r
 448 \r
 449 function unixtimefloat:float;\r
 450 const\r
 451   margin = 0.0012;\r
 452 var\r
 453   f,g,h:float;\r
 454 begin\r
 455   result := wintimefloat+timefloatbias;\r
 456   f := result-unixtimefloat_systemtime;\r
 457   if ((f > ticks_freq2+margin) or (f < -margin)) or (timefloatbias = 0) then begin\r
 458 //    writeln('unixtimefloat init');\r
 459     f := unixtimefloat_systemtime;\r
 460     settc;\r
 461     repeat g := unixtimefloat_systemtime; h := wintimefloat until g > f;\r
 462     unsettc;\r
 463     timefloatbias := g-h;\r
 464     result := unixtimefloat;\r
 465   end;\r
 466 \r
 467   {for small changes backwards, guarantee no steps backwards}\r
 468   if (result <= lastunixtimefloat) and (result > lastunixtimefloat-1.5) then result := lastunixtimefloat + 0.0000001;\r
 469   lastunixtimefloat := result;\r
 470 end;\r
 471 \r
 472 function unixtimeint:integer;\r
 473 begin\r
 474   result := trunc(unixtimefloat);\r
 475 end;\r
 476 \r
 477 {$endif}\r
 478 {-----------------------------------------------end of platform specific}\r
 479 \r
 480 function irctimefloat:float;\r
 481 begin\r
 482   result := unixtimefloat+settimebias;\r
 483 end;\r
 484 \r
 485 function irctimeint:integer;\r
 486 begin\r
 487   result := unixtimeint+settimebias;\r
 488 end;\r
 489 \r
 490 \r
 491 procedure settime(newtime:integer);\r
 492 var\r
 493   a:integer;\r
 494 begin\r
 495   a := irctimeint-settimebias;\r
 496   if newtime = 0 then settimebias := 0 else settimebias := newtime-a;\r
 497 \r
 498   irctime := irctimeint;\r
 499 end;\r
 500 \r
 501 procedure timehandler;\r
 502 begin\r
 503   if unixtime = 0 then init;\r
 504   unixtime := unixtimeint;\r
 505   irctime := irctimeint;\r
 506   if unixtime and 63 = 0 then begin\r
 507     {update everything, apply timezone changes, clock changes, etc}\r
 508     gettimezone;\r
 509     timefloatbias := 0;\r
 510     unixtime := unixtimeint;\r
 511     irctime := irctimeint;\r
 512   end;\r
 513 end;\r
 514 \r
 515 \r
 516 procedure gettimezone;\r
 517 var\r
 518   {$ifdef UNIX}\r
 519     {$ifndef ver1_9_4}\r
 520       {$ifndef ver1_0}\r
 521         {$define above194}\r
 522       {$endif}\r
 523     {$endif}\r
 524     {$ifndef above194}\r
 525       hh,mm,ss:word;\r
 526     {$endif}\r
 527   {$endif}\r
 528   l:integer;\r
 529 begin\r
 530   {$ifdef UNIX}\r
 531     {$ifdef above194}\r
 532       timezone := tzseconds;\r
 533     {$else}\r
 534       gettime(hh,mm,ss);\r
 535       timezone := (longint(hh) * 3600 + mm * 60 + ss) - (unixtimeint mod 86400);\r
 536     {$endif}\r
 537   {$else}\r
 538   timezone := round((now-now_utc)*86400);\r
 539   {$endif}\r
 540 \r
 541   while timezone > 43200 do dec(timezone,86400);\r
 542   while timezone < -43200 do inc(timezone,86400);\r
 543 \r
 544   if timezone >= 0 then timezonestr := '+' else timezonestr := '-';\r
 545   l := abs(timezone) div 60;\r
 546   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
 547 end;\r
 548 \r
 549 function timestrshort(i:integer):ansistring;\r
 550 const\r
 551   weekday:array[0..6] of ansistring =('Thu','Fri','Sat','Sun','Mon','Tue','Wed');\r
 552   month:array[0..11] of ansistring =('Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct','Nov','Dec');\r
 553 var\r
 554   y,m,d,h,min,sec,ms:word;\r
 555   t:tdatetime;\r
 556 begin\r
 557   t := unixtoole(i+timezone);\r
 558   decodedate(t,y,m,d);\r
 559   decodetime(t,h,min,sec,ms);\r
 560   result := weekday[(i+timezone) div 86400 mod 7]+' '+month[m-1]+' '+inttostr(d)+' '+\r
 561   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
 562   inttostr(y);\r
 563 end;\r
 564 \r
 565 function timestring(i:integer):ansistring;\r
 566 const\r
 567   weekday:array[0..6] of ansistring =('Thursday','Friday','Saturday','Sunday','Monday','Tuesday','Wednesday');\r
 568   month:array[0..11] of ansistring =('January','February','March','April','May','June','July','August','September','October','November','December');\r
 569 var\r
 570   y,m,d,h,min,sec,ms:word;\r
 571   t:tdatetime;\r
 572 begin\r
 573   t := unixtoole(i+timezone);\r
 574   decodedate(t,y,m,d);\r
 575   decodetime(t,h,min,sec,ms);\r
 576   result := weekday[(i+timezone) div 86400 mod 7]+' '+month[m-1]+' '+inttostr(d)+' '+inttostr(y)+' -- '+\r
 577   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
 578   timezonestr;\r
 579 end;\r
 580 \r
 581 procedure init;\r
 582 begin\r
 583   {$ifdef win32}timebeginperiod(1);{$endif} //ensure stable unchanging clock\r
 584   fillchar(mmtime_driftavg,sizeof(mmtime_driftavg),0);\r
 585   settimebias := 0;\r
 586   gettimezone;\r
 587   unixtime := unixtimeint;\r
 588   irctime := irctimeint;\r
 589 end;\r
 590 \r
 591 initialization init;\r
 592 \r
 593 end.\r