freepascal.compiler/rtl/unix/timezone.inc

{

  Support for timezone info in /usr/share/timezone
}

type

  ttzhead=packed record
    tzh_reserved : array[0..19] of byte;
    tzh_ttisgmtcnt,
    tzh_ttisstdcnt,
    tzh_leapcnt,
    tzh_timecnt,
    tzh_typecnt,
    tzh_charcnt  : longint;
  end;

  pttinfo=^tttinfo;
  tttinfo=packed record
    offset : longint;
    isdst  : boolean;
    idx    : byte;
    isstd  : byte;
    isgmt  : byte;
  end;

  pleap=^tleap;
  tleap=record
    transition : longint;
    change     : longint;
  end;

var
  num_transitions,
  num_leaps,
  num_types    : longint;

  transitions  : plongint = nil;
  type_idxs    : pbyte = Nil;
  types        : pttinfo = Nil;
  zone_names   : pchar = Nil;
  leaps        : pleap = Nil;

function find_transition(timer:longint;timerIsUTC:Boolean;var trans_start,trans_end:longint):pttinfo;
var
  i,L,R,CompareRes : longint;

  function DoCompare: longint;
  var
    timerUTC: LongInt;
  begin
    if not timerIsUTC then
      timerUTC:=timer-types[type_idxs[i-1]].offset
    else
      timerUTC:=timer;
    if timerUTC<transitions[i-1] then
      Exit(-1)
    else
    if timerUTC>=transitions[i] then
      Exit(1)
    else
      Exit(0);
  end;
begin
  if (num_transitions=0) or (timer<transitions[0]) then
   begin
     i:=0;
     while (i<num_types) and (types[i].isdst) do
      inc(i);
     if (i=num_types) then
      i:=0;
     { unknown transition boundaries }
     trans_start:=low(trans_start);
     trans_end:=high(trans_end);
   end
  else
   begin
      // Use binary search.
      L := 1;
      R := num_transitions-1;
      while (L<=R) do
      begin
        I := L + (R - L) div 2;
        CompareRes := DoCompare;
        if (CompareRes>0) then
          L := I+1
        else begin
          R := I-1;
          if (CompareRes=0) then
             L:=I; // break cycle
        end;
      end;

     trans_start:=transitions[i-1];
     trans_end:=transitions[i];
     i:=type_idxs[i-1];
   end;
  find_transition:=@types[i];
end;


procedure DoGetLocalTimezone(info:pttinfo;const trans_start,trans_end:longint;var ATZInfo:TTZInfo);
begin
  ATZInfo.validsince:=trans_start;
  ATZInfo.validuntil:=trans_end;
  ATZInfo.Daylight:=info^.isdst;
  ATZInfo.Seconds:=info^.offset;
end;

procedure DoGetLocalTimezoneEx(timer:cint;info:pttinfo;var ATZInfoEx:TTZInfoEx);
var
  i : longint;
  names: array[Boolean] of pchar;
begin
  names[true]:=nil;
  names[false]:=nil;
  ATZInfoEx.leap_hit:=0;
  ATZInfoEx.leap_correct:=0;

  i:=0;
  while (i<num_types) do
   begin
     names[types[i].isdst]:=@zone_names[types[i].idx];
     inc(i);
   end;
  names[info^.isdst]:=@zone_names[info^.idx];
  ATZInfoEx.name[true]:=names[true];
  ATZInfoEx.name[false]:=names[false];
  i:=num_leaps;
  repeat
    if i=0 then
     exit;
    dec(i);
  until (timer>leaps[i].transition);
  ATZInfoEx.leap_correct:=leaps[i].change;
  if (timer=leaps[i].transition) and
     (((i=0) and (leaps[i].change>0)) or
      (leaps[i].change>leaps[i-1].change)) then
   begin
     ATZInfoEx.leap_hit:=1;
     while (i>0) and
           (leaps[i].transition=leaps[i-1].transition+1) and
           (leaps[i].change=leaps[i-1].change+1) do
      begin
        inc(ATZInfoEx.leap_hit);
        dec(i);
      end;
   end;
end;

function GetLocalTimezone(timer:cint;timerIsUTC:Boolean;var ATZInfo:TTZInfo):Boolean;
var
  info: pttinfo;
  trans_start,trans_end: longint;
  timerUTC: cint;
begin
  { check if time is in current global Tzinfo }
  ATZInfo:=CurrentTZinfo[InterlockedExchangeAdd(CurrentTZindex, 0)];
  if not timerIsUTC then
    timerUTC:=timer-ATZInfo.seconds
  else
    timerUTC:=timer;
  if (ATZInfo.validsince<=timerUTC) and (timerUTC<ATZInfo.validuntil) then
    Exit(True);

  LockTZInfo;
  info:=find_transition(timer,timerIsUTC,trans_start,trans_end);
  GetLocalTimezone:=assigned(info);
  if GetLocalTimezone then
    DoGetLocalTimezone(info,trans_start,trans_end,ATZInfo);
  UnlockTZInfo;
