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

Contents of /trunk/btime.pas

Parent Directory Parent Directory | Revision Log Revision Log


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