/[lcore]/trunk/btime.pas
ViewVC logotype

Annotation of /trunk/btime.pas

Parent Directory Parent Directory | Revision Log Revision Log


Revision 60 - (hide annotations)
Thu Nov 12 20:47:41 2009 UTC (11 years, 7 months ago) by plugwash
File size: 16026 byte(s)
add support for fpc 2.2.4rc1

1 plugwash 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 beware 2
11 plugwash 1 unit btime;
12    
13     interface
14    
15     type
16     float=extended;
17    
18 beware 2 const
19     colorburst=39375000/11; {3579545.4545....}
20    
21 plugwash 1 var
22     timezone:integer;
23     timezonestr:string;
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):string;
43     function timestrshort(i:integer):string;
44    
45 beware 2 {$ifdef win32}
46     function unixtimefloat_systemtime:float;
47     {$endif}
48    
49 plugwash 1 function oletounixfloat(t:float):float;
50     function oletounix(t:tdatetime):integer;
51     function unixtoole(i:integer):tdatetime;
52    
53 beware 2 {$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 plugwash 1 var
63 beware 2 //this flag is to be set when btime has been running long enough to stabilise
64     warmup_finished:boolean;
65    
66 plugwash 1 timefloatbias:float;
67 beware 2 ticks_freq:float=0;
68     ticks_freq2:float=0;
69     ticks_freq_known:boolean=false;
70 plugwash 1 lastunixtimefloat:float=0;
71 beware 2 lastsynctime:float=0;
72     lastsyncbias:float=0;
73 plugwash 1
74 beware 2 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 plugwash 1 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 plugwash 60 baseunix,unix,unixutil,sockets, {unixutil and sockets needed by unixstuff.inc on some compiler versions}
100 plugwash 1 {$endif}
101     {$else}
102 beware 2 windows,unitsettc,mmsystem,
103 plugwash 1 {$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 beware 2 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 plugwash 1 {$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 beware 2 {
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 plugwash 1 { 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 beware 2 function unixtimefloat_systemtime:float;
437 plugwash 1 begin
438 beware 2 {result := oletounixfloat(now_utc);}
439 plugwash 1
440 beware 2 {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 plugwash 1 end;
443    
444 beware 2 function wintimefloat:extended;
445 plugwash 1 begin
446 beware 2 result := mmqpctimefloat;
447 plugwash 1 end;
448    
449     function unixtimefloat:float;
450 beware 2 const
451     margin = 0.0012;
452 plugwash 1 var
453     f,g,h:float;
454     begin
455 beware 2 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 plugwash 1 settc;
461 beware 2 repeat g := unixtimefloat_systemtime; h := wintimefloat until g > f;
462 plugwash 1 unsettc;
463 beware 2 timefloatbias := g-h;
464 plugwash 1 result := unixtimefloat;
465     end;
466    
467 beware 2 {for small changes backwards, guarantee no steps backwards}
468     if (result <= lastunixtimefloat) and (result > lastunixtimefloat-1.5) then result := lastunixtimefloat + 0.0000001;
469 plugwash 1 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 + 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);
547     end;
548    
549     function timestrshort(i:integer):string;
550     const
551     weekday:array[0..6] of string[4]=('Thu','Fri','Sat','Sun','Mon','Tue','Wed');
552     month:array[0..11] of string[4]=('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):string;
566     const
567     weekday:array[0..6] of string[10]=('Thursday','Friday','Saturday','Sunday','Monday','Tuesday','Wednesday');
568     month:array[0..11] of string[10]=('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 beware 2 {$ifdef win32}timebeginperiod(1);{$endif} //ensure stable unchanging clock
584     fillchar(mmtime_driftavg,sizeof(mmtime_driftavg),0);
585 plugwash 1 settimebias := 0;
586     gettimezone;
587     unixtime := unixtimeint;
588     irctime := irctimeint;
589     end;
590    
591 beware 2 initialization init;
592    
593 plugwash 1 end.

Properties

Name Value
svn:executable

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