end;

function GetLocalTimezone(timer:cint;timerIsUTC:Boolean;var ATZInfo:TTZInfo;var ATZInfoEx:TTZInfoEx):Boolean;
var
  info: pttinfo;
  trans_start,trans_end: longint;
  timerUTC: cint;
begin
  { check if time is in current global Tzinfo }
  ATZInfo:=CurrentTZinfo[InterlockedExchangeAdd(CurrentTZindex, 0)];
  if not timerIsUTC then
    timerUTC:=timer-ATZInfo.seconds
  else
    timerUTC:=timer;
  if (ATZInfo.validsince<=timerUTC) and (timerUTC<ATZInfo.validuntil) then
    begin
    ATZInfoEx:=TZInfoEx;
    Exit(True);
    end;

  { not current - search through all }
  LockTZInfo;
  info:=find_transition(timer,timerIsUTC,trans_start,trans_end);
  GetLocalTimezone:=assigned(info);
  if GetLocalTimezone then
    begin
    DoGetLocalTimezone(info,trans_start,trans_end,ATZInfo);
    DoGetLocalTimezoneEx(timer,info,ATZInfoEx);
    end;
  UnlockTZInfo;
end;

procedure RefreshTZInfo;
var
  NewTZInfo: TTZInfo;
  NewTZInfoEx: TTZInfoEx;
begin
  LockTZInfo;
  if GetLocalTimezone(fptime,false,NewTZInfo,NewTZInfoEx) then
    SetTZInfo(NewTZInfo,NewTZInfoEx);
  UnlockTZInfo;
end;

Const
  DefaultTimeZoneDir = '/usr/share/zoneinfo';

function TimeZoneDir : ShortString;

begin
  // Observe TZDIR environment variable.
  TimeZoneDir:=fpgetenv('TZDIR');
  if TimeZoneDir='' then
    TimeZoneDir:=DefaultTimeZoneDir;
  if TimeZoneDir[length(TimeZoneDir)]<>'/' then
    TimeZoneDir:=TimeZoneDir+'/';
end;

function ReadTimezoneFile(fn:string) : Boolean;

  procedure decode(var l:longint);
  var
    k : longint;
    p : pbyte;
  begin
    p:=pbyte(@l);
    if (p[0] and (1 shl 7))<>0 then
     k:=not 0
    else
     k:=0;
    k:=(k shl 8) or p[0];
    k:=(k shl 8) or p[1];
    k:=(k shl 8) or p[2];
    k:=(k shl 8) or p[3];
    l:=k;
  end;

const
  bufsize = 2048;
var
  buf    : array[0..bufsize-1] of byte;
  bufptr : pbyte;
  f      : longint;

  procedure readfilebuf;
  begin
    bufptr := @buf[0];
    fpread(f, buf, bufsize);
  end;

  function readbufbyte: byte;
  begin
    if bufptr > @buf[bufsize-1] then
      readfilebuf;
    readbufbyte := bufptr^;
    inc(bufptr);
  end;

  function readbuf(var dest; count: integer): integer;
  var
    numbytes: integer;
  begin
    readbuf := 0;
    repeat
      numbytes := (@buf[bufsize-1] + 1) - bufptr;
      if numbytes > count then
        numbytes := count;
      if numbytes > 0 then
      begin
        move(bufptr^, dest, numbytes);
        inc(bufptr, numbytes);
        dec(count, numbytes);
        inc(readbuf, numbytes);
      end;
      if count > 0 then
        readfilebuf
      else
        break;
    until false;
  end;

var
  tzdir  : shortstring;
  tzhead : ttzhead;
  i      : longint;
  chars  : longint;
