123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593 |
- { Copyright (C) 2005 Bas Steendijk and Peter Green
- For conditions of distribution and use, see copyright notice in zlib_license.txt
- which is included in the package
- ----------------------------------------------------------------------------- }
- {
- this unit returns unix timestamp with seconds and microseconds (as float)
- works on windows/delphi, and on freepascal on unix.
- }
-
-
- unit btime;
-
- interface
-
- type
- float=extended;
-
- const
- colorburst=39375000/11; {3579545.4545....}
-
- var
- timezone:integer;
- timezonestr:string;
- irctime,unixtime:integer;
- tickcount:integer;
- settimebias:integer;
- performancecountfreq:extended;
-
- function irctimefloat:float;
- function irctimeint:integer;
-
- function unixtimefloat:float;
- function unixtimeint:integer;
-
- function wintimefloat:float;
-
- procedure settime(newtime:integer);
- procedure gettimezone;
- procedure timehandler;
- procedure init;
-
- function timestring(i:integer):string;
- function timestrshort(i:integer):string;
-
- {$ifdef win32}
- function unixtimefloat_systemtime:float;
- {$endif}
-
- function oletounixfloat(t:float):float;
- function oletounix(t:tdatetime):integer;
- function unixtoole(i:integer):tdatetime;
-
- {$ifdef win32}
- function mmtimefloat:float;
- function qpctimefloat:float;
- {$endif}
-
- const
- mmtime_driftavgsize=32;
- mmtime_warmupnum=4;
- mmtime_warmupcyclelength=15;
- var
- //this flag is to be set when btime has been running long enough to stabilise
- warmup_finished:boolean;
-
- timefloatbias:float;
- ticks_freq:float=0;
- ticks_freq2:float=0;
- ticks_freq_known:boolean=false;
- lastunixtimefloat:float=0;
- lastsynctime:float=0;
- lastsyncbias:float=0;
-
- mmtime_last:integer=0;
- mmtime_wrapadd:float;
- mmtime_lastsyncmm:float=0;
- mmtime_lastsyncqpc:float=0;
- mmtime_drift:float=1;
- mmtime_lastresult:float;
- mmtime_nextdriftcorrection:float;
- mmtime_driftavg:array[0..mmtime_driftavgsize] of float;
- mmtime_synchedqpc:boolean;
-
- mmtime_prev_drift:float;
- mmtime_prev_lastsyncmm:float;
- mmtime_prev_lastsyncqpc:float;
-
- implementation
-
- {$ifdef fpc}
- {$mode delphi}
- {$endif}
-
- uses
- {$ifdef UNIX}
- {$ifdef VER1_0}
- linux,
- {$else}
- baseunix,unix,unixutil, {needed for 2.0.2}
- {$endif}
- {$else}
- windows,unitsettc,mmsystem,
- {$endif}
- sysutils;
-
- {$include unixstuff.inc}
-
-
- const
- daysdifference=25569;
-
- function oletounixfloat(t:float):float;
- begin
- t := (t - daysdifference) * 86400;
- result := t;
- end;
-
- function oletounix(t:tdatetime):integer;
- begin
- result := trunc(oletounixfloat(t));
- end;
-
- function unixtoole(i:integer):tdatetime;
- begin
- result := ((i)/86400)+daysdifference;
- end;
-
- const
- highdwordconst=65536.0 * 65536.0;
-
- function utrunc(f:float):integer;
- {converts float to integer, in 32 bits unsigned range}
- begin
- if f >= (highdwordconst/2) then f := f - highdwordconst;
- result := trunc(f);
- end;
-
- function uinttofloat(i:integer):float;
- {converts 32 bits unsigned integer to float}
- begin
- result := i;
- if result < 0 then result := result + highdwordconst;
- end;
-
- {$ifdef unix}
- {-----------------------------------------*nix/freepascal code to read time }
-
- function unixtimefloat:float;
- var
- tv:ttimeval;
- begin
- gettimeofday(tv);
- result := tv.tv_sec+(tv.tv_usec/1000000);
- end;
-
- function wintimefloat:extended;
- begin
- result := unixtimefloat;
- end;
-
- function unixtimeint:integer;
- var
- tv:ttimeval;
- begin
- gettimeofday(tv);
- result := tv.tv_sec;
- end;
-
- {$else} {delphi 3}
- {------------------------------ windows/delphi code to read time}
-
- {
- time float: gettickcount
- resolution: 9x: ~55 ms NT: 1/64th of a second
- guarantees: continuous without any jumps
- frequency base: same as system clock.
- epoch: system boot
- note: if called more than once per 49.7 days, 32 bits wrapping is compensated for and it keeps going on.
- note: i handle the timestamp as signed integer, but with the wrap compensation that works as well, and is faster
- }
-
- function mmtimefloat:float;
- const
- wrapduration=highdwordconst * 0.001;
- var
- i:integer;
- begin
- i := gettickcount; {timegettime}
- if i < mmtime_last then begin
- mmtime_wrapadd := mmtime_wrapadd + wrapduration;
- end;
- mmtime_last := i;
- result := mmtime_wrapadd + i * 0.001;
-
- 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
- end;
-
- procedure measure_ticks_freq;
- var
- f,g:float;
- o:tosversioninfo;
- isnt:boolean;
- is9x:boolean;
- begin
- if (performancecountfreq = 0) then qpctimefloat;
- ticks_freq_known := false;
- settc;
- f := mmtimefloat;
- repeat g := mmtimefloat until g > f;
- unsettc;
- f := g - f;
- fillchar(o,sizeof(o),0);
- o.dwOSVersionInfoSize := sizeof(o);
- getversionex(o);
- isnt := o.dwPlatformId = VER_PLATFORM_WIN32_NT;
- is9x := o.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS;
-
- ticks_freq2 := f;
- mmtime_synchedqpc := false;
- {
- NT 64 Hz
- identify mode as: nt64
- QPC rate: either 3579545 or TSC freq
- QPC synched to gettickcount: no
- duration between 2 ticks is constant: yes
- gettickcount tick duration: 64 Hz
- }
- if (f >= 0.014) and (f <= 0.018) and isnt then begin
- ticks_freq_known := true;
- ticks_freq := 1/64;
- mmtime_synchedqpc := false;
- end;
-
- {
- NT 100 Hz
- identify mode as: nt100
- QPC rate: 1193182
- QPC synched to gettickcount: yes
- duration between 2 ticks is constant: no?
- gettickcount tick duration: ~99.85 Hz
- }
- if (performancecountfreq = 1193182) and (f >= 0.008) and (f <= 0.012) and isnt then begin
- ticks_freq_known := true;
- ticks_freq2 := 11949 / (colorburst / 3);
- // ticks_freq2 := 11949 / 1193182;
- ticks_freq := 0;
- {the ticks freq should be very close to the real one but if it's not exact, it will cause drift and correction jumps}
- mmtime_synchedqpc := true;
- end;
-
- {9x}
- if (performancecountfreq = 1193182) and (g >= 0.050) and (g <= 0.060) then begin
- ticks_freq_known := true;
- ticks_freq := 65536 / (colorburst / 3);
- mmtime_synchedqpc := true;
- end;
- ticks_freq_known := true;
- if ticks_freq <> 0 then ticks_freq2 := ticks_freq;
- // writeln(formatfloat('0.000000',ticks_freq));
- end;
-
- {
- time float: QueryPerformanceCounter
- resolution: <1us
- guarantees: can have forward jumps depending on hardware. can have forward and backwards jitter on dual core.
- frequency base: on NT, not the system clock, drifts compared to it.
- epoch: system boot
- }
- function qpctimefloat:extended;
- var
- p:packed record
- lowpart:longint;
- highpart:longint
- end;
- p2:tlargeinteger absolute p;
- e:extended;
- begin
- if performancecountfreq = 0 then begin
- QueryPerformancefrequency(p2);
- e := p.lowpart;
- if e < 0 then e := e + highdwordconst;
- performancecountfreq := ((p.highpart*highdwordconst)+e);
- end;
- queryperformancecounter(p2);
- e := p.lowpart;
- if e < 0 then e := e + highdwordconst;
-
- result := ((p.highpart*highdwordconst)+e)/performancecountfreq;
- end;
-
- {
- time float: QPC locked to gettickcount
- resolution: <1us
- guarantees: continuous without any jumps
- frequency base: same as system clock.
- epoch: system boot
- }
-
- function mmqpctimefloat:float;
- const
- maxretries=5;
- margin=0.002;
- var
- jump:float;
- mm,f,qpc,newdrift,f1,f2:float;
- qpcjumped:boolean;
- a,b,c:integer;
- retrycount:integer;
- begin
- if not ticks_freq_known then measure_ticks_freq;
- retrycount := maxretries;
-
- qpc := qpctimefloat;
- mm := mmtimefloat;
- f := (qpc - mmtime_lastsyncqpc) * mmtime_drift + mmtime_lastsyncmm;
- //writeln('XXXX ',formatfloat('0.000000',qpc-mm));
- qpcjumped := ((f-mm) > ticks_freq2+margin) or ((f-mm) < -margin);
- // if qpcjumped then writeln('qpc jumped ',(f-mm));
- if ((qpc > mmtime_nextdriftcorrection) and not mmtime_synchedqpc) or qpcjumped then begin
-
- mmtime_nextdriftcorrection := qpc + 1;
- repeat
- mmtime_prev_drift := mmtime_drift;
- mmtime_prev_lastsyncmm := mmtime_lastsyncmm;
- mmtime_prev_lastsyncqpc := mmtime_lastsyncqpc;
-
- mm := mmtimefloat;
- dec(retrycount);
- settc;
- result := qpctimefloat;
- f := mmtimefloat;
- repeat
- if f = mm then result := qpctimefloat;
- f := mmtimefloat
- until f > mm;
- qpc := qpctimefloat;
-
- unsettc;
- if (qpc > result + 0.0001) then begin
- continue;
- end;
- mm := f;
-
- if (mmtime_lastsyncqpc <> 0) and not qpcjumped then begin
- newdrift := (mm - mmtime_lastsyncmm) / (qpc - mmtime_lastsyncqpc);
- mmtime_drift := newdrift;
- { writeln('raw drift: ',formatfloat('0.00000000',mmtime_drift));}
- move(mmtime_driftavg[0],mmtime_driftavg[1],sizeof(mmtime_driftavg[0])*high(mmtime_driftavg));
- mmtime_driftavg[0] := mmtime_drift;
-
- { write('averaging drift ',formatfloat('0.00000000',mmtime_drift),' -> ');}
- { mmtime_drift := 0;}
- b := 0;
- for a := 0 to high(mmtime_driftavg) do begin
- if mmtime_driftavg[a] <> 0 then inc(b);
- { mmtime_drift := mmtime_drift + mmtime_driftavg[a];}
- end;
- { mmtime_drift := mmtime_drift / b;}
- 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;
- mmtime_nextdriftcorrection := qpc + a;
- if (b >= 2) then warmup_finished := true;
- { writeln(formatfloat('0.00000000',mmtime_drift));}
- if mmtime_synchedqpc then mmtime_drift := 1;
- end;
-
- mmtime_lastsyncqpc := qpc;
- mmtime_lastsyncmm := mm;
- { writeln(formatfloat('0.00000000',mmtime_drift));}
- break;
- until false;
-
-
- qpc := qpctimefloat;
-
- result := (qpc - mmtime_lastsyncqpc) * mmtime_drift + mmtime_lastsyncmm;
- f := (qpc - mmtime_prev_lastsyncqpc) * mmtime_prev_drift + mmtime_prev_lastsyncmm;
-
- jump := result-f;
- {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)));}
-
- f := result;
- end;
-
- result := f;
-
- if (result < mmtime_lastresult) then result := mmtime_lastresult + 0.000001;
- mmtime_lastresult := result;
- end;
-
- { free pascals tsystemtime is incomaptible with windows api calls
- so we declare it ourselves - plugwash
- }
- {$ifdef fpc}
- type
- TSystemTime = record
- wYear: Word;
- wMonth: Word;
- wDayOfWeek: Word;
- wDay: Word;
- wHour: Word;
- wMinute: Word;
- wSecond: Word;
- wMilliseconds: Word;
- end;
- {$endif}
- function Date_utc: extended;
- var
- SystemTime: TSystemTime;
- begin
- {$ifdef fpc}
- GetsystemTime(@SystemTime);
- {$else}
- GetsystemTime(SystemTime);
- {$endif}
- with SystemTime do Result := EncodeDate(wYear, wMonth, wDay);
- end;
-
- function Time_utc: extended;
- var
- SystemTime: TSystemTime;
- begin
- {$ifdef fpc}
- GetsystemTime(@SystemTime);
- {$else}
- GetsystemTime(SystemTime);
- {$endif}
- with SystemTime do
- Result := EncodeTime(wHour, wMinute, wSecond, wMilliSeconds);
- end;
-
- function Now_utc: extended;
- begin
- Result := round(Date_utc) + Time_utc;
- end;
-
- function unixtimefloat_systemtime:float;
- begin
- {result := oletounixfloat(now_utc);}
-
- {this method gives exactly the same result with extended precision, but is less sensitive to float rounding in theory}
- result := oletounixfloat(int(date_utc+0.5))+time_utc*86400;
- end;
-
- function wintimefloat:extended;
- begin
- result := mmqpctimefloat;
- end;
-
- function unixtimefloat:float;
- const
- margin = 0.0012;
- var
- f,g,h:float;
- begin
- result := wintimefloat+timefloatbias;
- f := result-unixtimefloat_systemtime;
- if ((f > ticks_freq2+margin) or (f < -margin)) or (timefloatbias = 0) then begin
- // writeln('unixtimefloat init');
- f := unixtimefloat_systemtime;
- settc;
- repeat g := unixtimefloat_systemtime; h := wintimefloat until g > f;
- unsettc;
- timefloatbias := g-h;
- result := unixtimefloat;
- end;
-
- {for small changes backwards, guarantee no steps backwards}
- if (result <= lastunixtimefloat) and (result > lastunixtimefloat-1.5) then result := lastunixtimefloat + 0.0000001;
- lastunixtimefloat := result;
- end;
-
- function unixtimeint:integer;
- begin
- result := trunc(unixtimefloat);
- end;
-
- {$endif}
- {-----------------------------------------------end of platform specific}
-
- function irctimefloat:float;
- begin
- result := unixtimefloat+settimebias;
- end;
-
- function irctimeint:integer;
- begin
- result := unixtimeint+settimebias;
- end;
-
-
- procedure settime(newtime:integer);
- var
- a:integer;
- begin
- a := irctimeint-settimebias;
- if newtime = 0 then settimebias := 0 else settimebias := newtime-a;
-
- irctime := irctimeint;
- end;
-
- procedure timehandler;
- begin
- if unixtime = 0 then init;
- unixtime := unixtimeint;
- irctime := irctimeint;
- if unixtime and 63 = 0 then begin
- {update everything, apply timezone changes, clock changes, etc}
- gettimezone;
- timefloatbias := 0;
- unixtime := unixtimeint;
- irctime := irctimeint;
- end;
- end;
-
-
- procedure gettimezone;
- var
- {$ifdef UNIX}
- {$ifndef ver1_9_4}
- {$ifndef ver1_0}
- {$define above194}
- {$endif}
- {$endif}
- {$ifndef above194}
- hh,mm,ss:word;
- {$endif}
- {$endif}
- l:integer;
- begin
- {$ifdef UNIX}
- {$ifdef above194}
- timezone := tzseconds;
- {$else}
- gettime(hh,mm,ss);
- timezone := (longint(hh) * 3600 + mm * 60 + ss) - (unixtimeint mod 86400);
- {$endif}
- {$else}
- timezone := round((now-now_utc)*86400);
- {$endif}
-
- while timezone > 43200 do dec(timezone,86400);
- while timezone < -43200 do inc(timezone,86400);
-
- if timezone >= 0 then timezonestr := '+' else timezonestr := '-';
- l := abs(timezone) div 60;
- 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);
- end;
-
- function timestrshort(i:integer):string;
- const
- weekday:array[0..6] of string[4]=('Thu','Fri','Sat','Sun','Mon','Tue','Wed');
- month:array[0..11] of string[4]=('Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct','Nov','Dec');
- var
- y,m,d,h,min,sec,ms:word;
- t:tdatetime;
- begin
- t := unixtoole(i+timezone);
- decodedate(t,y,m,d);
- decodetime(t,h,min,sec,ms);
- result := weekday[(i+timezone) div 86400 mod 7]+' '+month[m-1]+' '+inttostr(d)+' '+
- inttostr(h div 10)+inttostr(h mod 10)+':'+inttostr(min div 10)+inttostr(min mod 10)+':'+inttostr(sec div 10)+inttostr(sec mod 10)+' '+
- inttostr(y);
- end;
-
- function timestring(i:integer):string;
- const
- weekday:array[0..6] of string[10]=('Thursday','Friday','Saturday','Sunday','Monday','Tuesday','Wednesday');
- month:array[0..11] of string[10]=('January','February','March','April','May','June','July','August','September','October','November','December');
- var
- y,m,d,h,min,sec,ms:word;
- t:tdatetime;
- begin
- t := unixtoole(i+timezone);
- decodedate(t,y,m,d);
- decodetime(t,h,min,sec,ms);
- result := weekday[(i+timezone) div 86400 mod 7]+' '+month[m-1]+' '+inttostr(d)+' '+inttostr(y)+' -- '+
- inttostr(h div 10)+inttostr(h mod 10)+':'+inttostr(min div 10)+inttostr(min mod 10)+':'+inttostr(sec div 10)+inttostr(sec mod 10)+' '+
- timezonestr;
- end;
-
- procedure init;
- begin
- {$ifdef win32}timebeginperiod(1);{$endif} //ensure stable unchanging clock
- fillchar(mmtime_driftavg,sizeof(mmtime_driftavg),0);
- settimebias := 0;
- gettimezone;
- unixtime := unixtimeint;
- irctime := irctimeint;
- end;
-
- initialization init;
-
- end.
|