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