DateTime::TimeZone::Tzfile - tzfile (zoneinfo) timezone files

	use DateTime::TimeZone::Tzfile;

	$tz = DateTime::TimeZone::Tzfile->new(
		name => "local timezone",
		filename => "/etc/localtime");
	$tz = DateTime::TimeZone::Tzfile->new("/etc/localtime");

	if($tz->is_floating) { ...
	if($tz->is_utc) { ...
	if($tz->is_olson) { ...
	$category = $tz->category;
	$tz_string = $tz->name;

	if($tz->has_dst_changes) { ...
	if($tz->is_dst_for_datetime($dt)) { ...
	$offset = $tz->offset_for_datetime($dt);
	$abbrev = $tz->short_name_for_datetime($dt);
	$offset = $tz->offset_for_local_datetime($dt);

package DateTime::TimeZone::Tzfile;

{ use 5.006; }
use warnings;
use strict;

use Carp qw(croak);
use IO::File 1.13;
use IO::Handle 1.08;

our $VERSION = "0.005";

# _fdiv(A, B), _fmod(A, B): divide A by B, flooring remainder
#
# B must be a positive Perl integer.  A must be a Perl integer.

sub _fdiv($$) {
	my($a, $b) = @_;
	if($a < 0) {
		use integer;
		return -(($b - 1 - $a) / $b);
	} else {
		use integer;
		return $a / $b;
	}
}

sub _fmod($$) { $_[0] % $_[1] }

sub _saferead($$) {
	my($fh, $len) = @_;
	my $data;
	my $rlen = $fh->read($data, $len);
	croak "can't read tzfile: $!" unless defined($rlen);
	croak "bad tzfile: premature EOF" unless $rlen == $len;
	return $data;
}

sub _read_u32($) { unpack("N", _saferead($_[0], 4)) }

sub _read_s32($) {
	my $uval = _read_u32($_[0]);
	return ($uval & 0x80000000) ? ($uval & 0x7fffffff) - 0x80000000 :
				      $uval;
}

sub _read_u8($) { ord(_saferead($_[0], 1)) }

use constant UNIX_EPOCH_RDN => 719163;

sub _read_tm32($) {
	my $t = _read_s32($_[0]);
	return [ UNIX_EPOCH_RDN + _fdiv($t, 86400), _fmod($t, 86400) ];
}

sub _read_tm64($) {
	my($fh) = @_;
	my $th = _read_s32($fh);
	my $tl = _read_u32($fh);
	my $dh = _fdiv($th, 86400);
	$th = (_fmod($th, 86400) << 10) | ($tl >> 22);
	my $d2 = _fdiv($th, 86400);
	$th = (_fmod($th, 86400) << 10) | (($tl >> 12) & 0x3ff);
	my $d3 = _fdiv($th, 86400);
	$th = (_fmod($th, 86400) << 12) | ($tl & 0xfff);
	my $d4 = _fdiv($th, 86400);
	$th = _fmod($th, 86400);
	my $d = $dh * 4294967296 + $d2 * 4194304 + (($d3 << 12) + $d4);
	return [ UNIX_EPOCH_RDN + $d, $th ];
}

use constant FACTORY_ABBR => "Local time zone must be set--see zic manual page";

sub new {
	my $class = shift;
	unshift @_, "filename" if @_ == 1;
	my $self = bless({}, $class);
	my($filename, $fh);
	while(@_) {
		my $attr = shift;
		my $value = shift;
		if($attr eq "name") {
			croak "timezone name specified redundantly"
				if exists $self->{name};
			$self->{name} = $value;
		} elsif($attr eq "category") {
			croak "category value specified redundantly"
				if exists $self->{category};
			$self->{category} = $value;
		} elsif($attr eq "is_olson") {
			croak "is_olson flag specified redundantly"
				if exists $self->{is_olson};
			$self->{is_olson} = !!$value;
		} elsif($attr eq "filename") {
			croak "filename specified redundantly"
				if defined($filename) || defined($fh);
			$filename = $value;
		} elsif($attr eq "filehandle") {
			croak "filehandle specified redundantly"
				if defined($filename) || defined($fh);
			$fh = $value;
		} else {
			croak "unrecognised attribute `$attr'";
		}
	}
	croak "file not specified" unless defined($filename) || defined($fh);
	unless(exists $self->{name}) {
		croak "timezone name not specified" unless defined $filename;
		$self->{name} = $filename;
	}
	unless(exists $self->{category}) {
		$self->{category} = undef;
	}
	unless(exists $self->{is_olson}) {
		$self->{is_olson} = !!0;
	}
	if(defined $filename) {
		($fh = IO::File->new($filename, "r")) && $fh->binmode
			or croak "can't read $filename: $!";
	}
	croak "bad tzfile: wrong magic number"
		unless _saferead($fh, 4) eq "TZif";
	my $fmtversion = _saferead($fh, 1);
	_saferead($fh, 15);
	my($ttisgmtcnt, $ttisstdcnt, $leapcnt, $timecnt, $typecnt, $charcnt) =
		map { _read_u32($fh) } 1 .. 6;
	croak "bad tzfile: no local time types" if $typecnt == 0;
	my @trn_times = map { _read_tm32($fh) } 1 .. $timecnt;
	my @obs_types = map { _read_u8($fh) } 1 .. $timecnt;
	my @types = map {
		[ _read_s32($fh), !!_read_u8($fh), _read_u8($fh) ]
	} 1 .. $typecnt;
	my $chars = _saferead($fh, $charcnt);
	for(my $i = $leapcnt; $i--; ) { _saferead($fh, 8); }
	for(my $i = $ttisstdcnt; $i--; ) { _saferead($fh, 1); }
	for(my $i = $ttisgmtcnt; $i--; ) { _saferead($fh, 1); }
	my $late_rule;
	if($fmtversion eq "2") {
		croak "bad tzfile: wrong magic number"
			unless _saferead($fh, 4) eq "TZif";
		_saferead($fh, 16);
		($ttisgmtcnt, $ttisstdcnt, $leapcnt,
		 $timecnt, $typecnt, $charcnt) =
			map { _read_u32($fh) } 1 .. 6;
		croak "bad tzfile: no local time types" if $typecnt == 0;
		@trn_times = map { _read_tm64($fh) } 1 .. $timecnt;
		@obs_types = map { _read_u8($fh) } 1 .. $timecnt;
		@types = map {
			[ _read_s32($fh), !!_read_u8($fh), _read_u8($fh) ]
		} 1 .. $typecnt;
		$chars = _saferead($fh, $charcnt);
		for(my $i = $leapcnt; $i--; ) { _saferead($fh, 12); }
		for(my $i = $ttisstdcnt; $i--; ) { _saferead($fh, 1); }
		for(my $i = $ttisgmtcnt; $i--; ) { _saferead($fh, 1); }
		croak "bad tzfile: missing newline"
			unless _saferead($fh, 1) eq "\x0a";
		$late_rule = "";
		while(1) {
			my $c = _saferead($fh, 1);
			last if $c eq "\x0a";
			$late_rule .= $c;
		}
	}
	$fh = undef;
	for(my $i = @trn_times - 1; $i-- > 0; ) {
		unless(($trn_times[$i]->[0] <=> $trn_times[$i+1]->[0] ||
			$trn_times[$i]->[1] <=> $trn_times[$i+1]->[1]) == -1) {
			croak "bad tzfile: unsorted change times";
		}
	}
	my $first_std_type_index;
	my %offsets;
	for(my $i = 0; $i != $typecnt; $i++) {
		my $abbrind = $types[$i]->[2];
		croak "bad tzfile: invalid abbreviation index"
			if $abbrind > $charcnt;
		pos($chars) = $abbrind;
		$chars =~ /\G([^\0]*)/g;
		$types[$i]->[2] = $1;
		$first_std_type_index = $i
			if !defined($first_std_type_index) && !$types[$i]->[1];
		$self->{has_dst} = 1 if $types[$i]->[1];
		if($types[$i]->[0] == 0 && !$types[$i]->[1] &&
				$types[$i]->[2] eq "zzz") {
			# "zzz" means the zone is not defined at this time,
			# due for example to the location being uninhabited
			$types[$i] = undef;
		} else {
			$offsets{$types[$i]->[0]} = undef;
		}
	}
	unshift @obs_types,
		defined($first_std_type_index) ? $first_std_type_index : 0;
	foreach my $obs_type (@obs_types) {
		croak "bad tzfile: invalid local time type index"
			if $obs_type >= $typecnt;
		$obs_type = $types[$obs_type];
	}
	if(defined($late_rule) && $late_rule eq "<".FACTORY_ABBR.">0" &&
			defined($obs_types[-1]) && $obs_types[-1]->[0] == 0 &&
			!$obs_types[-1]->[1] &&
			$obs_types[-1]->[2] eq FACTORY_ABBR) {
		# This bizarre timezone abbreviation is used in the Factory
		# timezone in the Olson database.  It's not valid in a
		# SysV-style TZ value, because it contains spaces, but zic
		# puts it into one anyway because the file format demands
		# it.  DT:TZ:SystemV would object, so as a special
		# exception we ignore the TZ value in this case.
		$late_rule = undef;
	}
	if(defined $late_rule) {
		$obs_types[-1] = $late_rule eq "" ? undef : do {
			require DateTime::TimeZone::SystemV;
			DateTime::TimeZone::SystemV->VERSION("0.002");
			DateTime::TimeZone::SystemV->new($late_rule);
		};
	}
	$self->{trn_times} = \@trn_times;
	$self->{obs_types} = \@obs_types;
	$self->{offsets} = [ sort { $a <=> $b } keys %offsets ];
	return $self;
}

sub is_floating { 0 }

sub is_utc { 0 }

sub is_olson { $_[0]->{is_olson} }

sub category { $_[0]->{category} }

sub name { $_[0]->{name} }

sub has_dst_changes { $_[0]->{has_dst} }

#
# observance lookup
#

sub _type_for_rdn_sod {
	my($self, $utc_rdn, $utc_sod) = @_;
	my $lo = 0;
	my $hi = @{$self->{trn_times}};
	while($lo != $hi) {
		my $try = do { use integer; ($lo + $hi) / 2 };
		if(($utc_rdn <=> $self->{trn_times}->[$try]->[0] ||
		    $utc_sod <=> $self->{trn_times}->[$try]->[1]) == -1) {
			$hi = $try;
		} else {
			$lo = $try + 1;
		}
	}
	my $type = $self->{obs_types}->[$lo];
	croak "local time not defined for this time" unless defined $type;
	return $type;
}

sub _type_for_datetime {
	my($self, $dt) = @_;
	my($utc_rdn, $utc_sod) = $dt->utc_rd_values;
	$utc_sod = 86399 if $utc_sod >= 86400;
	return $self->_type_for_rdn_sod($utc_rdn, $utc_sod);
}

sub offset_for_datetime {
	my($self, $dt) = @_;
	my $type = $self->_type_for_datetime($dt);
	return ref($type) eq "ARRAY" ? $type->[0] :
		$type->offset_for_datetime($dt);
}

sub is_dst_for_datetime {
	my($self, $dt) = @_;
	my $type = $self->_type_for_datetime($dt);
	return ref($type) eq "ARRAY" ? $type->[1] :
		$type->is_dst_for_datetime($dt);
}

sub short_name_for_datetime {
	my($self, $dt) = @_;
	my $type = $self->_type_for_datetime($dt);
	return ref($type) eq "ARRAY" ? $type->[2] :
		$type->short_name_for_datetime($dt);
}

sub _local_to_utc_rdn_sod($$$) {
	my($rdn, $sod, $offset) = @_;
	$sod -= $offset;
	while($sod < 0) {
		$rdn--;
		$sod += 86400;
	}
	while($sod >= 86400) {
		$rdn++;
		$sod -= 86400;
	}
	return ($rdn, $sod);
}

sub offset_for_local_datetime {
	my($self, $dt) = @_;
	my($lcl_rdn, $lcl_sod) = $dt->local_rd_values;
	$lcl_sod = 86399 if $lcl_sod >= 86400;
	my $seen_undefined;
	foreach my $offset (@{$self->{offsets}}) {
		my($utc_rdn, $utc_sod) =
			_local_to_utc_rdn_sod($lcl_rdn, $lcl_sod, $offset);
		my $ttype = eval { local $SIG{__DIE__};
			$self->_type_for_rdn_sod($utc_rdn, $utc_sod);
		};
		unless(defined $ttype) {
			$seen_undefined = 1;
			next;
		}
		my $local_offset = ref($ttype) eq "ARRAY" ? $ttype->[0] :
			eval { local $SIG{__DIE__};
				$ttype->offset_for_local_datetime($dt);
			};
		return $offset
			if defined($local_offset) && $local_offset == $offset;
	}
	croak "non-existent local time due to ".
		($seen_undefined ? "zone disuse" : "offset change");
}

1;