+++ /dev/null
-{ Copyright (C) 2005 Bas Steendijk and Peter Green\r
- For conditions of distribution and use, see copyright notice in zlib_license.txt\r
- which is included in the package\r
- ----------------------------------------------------------------------------- }\r
-{\r
-this unit returns unix timestamp with seconds and microseconds (as float)\r
-works on windows/delphi, and on freepascal on unix.\r
-}\r
-\r
-unit btime;\r
-\r
-interface\r
-\r
-type\r
- float=extended;\r
-\r
-var\r
- timezone:integer;\r
- timezonestr:string;\r
- irctime,unixtime:integer;\r
- tickcount:integer;\r
- settimebias:integer;\r
- qpcjump:float; {can be read out and reset for debug purpose}\r
- performancecountfreq:extended;\r
-\r
-function irctimefloat:float;\r
-function irctimeint:integer;\r
-\r
-function unixtimefloat:float;\r
-function unixtimeint:integer;\r
-\r
-function wintimefloat:float;\r
-\r
-procedure settime(newtime:integer);\r
-procedure gettimezone;\r
-procedure timehandler;\r
-procedure init;\r
-\r
-function timestring(i:integer):string;\r
-function timestrshort(i:integer):string;\r
-\r
-function oletounixfloat(t:float):float;\r
-function oletounix(t:tdatetime):integer;\r
-function unixtoole(i:integer):tdatetime;\r
-\r
-var\r
- timefloatbias:float;\r
- lastunixtimefloat:float=0;\r
-\r
-implementation\r
-\r
-{$ifdef fpc}\r
- {$mode delphi}\r
-{$endif}\r
-\r
-uses\r
- {$ifdef UNIX}\r
- {$ifdef VER1_0}\r
- linux,\r
- {$else}\r
- baseunix,unix,unixutil, {needed for 2.0.2}\r
- {$endif}\r
- {$else}\r
- windows,\r
- {$endif}\r
- sysutils;\r
-\r
- {$include unixstuff.inc}\r
-\r
-\r
-const\r
- daysdifference=25569;\r
-\r
-function oletounixfloat(t:float):float;\r
-begin\r
- t := (t - daysdifference) * 86400;\r
- result := t;\r
-end;\r
-\r
-function oletounix(t:tdatetime):integer;\r
-begin\r
- result := trunc(oletounixfloat(t));\r
-end;\r
-\r
-function unixtoole(i:integer):tdatetime;\r
-begin\r
- result := ((i)/86400)+daysdifference;\r
-end;\r
-\r
-{$ifdef unix}\r
-{-----------------------------------------*nix/freepascal code to read time }\r
-\r
-function unixtimefloat:float;\r
-var\r
- tv:ttimeval;\r
-begin\r
- gettimeofday(tv);\r
- result := tv.tv_sec+(tv.tv_usec/1000000);\r
-end;\r
-\r
-function wintimefloat:extended;\r
-begin\r
- result := unixtimefloat;\r
-end;\r
-\r
-function unixtimeint:integer;\r
-var\r
- tv:ttimeval;\r
-begin\r
- gettimeofday(tv);\r
- result := tv.tv_sec;\r
-end;\r
-\r
-{$else} {delphi 3}\r
-{------------------------------ windows/delphi code to read time}\r
-\r
-{ free pascals tsystemtime is incomaptible with windows api calls\r
- so we declare it ourselves - plugwash\r
-}\r
-{$ifdef fpc}\r
-type\r
- TSystemTime = record\r
- wYear: Word;\r
- wMonth: Word;\r
- wDayOfWeek: Word;\r
- wDay: Word;\r
- wHour: Word;\r
- wMinute: Word;\r
- wSecond: Word;\r
- wMilliseconds: Word;\r
- end;\r
- {$endif}\r
-function Date_utc: extended;\r
-var\r
- SystemTime: TSystemTime;\r
-begin\r
- {$ifdef fpc}\r
- GetsystemTime(@SystemTime);\r
- {$else}\r
- GetsystemTime(SystemTime);\r
- {$endif}\r
- with SystemTime do Result := EncodeDate(wYear, wMonth, wDay);\r
-end;\r
-\r
-function Time_utc: extended;\r
-var\r
- SystemTime: TSystemTime;\r
-begin\r
- {$ifdef fpc}\r
- GetsystemTime(@SystemTime);\r
- {$else}\r
- GetsystemTime(SystemTime);\r
- {$endif}\r
- with SystemTime do\r
- Result := EncodeTime(wHour, wMinute, wSecond, wMilliSeconds);\r
-end;\r
-\r
-function Now_utc: extended;\r
-begin\r
- Result := round(Date_utc) + Time_utc;\r
-end;\r
-\r
-const\r
- highdwordconst=4294967296.0;\r
-\r
-function wintimefloat:extended;\r
-var\r
- p:packed record\r
- lowpart:longint;\r
- highpart:longint\r
- end;\r
- p2:tlargeinteger absolute p;\r
- e:extended;\r
-begin\r
- if performancecountfreq = 0 then begin\r
- QueryPerformancefrequency(p2);\r
- e := p.lowpart;\r
- if e < 0 then e := e + highdwordconst;\r
- performancecountfreq := ((p.highpart*highdwordconst)+e);\r
- end;\r
- queryperformancecounter(p2);\r
- e := p.lowpart;\r
- if e < 0 then e := e + highdwordconst;\r
- result := ((p.highpart*highdwordconst)+e)/performancecountfreq;\r
-end;\r
-\r
-var\r
- classpriority,threadpriority:integer;\r
-\r
-procedure settc;\r
-var\r
- hprocess,hthread:integer;\r
-begin\r
- hProcess := GetCurrentProcess;\r
- hThread := GetCurrentThread;\r
-\r
- ClassPriority := GetPriorityClass(hProcess);\r
- ThreadPriority := GetThreadPriority(hThread);\r
-\r
- SetPriorityClass(hProcess, REALTIME_PRIORITY_CLASS);\r
- SetThreadPriority(hThread, THREAD_PRIORITY_TIME_CRITICAL);\r
-end;\r
-\r
-procedure unsettc;\r
-var\r
- hprocess,hthread:integer;\r
-begin\r
- hProcess := GetCurrentProcess;\r
- hThread := GetCurrentThread;\r
-\r
- SetPriorityClass(hProcess, ClassPriority);\r
- SetThreadPriority(hThread, ThreadPriority);\r
-end;\r
-\r
-function unixtimefloat:float;\r
-var\r
- f,g,h:float;\r
-begin\r
- if timefloatbias = 0 then begin\r
- settc;\r
- f := now_utc;\r
- repeat g := now_utc; h := wintimefloat until g > f;\r
- timefloatbias := oletounixfloat(g)-h;\r
- unsettc;\r
- end;\r
- result := wintimefloat+timefloatbias;\r
-\r
- {\r
- workaround for QPC jumps\r
- (approach 2: always check "hi res" QPC unixtime against the "guaranteed" systemtime one)\r
- }\r
- f := result-(oletounixfloat(now_utc));\r
- if abs(f) > 0.02 then begin\r
- f := timefloatbias;\r
- timefloatbias := 0;\r
- result := unixtimefloat;\r
- qpcjump := qpcjump + f - timefloatbias;\r
- end;\r
-\r
- if (result <= lastunixtimefloat) then result := lastunixtimefloat + 0.0000001;\r
- lastunixtimefloat := result;\r
-end;\r
-\r
-function unixtimeint:integer;\r
-begin\r
- result := trunc(unixtimefloat);\r
-end;\r
-\r
-{$endif}\r
-{-----------------------------------------------end of platform specific}\r
-\r
-function irctimefloat:float;\r
-begin\r
- result := unixtimefloat+settimebias;\r
-end;\r
-\r
-function irctimeint:integer;\r
-begin\r
- result := unixtimeint+settimebias;\r
-end;\r
-\r
-\r
-procedure settime(newtime:integer);\r
-var\r
- a:integer;\r
-begin\r
- a := irctimeint-settimebias;\r
- if newtime = 0 then settimebias := 0 else settimebias := newtime-a;\r
-\r
- irctime := irctimeint;\r
-end;\r
-\r
-procedure timehandler;\r
-begin\r
- if unixtime = 0 then init;\r
- unixtime := unixtimeint;\r
- irctime := irctimeint;\r
- if unixtime and 63 = 0 then begin\r
- {update everything, apply timezone changes, clock changes, etc}\r
- gettimezone;\r
- timefloatbias := 0;\r
- unixtime := unixtimeint;\r
- irctime := irctimeint;\r
- end;\r
-end;\r
-\r
-\r
-procedure gettimezone;\r
-var\r
- {$ifdef UNIX}\r
- {$ifndef ver1_9_4}\r
- {$ifndef ver1_0}\r
- {$define above194}\r
- {$endif}\r
- {$endif}\r
- {$ifndef above194}\r
- hh,mm,ss:word;\r
- {$endif}\r
- {$endif}\r
- l:integer;\r
-begin\r
- {$ifdef UNIX}\r
- {$ifdef above194}\r
- timezone := tzseconds;\r
- {$else}\r
- gettime(hh,mm,ss);\r
- timezone := (longint(hh) * 3600 + mm * 60 + ss) - (unixtimeint mod 86400);\r
- {$endif}\r
- {$else}\r
- timezone := round((now-now_utc)*86400);\r
- {$endif}\r
-\r
- while timezone > 43200 do dec(timezone,86400);\r
- while timezone < -43200 do inc(timezone,86400);\r
-\r
- if timezone >= 0 then timezonestr := '+' else timezonestr := '-';\r
- l := abs(timezone) div 60;\r
- 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);\r
-end;\r
-\r
-function timestrshort(i:integer):string;\r
-const\r
- weekday:array[0..6] of string[4]=('Thu','Fri','Sat','Sun','Mon','Tue','Wed');\r
- month:array[0..11] of string[4]=('Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct','Nov','Dec');\r
-var\r
- y,m,d,h,min,sec,ms:word;\r
- t:tdatetime;\r
-begin\r
- t := unixtoole(i+timezone);\r
- decodedate(t,y,m,d);\r
- decodetime(t,h,min,sec,ms);\r
- result := weekday[(i+timezone) div 86400 mod 7]+' '+month[m-1]+' '+inttostr(d)+' '+\r
- inttostr(h div 10)+inttostr(h mod 10)+':'+inttostr(min div 10)+inttostr(min mod 10)+':'+inttostr(sec div 10)+inttostr(sec mod 10)+' '+\r
- inttostr(y);\r
-end;\r
-\r
-function timestring(i:integer):string;\r
-const\r
- weekday:array[0..6] of string[10]=('Thursday','Friday','Saturday','Sunday','Monday','Tuesday','Wednesday');\r
- month:array[0..11] of string[10]=('January','February','March','April','May','June','July','August','September','October','November','December');\r
-var\r
- y,m,d,h,min,sec,ms:word;\r
- t:tdatetime;\r
-begin\r
- t := unixtoole(i+timezone);\r
- decodedate(t,y,m,d);\r
- decodetime(t,h,min,sec,ms);\r
- result := weekday[(i+timezone) div 86400 mod 7]+' '+month[m-1]+' '+inttostr(d)+' '+inttostr(y)+' -- '+\r
- inttostr(h div 10)+inttostr(h mod 10)+':'+inttostr(min div 10)+inttostr(min mod 10)+':'+inttostr(sec div 10)+inttostr(sec mod 10)+' '+\r
- timezonestr;\r
-end;\r
-\r
-procedure init;\r
-begin\r
- qpcjump := 0;\r
- settimebias := 0;\r
- gettimezone;\r
- unixtime := unixtimeint;\r
- irctime := irctimeint;\r
-end;\r
-\r
-end.\r
lcore.org gitweb / lcore.git / blobdiff