begin
  LockTZInfo;
  if fn='' then
   fn:='localtime';
  if fn[1]<>'/' then
    fn:=TimeZoneDir+fn;
  f:=fpopen(fn,Open_RdOnly);
  if f<0 then
  begin
   UnlockTZInfo;
   exit(False);
  end;
  bufptr := @buf[bufsize-1]+1;
  i:=readbuf(tzhead,sizeof(tzhead));
  if i<>sizeof(tzhead) then
  begin
   UnlockTZInfo;
   exit(False);
  end;
  decode(tzhead.tzh_timecnt);
  decode(tzhead.tzh_typecnt);
  decode(tzhead.tzh_charcnt);
  decode(tzhead.tzh_leapcnt);
  decode(tzhead.tzh_ttisstdcnt);
  decode(tzhead.tzh_ttisgmtcnt);

  num_transitions:=tzhead.tzh_timecnt;
  num_types:=tzhead.tzh_typecnt;
  chars:=tzhead.tzh_charcnt;
  num_leaps:=tzhead.tzh_leapcnt;
  reallocmem(transitions,num_transitions*sizeof(longint));
  reallocmem(type_idxs,num_transitions);
  reallocmem(types,num_types*sizeof(tttinfo));
  reallocmem(zone_names,chars);
  reallocmem(leaps,num_leaps*sizeof(tleap));

  readbuf(transitions^,num_transitions*4);
  readbuf(type_idxs^,num_transitions);

  for i:=0 to num_transitions-1 do
   decode(transitions[i]);

  for i:=0 to num_types-1 do
   begin
     readbuf(types[i].offset,4);
     readbuf(types[i].isdst,1);
     readbuf(types[i].idx,1);
     decode(types[i].offset);
     types[i].isstd:=0;
     types[i].isgmt:=0;
   end;

  readbuf(zone_names^,chars);

  for i:=0 to num_leaps-1 do
   begin
     readbuf(leaps[i].transition,4);
     readbuf(leaps[i].change,4);
     decode(leaps[i].transition);
     decode(leaps[i].change);
   end;

  for i:=0 to tzhead.tzh_ttisstdcnt-1 do
   types[i].isstd:=byte(readbufbyte<>0);

  for i:=0 to tzhead.tzh_ttisgmtcnt-1 do
   types[i].isgmt:=byte(readbufbyte<>0);

  fpclose(f);
  ReadTimezoneFile:=True;
  UnlockTZInfo;
end;

Const
  // Debian system; contains location of timezone file.
  TimeZoneLocationFile = '/etc/timezone';
  // SuSE has link in /usr/lib/zoneinfo/localtime to /etc/localtime
  // RedHat uses /etc/localtime

  TimeZoneFile = '/etc/localtime';                      // POSIX
  AltTimeZoneFile = '/usr/lib/zoneinfo/localtime';      // Other
  iOSTimeZoneFile = '/var/db/timezone/localtime';      // iOS
{$ifdef BSD}
  BSDTimeZonefile = DefaultTimeZoneDir;      // BSD usually is POSIX
                                                // compliant though
{$ENDIF}

{$ifndef FPC_HAS_GETTIMEZONEFILE}

function GetTimezoneFile:shortstring;
var
  f,len : longint;
  fn,s : shortstring;
  info : stat;
begin
  GetTimezoneFile:='';
  // Observe TZ variable.
  fn:=fpgetenv('TZ');
  if (fn<>'') then
    if (fn[1]=':') then
      begin
      Delete(fn,1,1);
      if (fn<>'') then
        begin
        if (fn[1]<>'/') then 
          Exit(TimeZoneDir+fn);
        Exit(fn);  
        end;
      end;
  if (fn='') then
    fn:=TimeZoneLocationFile;
  f:=fpopen(TimeZoneLocationFile,Open_RdOnly);
  if f>0 then
    begin
    len:=fpread(f,s[1],high(s));
    s[0]:=chr(len);
    len:=pos(#10,s);
    if len<>0 then
     s[0]:=chr(len-1);
    fpclose(f);
    GetTimezoneFile:=s;
    end
  // Try SuSE
  else if fpstat(TimeZoneFile,{$ifdef oldlinuxstat}baseunix.stat(info){$else}info{$endif})>=0 then
    GetTimeZoneFile:=TimeZoneFile
  // Try RedHat
  else If fpstat(AltTimeZoneFile,{$ifdef oldlinuxstat}baseunix.stat(info){$else}info{$endif})>=0 then
      GetTimeZoneFile:=AltTimeZoneFile
{$ifdef BSD}
//  else
//       If fpstat(BSDTimeZoneFile,{$ifdef oldlinuxstat}baseunix.stat(info){$else}info{$endif})>=0 then
// GetTimeZoneFile:=BSDTimeZoneFile
{$ENDIF}
{$if (defined(darwin) and defined(arm)) or defined(iphonesim)}
  else If fpstat(iOSTimeZoneFile,info)>=0 then
      GetTimeZoneFile:=iOSTimeZoneFile
{$endif}
end;

{$endif ndef FPC_HAS_GETTIMEZONEFILE}

procedure InitLocalTime;
begin
  ReadTimezoneFile(GetTimezoneFile);
  RefreshTZInfo;
end;


procedure DoneLocalTime;
begin
  if assigned(transitions) then
   freemem(transitions);
  transitions:=nil;
  if assigned(type_idxs) then
   freemem(type_idxs);
  type_idxs:=nil;
  if assigned(types) then
   freemem(types);
  types:=nil;
  if assigned(zone_names) then
   freemem(zone_names);
  zone_names:=Nil;
  if assigned(leaps) then
   freemem(leaps);
  leaps:=nil;
  num_transitions:=0;
  num_leaps:=0;
  num_types:=0;
end;

Procedure ReReadLocalTime;

begin
  LockTZInfo;
  DoneLocalTime;
  InitLocalTime;
  UnlockTZInfo;
end;