File Coverage

blib/lib/DateTimeX/Lite/TimeZone.pm

Criterion	Covered	Total	%
statement	220	230	95.6
branch	78	96	81.2
condition	27	33	81.8
subroutine	49	50	98.0
pod	19	26	73.0
total	393	435	90.3

package DateTimeX::Lite::TimeZone;
use strict;
use warnings;

use Carp ();
use DateTimeX::Lite::TimeZone::Catalog;
use DateTimeX::Lite::TimeZone::Floating;
use DateTimeX::Lite::TimeZone::Local;
use DateTimeX::Lite::TimeZone::OffsetOnly;
use DateTimeX::Lite::TimeZone::UTC;
use DateTimeX::Lite::OlsonDB;
use File::ShareDir qw(dist_file);

our %CachedTimeZones;

# the offsets for each span element
use constant UTC_START   => 0;
use constant UTC_END     => 1;
use constant LOCAL_START => 2;
use constant LOCAL_END   => 3;
use constant OFFSET      => 4;
use constant IS_DST      => 5;
use constant SHORT_NAME  => 6;

my %SpecialName = map { $_ => 1 } qw( EST MST HST CET EET MET WET EST5EDT CST6CDT MST7MDT PST8PDT );

sub load {
    my ($class, %p) = @_;

    my $name = $p{name};
    my $conf;
    my $zone;
    if (defined $name) {
        my $links = \%DateTimeX::Lite::TimeZone::Catalog::LINKS;
        if ( exists $links->{ $name } ) {
            $name = $links->{ $name };
        } elsif ( exists $links->{ uc $name } ) {
            $name = $links->{ uc $name };
        }
    }

    if (defined $name) {
        return $CachedTimeZones{$name} if $CachedTimeZones{$name};
        unless ( $name =~ m,/, || $SpecialName{ $name }) {
            if ( $name eq 'floating' ) {
                return $CachedTimeZones{$name} = DateTimeX::Lite::TimeZone::Floating->new;
            }
            if ( $name eq 'local' ) {
                return $CachedTimeZones{$name} = DateTimeX::Lite::TimeZone::Local->TimeZone();
            }

            if ( $name eq 'UTC' || $name eq 'Z' ) {
                return $CachedTimeZones{$name} = DateTimeX::Lite::TimeZone::UTC->new;
            }

            return $CachedTimeZones{$name} = DateTimeX::Lite::TimeZone::OffsetOnly->new( offset => $name );
        }
        $conf = _load_time_zone($name);
    }

    if (! $conf) {
        my $x = $ENV{DATETIMEX_LITE_DEBUG} ? \&Carp::confess : \&Carp::croak ;
        $x->( "The timezone '" . ($p{name} || 'undef') . "' could not be loaded, or is an invalid name.\n" );
    }

    $zone = $class->new(%$conf);

    if ( $zone->is_olson() ) {
        my $object_version =
            $zone->can('olson_version')
            ? $zone->olson_version()
            : 'unknown';
        my $catalog_version = DateTimeX::Lite::TimeZone::Catalog->OlsonVersion();

        if ( $object_version ne $catalog_version )
        {
            warn "Loaded $name, which is from an older version ($object_version) of the Olson database than this installation of DateTimeX::Lite::TimeZone ($catalog_version).\n";
        }
    }

    $CachedTimeZones{$name} = $zone;
    return $zone;
}

sub new { my $class = shift; bless { @_ }, $class }

sub _load_time_zone {
    my $name = shift;
    my $file = "$name.dat";
    $file =~ s/-/_/g;

    # Quietly fail here, so we can let the proceeding section croak for us
    eval {
        $file = dist_file( 'DateTimeX-Lite', "DateTimeX/Lite/TimeZone/$file");
    };
    return $file ? do $file : ();
}

sub rules { $_[0]->{rules} }
sub max_year { $_[0]->{max_year} }
sub last_offset { $_[0]->{last_offset} }
sub last_observance { $_[0]->{last_observance} }

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

sub is_dst_for_datetime
{
    my $self = shift;

    my $span = $self->_span_for_datetime( 'utc', $_[0] );

    return $span->[IS_DST];
}

sub offset_for_datetime
{
    my $self = shift;

    my $span = $self->_span_for_datetime( 'utc', $_[0] );

    return $span->[OFFSET];
}

sub offset_for_local_datetime
{
    my $self = shift;

    my $span = $self->_span_for_datetime( 'local', $_[0] );

    return $span->[OFFSET];
}

