/[lcore]/branches/delphi2010/btime.pas
ViewVC logotype

Contents of /branches/delphi2010/btime.pas

Parent Directory Parent Directory | Revision Log Revision Log


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

Properties

Name Value
svn:eol-style CRLF

No admin address has been configured">No admin address has been configured
ViewVC Help
Powered by ViewVC 1.1.22