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

Annotation of /trunk/btime.pas

Parent Directory Parent Directory | Revision Log Revision Log


Revision 155 - (hide annotations)
Sun Feb 23 19:27:13 2020 UTC (15 months, 3 weeks ago) by beware
File size: 21510 byte(s)
make unixtimeint and unixtimefloat work after 2038 on 32 bits unix. timezone is still broken.
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 plugwash 149 {$ifdef fpc}
13     {$mode delphi}
14     {$endif}
15 beware 150
16     {$include lcoreconfig.inc}
17    
18 plugwash 1 interface
19    
20 beware 127 {$ifdef mswindows}
21 beware 84 uses
22     ltimevalstuff;
23     {$endif}
24    
25 plugwash 1 type
26     float=extended;
27 beware 118 tunixtimeint={$ifdef ver100}longint;{$else}int64;{$endif}
28 plugwash 1
29 beware 2 const
30     colorburst=39375000/11; {3579545.4545....}
31    
32 plugwash 1 var
33     timezone:integer;
34     timezonestr:string;
35 beware 118 irctime,unixtime:tunixtimeint;
36 plugwash 1 tickcount:integer;
37 beware 118 settimebias:tunixtimeint;
38 plugwash 1 performancecountfreq:extended;
39 beware 152 btimenowin8:boolean;
40 plugwash 1
41     function irctimefloat:float;
42 beware 118 function irctimeint:tunixtimeint;
43 plugwash 1
44 beware 118 //unix timestamp (UTC) float seconds
45 plugwash 1 function unixtimefloat:float;
46 beware 118 function unixtimeint:tunixtimeint;
47 plugwash 1
48 beware 118 //monotonic float seconds
49     function monotimefloat:float;
50    
51     //monotonic (alias, old function name)
52 plugwash 1 function wintimefloat:float;
53    
54 beware 118 procedure settime(newtime:tunixtimeint);
55 plugwash 1 procedure gettimezone;
56     procedure timehandler;
57     procedure init;
58    
59 beware 119 function timestring(i:tunixtimeint):string; // Wednesday August 15 2012 -- 16:21:09 +02:00
60     function timestrshort(i:tunixtimeint):string; // Wed Aug 15 16:21:09 2012
61     function timestriso(i:tunixtimeint):string; // 2012-08-15 16:21:09
62     function timestrisoutc(i:float):string; // 2012-08-15T14:21:09.255553Z
63 plugwash 1
64 beware 150 procedure beginhightimerrate;
65     procedure endhightimerrate;
66    
67 beware 127 {$ifdef mswindows}
68 beware 2 function unixtimefloat_systemtime:float;
69     {$endif}
70    
71 plugwash 1 function oletounixfloat(t:float):float;
72 beware 118 function oletounix(t:tdatetime):tunixtimeint;
73 beware 88 function unixtoole(i:float):tdatetime;
74 plugwash 1
75 beware 127 {$ifdef mswindows}
76 beware 2 function mmtimefloat:float;
77     function qpctimefloat:float;
78     {$endif}
79    
80 beware 127 {$ifdef mswindows}
81 beware 84 procedure gettimeofday(var tv:ttimeval);
82     {$endif}
83    
84    
85 beware 2 const
86     mmtime_driftavgsize=32;
87     mmtime_warmupnum=4;
88     mmtime_warmupcyclelength=15;
89 plugwash 1 var
90 beware 2 //this flag is to be set when btime has been running long enough to stabilise
91     warmup_finished:boolean;
92    
93 plugwash 1 timefloatbias:float;
94 beware 2 ticks_freq:float=0;
95     ticks_freq2:float=0;
96     ticks_freq_known:boolean=false;
97 plugwash 1 lastunixtimefloat:float=0;
98 beware 2 lastsynctime:float=0;
99     lastsyncbias:float=0;
100 plugwash 1
101 beware 2 mmtime_last:integer=0;
102     mmtime_wrapadd:float;
103     mmtime_lastsyncmm:float=0;
104     mmtime_lastsyncqpc:float=0;
105     mmtime_drift:float=1;
106     mmtime_lastresult:float;
107     mmtime_nextdriftcorrection:float;
108     mmtime_driftavg:array[0..mmtime_driftavgsize] of float;
109     mmtime_synchedqpc:boolean;
110    
111     mmtime_prev_drift:float;
112     mmtime_prev_lastsyncmm:float;
113     mmtime_prev_lastsyncqpc:float;
114    
115 plugwash 1 implementation
116    
117    
118 plugwash 149
119 plugwash 1 uses
120     {$ifdef UNIX}
121     {$ifdef VER1_0}
122     linux,
123     {$else}
124 plugwash 60 baseunix,unix,unixutil,sockets, {unixutil and sockets needed by unixstuff.inc on some compiler versions}
125 plugwash 1 {$endif}
126 beware 118 {$ifdef linux}
127     dl,
128     {$endif}
129 plugwash 1 {$else}
130 beware 2 windows,unitsettc,mmsystem,
131 plugwash 1 {$endif}
132     sysutils;
133    
134     {$include unixstuff.inc}
135    
136    
137     const
138     daysdifference=25569;
139    
140     function oletounixfloat(t:float):float;
141     begin
142     t := (t - daysdifference) * 86400;
143     result := t;
144     end;
145    
146 beware 118 function oletounix(t:tdatetime):tunixtimeint;
147 plugwash 1 begin
148 beware 144 result := round(oletounixfloat(t));
149 plugwash 1 end;
150    
151 beware 88 function unixtoole(i:float):tdatetime;
152 plugwash 1 begin
153     result := ((i)/86400)+daysdifference;
154     end;
155    
156 beware 2 const
157     highdwordconst=65536.0 * 65536.0;
158    
159     function utrunc(f:float):integer;
160     {converts float to integer, in 32 bits unsigned range}
161     begin
162     if f >= (highdwordconst/2) then f := f - highdwordconst;
163     result := trunc(f);
164     end;
165    
166     function uinttofloat(i:integer):float;
167     {converts 32 bits unsigned integer to float}
168     begin
169     result := i;
170     if result < 0 then result := result + highdwordconst;
171     end;
172    
173 plugwash 1 {$ifdef unix}
174     {-----------------------------------------*nix/freepascal code to read time }
175    
176     function unixtimefloat:float;
177     var
178     tv:ttimeval;
179 beware 155 sec:tunixtimeint;
180 plugwash 1 begin
181     gettimeofday(tv);
182 beware 155 sec := tv.tv_sec;
183     {$ifndef cpu64}
184     if (sec < 0) then inc(sec,$100000000); //tv_sec is 32 bits
185     {$endif}
186     result := sec+(tv.tv_usec/1000000);
187 plugwash 1 end;
188    
189 beware 118 {$ifdef linux}
190     {$define monotimefloat_implemented}
191     const
192     CLOCK_MONOTONIC = 1;
193     type
194     ptimeval = ^ttimeval;
195     tclock_gettime = function(clk_id: integer; tp: ptimeval): integer; cdecl;
196 plugwash 1
197 beware 118 var
198     librt_handle:pointer;
199     librt_inited:boolean;
200     clock_gettime: tclock_gettime;
201    
202     function monotimefloat:float;
203     var
204     ts: ttimeval;
205     begin
206     if not librt_inited then begin
207     librt_inited := true;
208     clock_gettime := nil;
209     librt_handle := dlopen('librt.so', RTLD_LAZY);
210     if assigned(librt_handle) then begin
211     clock_gettime := dlsym(librt_handle, 'clock_gettime');
212     end;
213     end;
214     if assigned(clock_gettime) then begin
215     if clock_gettime(CLOCK_MONOTONIC, @ts) = 0 then begin
216     //note this really returns nanoseconds
217     result := ts.tv_sec + ts.tv_usec / 1000000000.0;
218     exit;
219     end;
220     end;
221     //fallback
222     result := unixtimefloat;
223     end;
224    
225    
226     {$endif} {linux}
227    
228     {$ifdef darwin} {mac OS X}
229     {$define monotimefloat_implemented}
230    
231     type
232     tmach_timebase_info = packed record
233     numer: longint;
234     denom: longint;
235     end;
236     pmach_timebase_info = ^tmach_timebase_info;
237    
238     function mach_absolute_time: int64; cdecl; external;
239     function mach_timebase_info(info: pmach_timebase_info): integer; cdecl; external;
240    
241     var
242     timebase_info: tmach_timebase_info;
243    
244     function monotimefloat:float;
245     var
246     i:int64;
247     begin
248     if timebase_info.denom = 0 then begin
249     mach_timebase_info(@timebase_info);
250     end;
251     i := mach_absolute_time;
252     result := (i * timebase_info.numer div timebase_info.denom) / 1000000000.0;
253     end;
254    
255     {$endif} {darwin, mac OS X}
256    
257    
258     {$ifndef monotimefloat_implemented} {fallback}
259    
260     function monotimefloat:extended;
261     begin
262     result := unixtimefloat;
263     end;
264    
265     {$endif} {monotimefloat fallback}
266    
267    
268     function unixtimeint:tunixtimeint;
269 plugwash 1 var
270     tv:ttimeval;
271 beware 155 sec:tunixtimeint;
272 plugwash 1 begin
273     gettimeofday(tv);
274 beware 155 sec := tv.tv_sec;
275     {$ifndef cpu64}
276     if (sec < 0) then inc(sec,$100000000); //tv_sec is 32 bits
277     {$endif}
278     result := sec;
279 plugwash 1 end;
280    
281 beware 118 {------------------------------ end of *nix/freepascal section}
282    
283 plugwash 1 {$else} {delphi 3}
284     {------------------------------ windows/delphi code to read time}
285    
286 beware 84
287     {simulate gettimeofday on windows so one can always use gettimeofday if preferred}
288    
289     procedure gettimeofday(var tv:ttimeval);
290     var
291     e:extended;
292     begin
293     e := unixtimefloat;
294     tv.tv_sec := round(int(e));
295     tv.tv_usec := trunc(frac(e)*1000000);
296     {just in case}
297     if (tv.tv_usec < 0) then tv.tv_usec := 0;
298     if (tv.tv_usec > 999999) then tv.tv_usec := 999999;
299     end;
300    
301    
302 beware 2 {
303     time float: gettickcount
304     resolution: 9x: ~55 ms NT: 1/64th of a second
305     guarantees: continuous without any jumps
306     frequency base: same as system clock.
307     epoch: system boot
308     note: if called more than once per 49.7 days, 32 bits wrapping is compensated for and it keeps going on.
309     note: i handle the timestamp as signed integer, but with the wrap compensation that works as well, and is faster
310     }
311    
312     function mmtimefloat:float;
313     const
314     wrapduration=highdwordconst * 0.001;
315     var
316     i:integer;
317 beware 118 temp:float;
318 beware 2 begin
319     i := gettickcount; {timegettime}
320     if i < mmtime_last then begin
321     mmtime_wrapadd := mmtime_wrapadd + wrapduration;
322     end;
323     mmtime_last := i;
324     result := mmtime_wrapadd + i * 0.001;
325    
326 beware 118 if (ticks_freq <> 0) and ticks_freq_known then begin
327     {the value we get is rounded to 1 ms, but the ticks are not a multiple of 1 ms
328     this makes the value noisy. use the known ticks frequency to restore the original value}
329     temp := int((result / ticks_freq)+0.5) * ticks_freq;
330    
331     {if the known ticks freq is wrong (can happen), disable the un-rounding behavior
332     this will be a bit less accurate but it prevents problems}
333     if abs(temp - result) > 0.002 then begin
334     ticks_freq := 0;
335     end else result := temp;
336     end;
337 beware 2 end;
338    
339     procedure measure_ticks_freq;
340     var
341     f,g:float;
342     o:tosversioninfo;
343     isnt:boolean;
344 beware 94 { is9x:boolean;}
345 beware 118 adjust1,adjust2:cardinal;
346     adjustbool:longbool;
347 beware 2 begin
348     if (performancecountfreq = 0) then qpctimefloat;
349     ticks_freq_known := false;
350     settc;
351     f := mmtimefloat;
352     repeat g := mmtimefloat until g > f;
353     unsettc;
354     f := g - f;
355     fillchar(o,sizeof(o),0);
356     o.dwOSVersionInfoSize := sizeof(o);
357     getversionex(o);
358     isnt := o.dwPlatformId = VER_PLATFORM_WIN32_NT;
359 beware 94 { is9x := o.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS;}
360 beware 2
361     ticks_freq2 := f;
362     mmtime_synchedqpc := false;
363 beware 117
364 beware 118 if (isnt and (o.dwMajorVersion >= 5)) then begin
365     {windows 2000 and later: query tick rate from OS in 100 ns units
366     typical rates: XP: 156250 or 100144, windows 7: 156001}
367     if GetSystemTimeAdjustment(adjust1,adjust2,adjustbool) then begin
368     ticks_freq := adjust1 / 10000000.0;
369     ticks_freq_known := true;
370     mmtime_synchedqpc := false;
371 beware 117 end;
372 beware 2 end;
373    
374     {9x}
375 beware 117 if (performancecountfreq = 1193182) and (f >= 0.050) and (f <= 0.060) then begin
376 beware 2 ticks_freq_known := true;
377     ticks_freq := 65536 / (colorburst / 3);
378     mmtime_synchedqpc := true;
379     end;
380     ticks_freq_known := true;
381     if ticks_freq <> 0 then ticks_freq2 := ticks_freq;
382     // writeln(formatfloat('0.000000',ticks_freq));
383     end;
384    
385     {
386     time float: QueryPerformanceCounter
387     resolution: <1us
388     guarantees: can have forward jumps depending on hardware. can have forward and backwards jitter on dual core.
389     frequency base: on NT, not the system clock, drifts compared to it.
390     epoch: system boot
391     }
392     function qpctimefloat:extended;
393     var
394     p:packed record
395     lowpart:longint;
396     highpart:longint
397     end;
398     p2:tlargeinteger absolute p;
399     e:extended;
400     begin
401     if performancecountfreq = 0 then begin
402     QueryPerformancefrequency(p2);
403     e := p.lowpart;
404     if e < 0 then e := e + highdwordconst;
405     performancecountfreq := ((p.highpart*highdwordconst)+e);
406     end;
407     queryperformancecounter(p2);
408     e := p.lowpart;
409     if e < 0 then e := e + highdwordconst;
410    
411     result := ((p.highpart*highdwordconst)+e)/performancecountfreq;
412     end;
413    
414     {
415     time float: QPC locked to gettickcount
416     resolution: <1us
417     guarantees: continuous without any jumps
418     frequency base: same as system clock.
419     epoch: system boot
420     }
421    
422     function mmqpctimefloat:float;
423     const
424     maxretries=5;
425     margin=0.002;
426     var
427 beware 94 { jump:float;}
428     mm,f,qpc,newdrift:float;
429 beware 2 qpcjumped:boolean;
430 beware 94 a,b:integer;
431     { retrycount:integer;}
432 beware 2 begin
433     if not ticks_freq_known then measure_ticks_freq;
434 beware 94 { retrycount := maxretries;}
435 beware 2
436     qpc := qpctimefloat;
437     mm := mmtimefloat;
438     f := (qpc - mmtime_lastsyncqpc) * mmtime_drift + mmtime_lastsyncmm;
439     //writeln('XXXX ',formatfloat('0.000000',qpc-mm));
440     qpcjumped := ((f-mm) > ticks_freq2+margin) or ((f-mm) < -margin);
441     // if qpcjumped then writeln('qpc jumped ',(f-mm));
442     if ((qpc > mmtime_nextdriftcorrection) and not mmtime_synchedqpc) or qpcjumped then begin
443    
444     mmtime_nextdriftcorrection := qpc + 1;
445     repeat
446     mmtime_prev_drift := mmtime_drift;
447     mmtime_prev_lastsyncmm := mmtime_lastsyncmm;
448     mmtime_prev_lastsyncqpc := mmtime_lastsyncqpc;
449    
450     mm := mmtimefloat;
451 beware 94 { dec(retrycount);}
452 beware 2 settc;
453     result := qpctimefloat;
454     f := mmtimefloat;
455     repeat
456     if f = mm then result := qpctimefloat;
457     f := mmtimefloat
458     until f > mm;
459     qpc := qpctimefloat;
460    
461     unsettc;
462     if (qpc > result + 0.0001) then begin
463     continue;
464     end;
465     mm := f;
466    
467     if (mmtime_lastsyncqpc <> 0) and not qpcjumped then begin
468     newdrift := (mm - mmtime_lastsyncmm) / (qpc - mmtime_lastsyncqpc);
469     mmtime_drift := newdrift;
470     { writeln('raw drift: ',formatfloat('0.00000000',mmtime_drift));}
471     move(mmtime_driftavg[0],mmtime_driftavg[1],sizeof(mmtime_driftavg[0])*high(mmtime_driftavg));
472     mmtime_driftavg[0] := mmtime_drift;
473    
474     { write('averaging drift ',formatfloat('0.00000000',mmtime_drift),' -> ');}
475     { mmtime_drift := 0;}
476     b := 0;
477     for a := 0 to high(mmtime_driftavg) do begin
478     if mmtime_driftavg[a] <> 0 then inc(b);
479     { mmtime_drift := mmtime_drift + mmtime_driftavg[a];}
480     end;
481     { mmtime_drift := mmtime_drift / b;}
482 beware 94 a := 5;
483 beware 2 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;
484     mmtime_nextdriftcorrection := qpc + a;
485     if (b >= 2) then warmup_finished := true;
486     { writeln(formatfloat('0.00000000',mmtime_drift));}
487     if mmtime_synchedqpc then mmtime_drift := 1;
488     end;
489    
490     mmtime_lastsyncqpc := qpc;
491     mmtime_lastsyncmm := mm;
492     { writeln(formatfloat('0.00000000',mmtime_drift));}
493     break;
494     until false;
495    
496    
497     qpc := qpctimefloat;
498    
499     result := (qpc - mmtime_lastsyncqpc) * mmtime_drift + mmtime_lastsyncmm;
500    
501 beware 94 {f := (qpc - mmtime_prev_lastsyncqpc) * mmtime_prev_drift + mmtime_prev_lastsyncmm;
502 beware 2 jump := result-f;
503 beware 94 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)));}
504 beware 2
505     f := result;
506     end;
507    
508     result := f;
509    
510 beware 116 if (result < mmtime_lastresult) then result := mmtime_lastresult;
511 beware 2 mmtime_lastresult := result;
512     end;
513    
514 beware 136 { free pascals tsystemtime is incompatible with windows api calls
515 plugwash 1 so we declare it ourselves - plugwash
516     }
517     {$ifdef fpc}
518     type
519     TSystemTime = record
520     wYear: Word;
521     wMonth: Word;
522     wDayOfWeek: Word;
523     wDay: Word;
524     wHour: Word;
525     wMinute: Word;
526     wSecond: Word;
527     wMilliseconds: Word;
528     end;
529     {$endif}
530     function Date_utc: extended;
531     var
532     SystemTime: TSystemTime;
533     begin
534     {$ifdef fpc}
535     GetsystemTime(@SystemTime);
536     {$else}
537     GetsystemTime(SystemTime);
538     {$endif}
539     with SystemTime do Result := EncodeDate(wYear, wMonth, wDay);
540     end;
541    
542     function Time_utc: extended;
543     var
544     SystemTime: TSystemTime;
545     begin
546     {$ifdef fpc}
547     GetsystemTime(@SystemTime);
548     {$else}
549     GetsystemTime(SystemTime);
550     {$endif}
551     with SystemTime do
552     Result := EncodeTime(wHour, wMinute, wSecond, wMilliSeconds);
553     end;
554    
555     function Now_utc: extended;
556     begin
557     Result := round(Date_utc) + Time_utc;
558     end;
559    
560 beware 2 function unixtimefloat_systemtime:float;
561 plugwash 1 begin
562 beware 2 {result := oletounixfloat(now_utc);}
563 plugwash 1
564 beware 2 {this method gives exactly the same result with extended precision, but is less sensitive to float rounding in theory}
565     result := oletounixfloat(int(date_utc+0.5))+time_utc*86400;
566 plugwash 1 end;
567    
568 beware 118 function monotimefloat:extended;
569 plugwash 1 begin
570 beware 2 result := mmqpctimefloat;
571 plugwash 1 end;
572    
573 beware 140
574    
575     var
576     GetSystemTimePreciseAsFileTime:procedure(var v:tfiletime); stdcall;
577     win8inited:boolean;
578    
579     procedure initwin8;
580     var
581     dllhandle:thandle;
582    
583     begin
584     win8inited := true;
585     dllhandle := loadlibrary('kernel32.dll');
586     if (dllhandle <> 0) then begin
587     GetSystemTimePreciseAsFileTime := getprocaddress(dllhandle,'GetSystemTimePreciseAsFileTime');
588     end;
589     end;
590    
591    
592     function unixtimefloat_win8:float;
593     var
594     ft:tfiletime;
595     i:int64 absolute ft;
596     begin
597     GetSystemTimePreciseAsFileTime(ft);
598     {change from windows 1601-01-01 to unix 1970-01-01.
599     use integer math for this, to preserve precision}
600     dec(i, 116444736000000000);
601     result := (i / 10000000);
602     end;
603    
604    
605    
606 plugwash 1 function unixtimefloat:float;
607 beware 2 const
608     margin = 0.0012;
609 plugwash 1 var
610     f,g,h:float;
611     begin
612 beware 152 if not btimenowin8 then begin
613     if not win8inited then initwin8;
614     if assigned(@GetSystemTimePreciseAsFileTime) then begin
615     result := unixtimefloat_win8;
616     exit;
617     end;
618 beware 140 end;
619    
620 beware 118 result := monotimefloat+timefloatbias;
621 beware 2 f := result-unixtimefloat_systemtime;
622     if ((f > ticks_freq2+margin) or (f < -margin)) or (timefloatbias = 0) then begin
623     // writeln('unixtimefloat init');
624     f := unixtimefloat_systemtime;
625 plugwash 1 settc;
626 beware 118 repeat g := unixtimefloat_systemtime; h := monotimefloat until g > f;
627 plugwash 1 unsettc;
628 beware 2 timefloatbias := g-h;
629 plugwash 1 result := unixtimefloat;
630     end;
631    
632 beware 2 {for small changes backwards, guarantee no steps backwards}
633     if (result <= lastunixtimefloat) and (result > lastunixtimefloat-1.5) then result := lastunixtimefloat + 0.0000001;
634 plugwash 1 lastunixtimefloat := result;
635     end;
636    
637 beware 118 function unixtimeint:tunixtimeint;
638 plugwash 1 begin
639     result := trunc(unixtimefloat);
640     end;
641    
642     {$endif}
643     {-----------------------------------------------end of platform specific}
644    
645 beware 118 function wintimefloat:float;
646     begin
647     result := monotimefloat;
648     end;
649    
650 plugwash 1 function irctimefloat:float;
651     begin
652     result := unixtimefloat+settimebias;
653     end;
654    
655 beware 118 function irctimeint:tunixtimeint;
656 plugwash 1 begin
657     result := unixtimeint+settimebias;
658     end;
659    
660    
661 beware 118 procedure settime(newtime:tunixtimeint);
662 plugwash 1 var
663 beware 118 a:tunixtimeint;
664 plugwash 1 begin
665     a := irctimeint-settimebias;
666     if newtime = 0 then settimebias := 0 else settimebias := newtime-a;
667    
668     irctime := irctimeint;
669     end;
670    
671     procedure timehandler;
672     begin
673     if unixtime = 0 then init;
674     unixtime := unixtimeint;
675     irctime := irctimeint;
676     if unixtime and 63 = 0 then begin
677     {update everything, apply timezone changes, clock changes, etc}
678     gettimezone;
679     timefloatbias := 0;
680     unixtime := unixtimeint;
681     irctime := irctimeint;
682     end;
683     end;
684    
685    
686     procedure gettimezone;
687     var
688     {$ifdef UNIX}
689     {$ifndef ver1_9_4}
690     {$ifndef ver1_0}
691     {$define above194}
692     {$endif}
693     {$endif}
694     {$ifndef above194}
695     hh,mm,ss:word;
696     {$endif}
697     {$endif}
698     l:integer;
699     begin
700     {$ifdef UNIX}
701     {$ifdef above194}
702     timezone := tzseconds;
703     {$else}
704     gettime(hh,mm,ss);
705     timezone := (longint(hh) * 3600 + mm * 60 + ss) - (unixtimeint mod 86400);
706     {$endif}
707     {$else}
708     timezone := round((now-now_utc)*86400);
709     {$endif}
710    
711     while timezone > 43200 do dec(timezone,86400);
712     while timezone < -43200 do inc(timezone,86400);
713    
714     if timezone >= 0 then timezonestr := '+' else timezonestr := '-';
715     l := abs(timezone) div 60;
716     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);
717     end;
718    
719 beware 118 function timestrshort(i:tunixtimeint):string;
720 plugwash 1 const
721     weekday:array[0..6] of string[4]=('Thu','Fri','Sat','Sun','Mon','Tue','Wed');
722     month:array[0..11] of string[4]=('Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct','Nov','Dec');
723     var
724     y,m,d,h,min,sec,ms:word;
725     t:tdatetime;
726     begin
727     t := unixtoole(i+timezone);
728     decodedate(t,y,m,d);
729     decodetime(t,h,min,sec,ms);
730     result := weekday[(i+timezone) div 86400 mod 7]+' '+month[m-1]+' '+inttostr(d)+' '+
731     inttostr(h div 10)+inttostr(h mod 10)+':'+inttostr(min div 10)+inttostr(min mod 10)+':'+inttostr(sec div 10)+inttostr(sec mod 10)+' '+
732     inttostr(y);
733     end;
734    
735 beware 118 function timestring(i:tunixtimeint):string;
736 plugwash 1 const
737     weekday:array[0..6] of string[10]=('Thursday','Friday','Saturday','Sunday','Monday','Tuesday','Wednesday');
738     month:array[0..11] of string[10]=('January','February','March','April','May','June','July','August','September','October','November','December');
739     var
740     y,m,d,h,min,sec,ms:word;
741     t:tdatetime;
742     begin
743     t := unixtoole(i+timezone);
744     decodedate(t,y,m,d);
745     decodetime(t,h,min,sec,ms);
746     result := weekday[(i+timezone) div 86400 mod 7]+' '+month[m-1]+' '+inttostr(d)+' '+inttostr(y)+' -- '+
747     inttostr(h div 10)+inttostr(h mod 10)+':'+inttostr(min div 10)+inttostr(min mod 10)+':'+inttostr(sec div 10)+inttostr(sec mod 10)+' '+
748     timezonestr;
749     end;
750    
751 beware 119 function timestriso(i:tunixtimeint):string;
752     var
753     y,m,d,h,min,sec,ms:word;
754     t:tdatetime;
755     begin
756     t := unixtoole(i+timezone);
757     decodedate(t,y,m,d);
758     decodetime(t,h,min,sec,ms);
759     result := inttostr(y)+'-'+inttostr(m div 10)+inttostr(m mod 10)+'-'+inttostr(d div 10)+inttostr(d mod 10)+' '+inttostr(h div 10)+inttostr(h mod 10)+':'+inttostr(min div 10)+inttostr(min mod 10)+':'+inttostr(sec div 10)+inttostr(sec mod 10);
760     end;
761    
762     function timestrisoutc(i:float):string;
763     var
764     y,m,d,h,min,sec,ms:word;
765     t:tdatetime;
766     fr:float;
767     begin
768     t := unixtoole(i);
769     decodedate(t,y,m,d);
770     decodetime(t,h,min,sec,ms);
771     result := inttostr(y)+'-'+inttostr(m div 10)+inttostr(m mod 10)+'-'+inttostr(d div 10)+inttostr(d mod 10)+'T'+inttostr(h div 10)+inttostr(h mod 10)+':'+inttostr(min div 10)+inttostr(min mod 10)+':'+inttostr(sec div 10)+inttostr(sec mod 10);
772     fr := frac(i);
773    
774     result := result + '.'+
775     inttostr(trunc(fr*10) mod 10)+
776     inttostr(trunc(fr*100) mod 10)+
777     inttostr(trunc(fr*1000) mod 10)+
778     inttostr(trunc(fr*10000) mod 10)+
779     inttostr(trunc(fr*100000) mod 10)+
780     inttostr(trunc(fr*1000000) mod 10)+'Z';
781    
782     end;
783    
784 beware 150 procedure beginhightimerrate;
785     begin
786     {$ifdef mswindows}timebeginperiod(1);{$endif}
787     end;
788 beware 119
789 beware 150 procedure endhightimerrate;
790     begin
791     {$ifdef mswindows}timeendperiod(1);{$endif}
792     end;
793    
794 plugwash 1 procedure init;
795     begin
796 beware 150 {$ifdef btimehighrate}beginhightimerrate;{$endif}
797 beware 2 fillchar(mmtime_driftavg,sizeof(mmtime_driftavg),0);
798 plugwash 1 settimebias := 0;
799     gettimezone;
800     unixtime := unixtimeint;
801     irctime := irctimeint;
802     end;
803    
804 beware 2 initialization init;
805    
806 plugwash 1 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.26