sub short_name_for_datetime
{
    my $self = shift;

    my $span = $self->_span_for_datetime( 'utc', $_[0] );

    return $span->[SHORT_NAME];
}

sub _span_for_datetime
{
    my $self = shift;
    my $type = shift;
    my $dt   = shift;

    my $method = $type . '_rd_as_seconds';

    my $end = $type eq 'utc' ? UTC_END : LOCAL_END;

    my $span;
    my $seconds = $dt->$method();
    if ( $seconds < $self->max_span->[$end] )
    {
        $span = $self->_spans_binary_search( $type, $seconds );
    }
    else
    {
        my $until_year = $dt->utc_year + 1;
        $span = $self->_generate_spans_until_match( $until_year, $seconds, $type );
    }

    # This means someone gave a local time that doesn't exist
    # (like during a transition into savings time)
    unless ( defined $span )
    {
        my $err = 'Invalid local time for date';
        $err .= ' ' . $dt->iso8601 if $type eq 'utc';
        $err .= " in time zone: " . $self->name;
        $err .= "\n";

        die $err;
    }

    return $span;
}

sub _spans_binary_search
{
    my $self = shift;
    my ( $type, $seconds ) = @_;

    my ( $start, $end ) = _keys_for_type($type);

    my $min = 0;
    my $max = scalar @{ $self->{spans} } + 1;
    my $i = int( $max / 2 );
    # special case for when there are only 2 spans
    $i++ if $max % 2 && $max != 3;

    $i = 0 if @{ $self->{spans} } == 1;

    while (1)
    {
        my $current = $self->{spans}[$i];
        if ( $seconds < $current->[$start] )
        {
            $max = $i;
            my $c = int( ( $i - $min ) / 2 );
            $c ||= 1;

            $i -= $c;

            return if $i < $min;
        }
        elsif ( $seconds >= $current->[$end] )
        {
            $min = $i;
            my $c = int( ( $max - $i ) / 2 );
            $c ||= 1;

            $i += $c;

            return if $i >= $max;
        }
        else
        {
            # Special case for overlapping ranges because of DST and
            # other weirdness (like Alaska's change when bought from
            # Russia by the US).  Always prefer latest span.
            if ( $current->[IS_DST] && $type eq 'local' )
            {
                my $next = $self->{spans}[$i + 1];
                # Sometimes we will get here and the span we're
                # looking at is the last that's been generated so far.
                # We need to try to generate one more or else we run
                # out.
                $next ||= $self->_generate_next_span;

                die "No next span in $self->{max_year}" unless defined $next;

                if ( ( ! $next->[IS_DST] )
                     && $next->[$start] <= $seconds
                     && $seconds        <= $next->[$end]
                   )
                {
                    return $next;
                }
            }

            return $current;
        }
    }
}

sub _generate_next_span
{
    my $self = shift;

    my $last_idx = $#{ $self->{spans} };

    my $max_span = $self->max_span;

    # Kind of a hack, but AFAIK there are no zones where it takes
    # _more_ than a year for a _future_ time zone change to occur, so
    # by looking two years out we can ensure that we will find at
    # least one more span.  Of course, I will no doubt be proved wrong
    # and this will cause errors.
    $self->_generate_spans_until_match
        ( $self->{max_year} + 2, $max_span->[UTC_END] + ( 366 * 86400 ), 'utc' );

    return $self->{spans}[ $last_idx + 1 ];
}

