btime.pas

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