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

Contents of /trunk/btime.pas

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1 - (show annotations)
Fri Mar 28 02:26:58 2008 UTC (13 years, 4 months ago) by plugwash
File size: 8471 byte(s)
initial import

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 unit btime;
11
12 interface
13
14 type
15 float=extended;
16
17 var
18 timezone:integer;
19 timezonestr:string;
20 irctime,unixtime:integer;
21 tickcount:integer;
22 settimebias:integer;
23 qpcjump:float; {can be read out and reset for debug purpose}
24 performancecountfreq:extended;
25
26 function irctimefloat:float;
27 function irctimeint:integer;
28
29 function unixtimefloat:float;
30 function unixtimeint:integer;
31
32 function wintimefloat:float;
33
34 procedure settime(newtime:integer);
35 procedure gettimezone;
36 procedure timehandler;
37 procedure init;
38
39 function timestring(i:integer):string;
40 function timestrshort(i:integer):string;
41
42 function oletounixfloat(t:float):float;
43 function oletounix(t:tdatetime):integer;
44 function unixtoole(i:integer):tdatetime;
45
46 var
47 timefloatbias:float;
48 lastunixtimefloat:float=0;
49
50 implementation
51
52 {$ifdef fpc}
53 {$mode delphi}
54 {$endif}
55
56 uses
57 {$ifdef UNIX}
58 {$ifdef VER1_0}
59 linux,
60 {$else}
61 baseunix,unix,unixutil,{needed for 2.0.2}
62 {$endif}
63 {$else}
64 windows,
65 {$endif}
66 sysutils;
67
68 {$include unixstuff.inc}
69
70
71 const
72 daysdifference=25569;
73
74 function oletounixfloat(t:float):float;
75 begin
76 t := (t - daysdifference) * 86400;
77 result := t;
78 end;
79
80 function oletounix(t:tdatetime):integer;
81 begin
82 result := trunc(oletounixfloat(t));
83 end;
84
85 function unixtoole(i:integer):tdatetime;
86 begin
87 result := ((i)/86400)+daysdifference;
88 end;
89
90 {$ifdef unix}
91 {-----------------------------------------*nix/freepascal code to read time }
92
93 function unixtimefloat:float;
94 var
95 tv:ttimeval;
96 begin
97 gettimeofday(tv);
98 result := tv.tv_sec+(tv.tv_usec/1000000);
99 end;
100
101 function wintimefloat:extended;
102 begin
103 result := unixtimefloat;
104 end;
105
106 function unixtimeint:integer;
107 var
108 tv:ttimeval;
109 begin
110 gettimeofday(tv);
111 result := tv.tv_sec;
112 end;
113
114 {$else} {delphi 3}
115 {------------------------------ windows/delphi code to read time}
116
117 { free pascals tsystemtime is incomaptible with windows api calls
118 so we declare it ourselves - plugwash
119 }
120 {$ifdef fpc}
121 type
122 TSystemTime = record
123 wYear: Word;
124 wMonth: Word;
125 wDayOfWeek: Word;
126 wDay: Word;
127 wHour: Word;
128 wMinute: Word;
129 wSecond: Word;
130 wMilliseconds: Word;
131 end;
132 {$endif}
133 function Date_utc: extended;
134 var
135 SystemTime: TSystemTime;
136 begin
137 {$ifdef fpc}
138 GetsystemTime(@SystemTime);
139 {$else}
140 GetsystemTime(SystemTime);
141 {$endif}
142 with SystemTime do Result := EncodeDate(wYear, wMonth, wDay);
143 end;
144
145 function Time_utc: extended;
146 var
147 SystemTime: TSystemTime;
148 begin
149 {$ifdef fpc}
150 GetsystemTime(@SystemTime);
151 {$else}
152 GetsystemTime(SystemTime);
153 {$endif}
154 with SystemTime do
155 Result := EncodeTime(wHour, wMinute, wSecond, wMilliSeconds);
156 end;
157
158 function Now_utc: extended;
159 begin
160 Result := round(Date_utc) + Time_utc;
161 end;
162
163 const
164 highdwordconst=4294967296.0;
165
166 function wintimefloat:extended;
167 var
168 p:packed record
169 lowpart:longint;
170 highpart:longint
171 end;
172 p2:tlargeinteger absolute p;
173 e:extended;
174 begin
175 if performancecountfreq = 0 then begin
176 QueryPerformancefrequency(p2);
177 e := p.lowpart;
178 if e < 0 then e := e + highdwordconst;
179 performancecountfreq := ((p.highpart*highdwordconst)+e);
180 end;
181 queryperformancecounter(p2);
182 e := p.lowpart;
183 if e < 0 then e := e + highdwordconst;
184 result := ((p.highpart*highdwordconst)+e)/performancecountfreq;
185 end;
186
187 var
188 classpriority,threadpriority:integer;
189
190 procedure settc;
191 var
192 hprocess,hthread:integer;
193 begin
194 hProcess := GetCurrentProcess;
195 hThread := GetCurrentThread;
196
197 ClassPriority := GetPriorityClass(hProcess);
198 ThreadPriority := GetThreadPriority(hThread);
199
200 SetPriorityClass(hProcess, REALTIME_PRIORITY_CLASS);
201 SetThreadPriority(hThread, THREAD_PRIORITY_TIME_CRITICAL);
202 end;
203
204 procedure unsettc;
205 var
206 hprocess,hthread:integer;
207 begin
208 hProcess := GetCurrentProcess;
209 hThread := GetCurrentThread;
210
211 SetPriorityClass(hProcess, ClassPriority);
212 SetThreadPriority(hThread, ThreadPriority);
213 end;
214
215 function unixtimefloat:float;
216 var
217 f,g,h:float;
218 begin
219 if timefloatbias = 0 then begin
220 settc;
221 f := now_utc;
222 repeat g := now_utc; h := wintimefloat until g > f;
223 timefloatbias := oletounixfloat(g)-h;
224 unsettc;
225 end;
226 result := wintimefloat+timefloatbias;
227
228 {
229 workaround for QPC jumps
230 (approach 2: always check "hi res" QPC unixtime against the "guaranteed" systemtime one)
231 }
232 f := result-(oletounixfloat(now_utc));
233 if abs(f) > 0.02 then begin
234 f := timefloatbias;
235 timefloatbias := 0;
236 result := unixtimefloat;
237 qpcjump := qpcjump + f - timefloatbias;
238 end;
239
240 if (result <= lastunixtimefloat) then result := lastunixtimefloat + 0.0000001;
241 lastunixtimefloat := result;
242 end;
243
244 function unixtimeint:integer;
245 begin
246 result := trunc(unixtimefloat);
247 end;
248
249 {$endif}
250 {-----------------------------------------------end of platform specific}
251
252 function irctimefloat:float;
253 begin
254 result := unixtimefloat+settimebias;
255 end;
256
257 function irctimeint:integer;
258 begin
259 result := unixtimeint+settimebias;
260 end;
261
262
263 procedure settime(newtime:integer);
264 var
265 a:integer;
266 begin
267 a := irctimeint-settimebias;
268 if newtime = 0 then settimebias := 0 else settimebias := newtime-a;
269
270 irctime := irctimeint;
271 end;
272
273 procedure timehandler;
274 begin
275 if unixtime = 0 then init;
276 unixtime := unixtimeint;
277 irctime := irctimeint;
278 if unixtime and 63 = 0 then begin
279 {update everything, apply timezone changes, clock changes, etc}
280 gettimezone;
281 timefloatbias := 0;
282 unixtime := unixtimeint;
283 irctime := irctimeint;
284 end;
285 end;
286
287
288 procedure gettimezone;
289 var
290 {$ifdef UNIX}
291 {$ifndef ver1_9_4}
292 {$ifndef ver1_0}
293 {$define above194}
294 {$endif}
295 {$endif}
296 {$ifndef above194}
297 hh,mm,ss:word;
298 {$endif}
299 {$endif}
300 l:integer;
301 begin
302 {$ifdef UNIX}
303 {$ifdef above194}
304 timezone := tzseconds;
305 {$else}
306 gettime(hh,mm,ss);
307 timezone := (longint(hh) * 3600 + mm * 60 + ss) - (unixtimeint mod 86400);
308 {$endif}
309 {$else}
310 timezone := round((now-now_utc)*86400);
311 {$endif}
312
313 while timezone > 43200 do dec(timezone,86400);
314 while timezone < -43200 do inc(timezone,86400);
315
316 if timezone >= 0 then timezonestr := '+' else timezonestr := '-';
317 l := abs(timezone) div 60;
318 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);
319 end;
320
321 function timestrshort(i:integer):string;
322 const
323 weekday:array[0..6] of string[4]=('Thu','Fri','Sat','Sun','Mon','Tue','Wed');
324 month:array[0..11] of string[4]=('Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct','Nov','Dec');
325 var
326 y,m,d,h,min,sec,ms:word;
327 t:tdatetime;
328 begin
329 t := unixtoole(i+timezone);
330 decodedate(t,y,m,d);
331 decodetime(t,h,min,sec,ms);
332 result := weekday[(i+timezone) div 86400 mod 7]+' '+month[m-1]+' '+inttostr(d)+' '+
333 inttostr(h div 10)+inttostr(h mod 10)+':'+inttostr(min div 10)+inttostr(min mod 10)+':'+inttostr(sec div 10)+inttostr(sec mod 10)+' '+
334 inttostr(y);
335 end;
336
337 function timestring(i:integer):string;
338 const
339 weekday:array[0..6] of string[10]=('Thursday','Friday','Saturday','Sunday','Monday','Tuesday','Wednesday');
340 month:array[0..11] of string[10]=('January','February','March','April','May','June','July','August','September','October','November','December');
341 var
342 y,m,d,h,min,sec,ms:word;
343 t:tdatetime;
344 begin
345 t := unixtoole(i+timezone);
346 decodedate(t,y,m,d);
347 decodetime(t,h,min,sec,ms);
348 result := weekday[(i+timezone) div 86400 mod 7]+' '+month[m-1]+' '+inttostr(d)+' '+inttostr(y)+' -- '+
349 inttostr(h div 10)+inttostr(h mod 10)+':'+inttostr(min div 10)+inttostr(min mod 10)+':'+inttostr(sec div 10)+inttostr(sec mod 10)+' '+
350 timezonestr;
351 end;
352
353 procedure init;
354 begin
355 qpcjump := 0;
356 settimebias := 0;
357 gettimezone;
358 unixtime := unixtimeint;
359 irctime := irctimeint;
360 end;
361
362 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