sub _generate_spans_until_match
{
    my $self = shift;
    my $generate_until_year = shift;
    my $seconds = shift;
    my $type = shift;

    my @changes;
    my @rules = @{ $self->rules };
    foreach my $year ( $self->max_year .. $generate_until_year )
    {
        for ( my $x = 0; $x < @rules; $x++ )
        {
            my $last_offset_from_std;

            if ( @rules == 2 )
            {
                $last_offset_from_std =
                    $x ? $rules[0]->offset_from_std : $rules[1]->offset_from_std;
            }
            elsif ( @rules == 1 )
            {
                $last_offset_from_std = $rules[0]->offset_from_std;
            }
            else
            {
                my $count = scalar @rules;
                die "Cannot generate future changes for zone with $count infinite rules\n";
            }

            my $rule = $rules[$x];

            my $next =
                $rule->utc_start_datetime_for_year
                    ( $year, $self->last_offset, $last_offset_from_std );

            # don't bother with changes we've seen already
            next if $next->utc_rd_as_seconds < $self->max_span->[UTC_END];

            my $last_observance = $self->last_observance;
            push @changes,
                DateTimeX::Lite::OlsonDB::Change->new
                    ( type => 'rule',
                      utc_start_datetime   => $next,
                      local_start_datetime =>
                      $next +
                      DateTimeX::Lite::Duration->new
                          ( seconds => $last_observance->total_offset +
                                       $rule->offset_from_std ),
                      short_name =>
                      sprintf( $last_observance->format, $rule->letter ),
                      observance => $last_observance,
                      rule       => $rule,
                    );
        }
    }

    $self->{max_year} = $generate_until_year;

    my @sorted = sort { $a->utc_start_datetime <=> $b->utc_start_datetime } @changes;

    my ( $start, $end ) = _keys_for_type($type);

    my $match;
    for ( my $x = 1; $x < @sorted; $x++ )
    {
        my $last_total_offset =
            $x == 1 ? $self->max_span->[OFFSET] : $sorted[ $x - 2 ]->total_offset;

        my $span =
            DateTimeX::Lite::OlsonDB::Change::two_changes_as_span
                ( @sorted[ $x - 1, $x ], $last_total_offset );

        $span = _span_as_array($span);

        push @{ $self->{spans} }, $span;

        $match = $span
            if $seconds >= $span->[$start] && $seconds < $span->[$end];
    }

    return $match;
}

sub max_span { $_[0]->{spans}[-1] }

sub _keys_for_type
{
    $_[0] eq 'utc' ? ( UTC_START, UTC_END ) : ( LOCAL_START, LOCAL_END );
}

sub _span_as_array
{
    [ @{ $_[0] }{ qw( utc_start utc_end local_start local_end offset is_dst short_name ) } ];
}

sub is_floating { 0 }

sub is_utc { 0 }

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

sub name      { $_[0]->{name} }
sub category  { (split /\//, $_[0]->{name}, 2)[0] }

sub is_valid_name
{
    my $tz;
    {
        local $@;
        $tz = eval { $_[0]->load( name => $_[1] ) };
    }

    return $tz && $tz->isa('DateTimeX::Lite::TimeZone') ? 1 : 0
}

#
# Functions
#
sub offset_as_seconds {
    {
        local $@;
        shift if eval { $_[0]->isa('DateTimeX::Lite::TimeZone') };
    }
    DateTimeX::Lite::Util::offset_as_seconds(@_);
}

sub offset_as_string {
    {
        local $@;
        shift if eval { $_[0]->isa('DateTimeX::Lite::TimeZone') };
    }
    DateTimeX::Lite::Util::offset_as_string(@_);
}

# These methods all operate on data contained in the DateTime/TimeZone/Catalog.pm file.

sub all_names {
    return wantarray ? @DateTimeX::Lite::TimeZone::Catalog::ALL : [@DateTimeX::Lite::TimeZone::Catalog::ALL];
}

sub categories {
    return wantarray
        ? @DateTimeX::Lite::TimeZone::Catalog::CATEGORY_NAMES
        : [@DateTimeX::Lite::TimeZone::Catalog::CATEGORY_NAMES];
}

sub links
{
    return
        wantarray ? %DateTimeX::Lite::TimeZone::Catalog::LINKS : {%DateTimeX::Lite::TimeZone::Catalog::LINKS};
}

sub names_in_category
{
    shift if $_[0]->isa('DateTimeX::Lite::TimeZone');
    return unless exists $DateTimeX::Lite::TimeZone::Catalog::CATEGORIES{ $_[0] };

    return
        wantarray
        ? @{ $DateTimeX::Lite::TimeZone::Catalog::CATEGORIES{ $_[0] } }
        : [ $DateTimeX::Lite::TimeZone::Catalog::CATEGORIES{ $_[0] } ];
}

sub countries
{
    wantarray
        ? ( sort keys %DateTimeX::Lite::TimeZone::Catalog::ZONES_BY_COUNTRY )
        : [ sort keys %DateTimeX::Lite::TimeZone::Catalog::ZONES_BY_COUNTRY ];
}

sub names_in_country
{
    shift if $_[0]->isa('DateTimeX::Lite::TimeZone');

    return unless exists $DateTimeX::Lite::TimeZone::Catalog::ZONES_BY_COUNTRY{ lc $_[0] };

    return
        wantarray
        ? @{ $DateTimeX::Lite::TimeZone::Catalog::ZONES_BY_COUNTRY{ lc $_[0] } }
        : $DateTimeX::Lite::TimeZone::Catalog::ZONES_BY_COUNTRY{ lc $_[0] };
}

1;

__END__