362 lines
8.2 KiB
Perl
362 lines
8.2 KiB
Perl
package DateTime::TimeZone::OlsonDB;
|
|
|
|
use strict;
|
|
use warnings;
|
|
use namespace::autoclean;
|
|
|
|
our $VERSION = '2.46';
|
|
|
|
use DateTime::Duration;
|
|
use DateTime::TimeZone::OlsonDB::Rule;
|
|
use DateTime::TimeZone::OlsonDB::Zone;
|
|
|
|
my $x = 1;
|
|
our %MONTHS = map { $_ => $x++ } qw( Jan Feb Mar Apr May Jun
|
|
Jul Aug Sep Oct Nov Dec);
|
|
|
|
$x = 1;
|
|
our %DAYS = map { $_ => $x++ } qw( Mon Tue Wed Thu Fri Sat Sun );
|
|
|
|
our $PLUS_ONE_DAY_DUR = DateTime::Duration->new( days => 1 );
|
|
our $MINUS_ONE_DAY_DUR = DateTime::Duration->new( days => -1 );
|
|
|
|
sub new {
|
|
my $class = shift;
|
|
|
|
return bless {
|
|
rules => {},
|
|
zones => {},
|
|
links => {},
|
|
}, $class;
|
|
}
|
|
|
|
sub parse_file {
|
|
my $self = shift;
|
|
my $file = shift;
|
|
|
|
open my $fh, '<', $file
|
|
or die "Cannot read $file: $!";
|
|
|
|
while (<$fh>) {
|
|
chomp;
|
|
$self->_parse_line($_);
|
|
}
|
|
|
|
close $fh or die $!;
|
|
}
|
|
|
|
sub _parse_line {
|
|
my $self = shift;
|
|
my $line = shift;
|
|
|
|
return if $line =~ /^\s+$/;
|
|
return if $line =~ /^#/;
|
|
|
|
# remove any comments at the end of the line
|
|
$line =~ s/\s*#.+$//;
|
|
|
|
if ( $self->{in_zone} && $line =~ /^[ \t]/ ) {
|
|
$self->_parse_zone( $line, $self->{in_zone} );
|
|
return;
|
|
}
|
|
|
|
foreach (qw( Rule Zone Link )) {
|
|
if ( substr( $line, 0, 4 ) eq $_ ) {
|
|
my $m = '_parse_' . lc $_;
|
|
$self->$m($line);
|
|
}
|
|
}
|
|
}
|
|
|
|
## no critic (Subroutines::ProhibitUnusedPrivateSubroutines)
|
|
sub _parse_rule {
|
|
my $self = shift;
|
|
my $rule = shift;
|
|
|
|
my @items = split /\s+/, $rule, 10;
|
|
|
|
shift @items;
|
|
my $name = shift @items;
|
|
|
|
my %rule;
|
|
@rule{qw( from to type in on at save letter )} = @items;
|
|
delete $rule{letter} if $rule{letter} eq '-';
|
|
|
|
# As of the 2003a data, there are no rules with a type set
|
|
delete $rule{type} if $rule{type} eq '-';
|
|
|
|
push @{ $self->{rules}{$name} },
|
|
DateTime::TimeZone::OlsonDB::Rule->new( name => $name, %rule );
|
|
|
|
undef $self->{in_zone};
|
|
}
|
|
|
|
sub _parse_zone {
|
|
my $self = shift;
|
|
my $zone = shift;
|
|
my $name = shift;
|
|
|
|
my $expect = $name ? 5 : 6;
|
|
my @items = grep { defined && length } split /\s+/, $zone, $expect;
|
|
|
|
my %obs;
|
|
unless ($name) {
|
|
shift @items; # remove "Zone"
|
|
$name = shift @items;
|
|
}
|
|
|
|
@obs{qw( gmtoff rules format until )} = @items;
|
|
|
|
if ( $obs{rules} =~ /\d\d?:\d\d/ ) {
|
|
$obs{offset_from_std} = delete $obs{rules};
|
|
}
|
|
else {
|
|
delete $obs{rules} if $obs{rules} eq '-';
|
|
}
|
|
|
|
delete $obs{until} unless defined $obs{until};
|
|
|
|
push @{ $self->{zones}{$name} }, \%obs;
|
|
|
|
$self->{in_zone} = $name;
|
|
}
|
|
|
|
sub _parse_link {
|
|
my $self = shift;
|
|
my $link = shift;
|
|
|
|
my @items = split /\s+/, $link, 3;
|
|
|
|
$self->{links}{ $items[2] } = $items[1];
|
|
|
|
undef $self->{in_zone};
|
|
}
|
|
## use critic
|
|
|
|
sub links { %{ $_[0]->{links} } }
|
|
|
|
sub zone_names { keys %{ $_[0]->{zones} } }
|
|
|
|
sub zone {
|
|
my $self = shift;
|
|
my $name = shift;
|
|
|
|
die "Invalid zone name $name"
|
|
unless exists $self->{zones}{$name};
|
|
|
|
return DateTime::TimeZone::OlsonDB::Zone->new(
|
|
name => $name,
|
|
observances => $self->{zones}{$name},
|
|
olson_db => $self,
|
|
);
|
|
}
|
|
|
|
sub expanded_zone {
|
|
my $self = shift;
|
|
my %p = @_;
|
|
|
|
$p{expand_to_year} ||= (localtime)[5] + 1910;
|
|
|
|
my $zone = $self->zone( $p{name} );
|
|
|
|
$zone->expand_observances( $self, $p{expand_to_year} );
|
|
|
|
return $zone;
|
|
}
|
|
|
|
sub rules_by_name {
|
|
my $self = shift;
|
|
my $name = shift;
|
|
|
|
return unless defined $name;
|
|
|
|
die "Invalid rule name $name"
|
|
unless exists $self->{rules}{$name};
|
|
|
|
return @{ $self->{rules}{$name} };
|
|
}
|
|
|
|
sub parse_day_spec {
|
|
my ( $day, $month, $year ) = @_;
|
|
|
|
return ( $month, $day ) if $day =~ /^\d+$/;
|
|
|
|
if ( $day =~ /^last(\w\w\w)$/ ) {
|
|
my $dow = $DAYS{$1};
|
|
|
|
my $last_day = DateTime->last_day_of_month(
|
|
year => $year,
|
|
month => $month,
|
|
time_zone => 'floating',
|
|
);
|
|
|
|
my $dt = DateTime->new(
|
|
year => $year,
|
|
month => $month,
|
|
day => $last_day->day,
|
|
time_zone => 'floating',
|
|
);
|
|
|
|
while ( $dt->day_of_week != $dow ) {
|
|
$dt -= $PLUS_ONE_DAY_DUR;
|
|
}
|
|
|
|
return ( $dt->month, $dt->day );
|
|
}
|
|
elsif ( $day =~ /^(\w\w\w)([><])=(\d\d?)$/ ) {
|
|
my $dow = $DAYS{$1};
|
|
|
|
my $dt = DateTime->new(
|
|
year => $year,
|
|
month => $month,
|
|
day => $3,
|
|
time_zone => 'floating',
|
|
);
|
|
|
|
my $dur = $2 eq '<' ? $MINUS_ONE_DAY_DUR : $PLUS_ONE_DAY_DUR;
|
|
|
|
while ( $dt->day_of_week != $dow ) {
|
|
$dt += $dur;
|
|
}
|
|
|
|
return ( $dt->month, $dt->day );
|
|
}
|
|
else {
|
|
die "Invalid on spec for rule: $day\n";
|
|
}
|
|
}
|
|
|
|
sub utc_datetime_for_time_spec {
|
|
my %p = @_;
|
|
|
|
# 'w'all - ignore it, because that's the default
|
|
$p{spec} =~ s/w$//;
|
|
|
|
# 'g'reenwich, 'u'tc, or 'z'ulu
|
|
my $is_utc = $p{spec} =~ s/[guz]$//;
|
|
|
|
# 's'tandard time - ignore DS offset
|
|
my $is_std = $p{spec} =~ s/s$//;
|
|
|
|
## no critic (NamingConventions::ProhibitAmbiguousNames)
|
|
my ( $hour, $minute, $second ) = split /:/, $p{spec};
|
|
$minute = 0 unless defined $minute;
|
|
$second = 0 unless defined $second;
|
|
|
|
my $add_day = 0;
|
|
if ( $hour >= 24 ) {
|
|
$hour = $hour - 24;
|
|
$add_day = 1;
|
|
}
|
|
|
|
my $utc;
|
|
if ($is_utc) {
|
|
$utc = DateTime->new(
|
|
year => $p{year},
|
|
month => $p{month},
|
|
day => $p{day},
|
|
hour => $hour,
|
|
minute => $minute,
|
|
second => $second,
|
|
time_zone => 'floating',
|
|
);
|
|
}
|
|
else {
|
|
my $local = DateTime->new(
|
|
year => $p{year},
|
|
month => $p{month},
|
|
day => $p{day},
|
|
hour => $hour,
|
|
minute => $minute,
|
|
second => $second,
|
|
time_zone => 'floating',
|
|
);
|
|
|
|
$p{offset_from_std} = 0 if $is_std;
|
|
|
|
my $dur = DateTime::Duration->new(
|
|
seconds => $p{offset_from_utc} + $p{offset_from_std} );
|
|
|
|
$utc = $local - $dur;
|
|
}
|
|
|
|
$utc->add( days => 1 ) if $add_day;
|
|
|
|
return $utc;
|
|
}
|
|
|
|
1;
|
|
|
|
# ABSTRACT: An object to represent an Olson time zone database
|
|
|
|
__END__
|
|
|
|
=pod
|
|
|
|
=encoding UTF-8
|
|
|
|
=head1 NAME
|
|
|
|
DateTime::TimeZone::OlsonDB - An object to represent an Olson time zone database
|
|
|
|
=head1 VERSION
|
|
|
|
version 2.46
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
none yet
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
This module parses the Olson database time zone definition files and
|
|
creates various objects representing time zone data.
|
|
|
|
Each time zone is broken down into several parts. The first piece is
|
|
an observance, which is an offset from UTC and an abbreviation. A
|
|
single zone may contain many observances, reflecting historical
|
|
changes in that time zone over time. An observance may also refer to
|
|
a set of rules.
|
|
|
|
Rules are named, and may apply to many different zones. For example,
|
|
the "US" rules apply to most of the time zones in the US,
|
|
unsurprisingly. Rules are made of an offset from standard time and a
|
|
definition of when that offset changes. Changes can be a one time
|
|
thing, or they can recur at regular times through a span of years.
|
|
|
|
Each rule may have an associated letter, which is used to generate an
|
|
abbreviated name for the time zone, along with the offset's
|
|
abbreviation. For example, if the offset's abbreviation is "C%sT",
|
|
and the a rule specifies the letter "S", then the abbreviation when
|
|
that rule is in effect is "CST".
|
|
|
|
=head1 USAGE
|
|
|
|
Not yet documented. This stuff is a mess.
|
|
|
|
=head1 SUPPORT
|
|
|
|
Bugs may be submitted at L<https://github.com/houseabsolute/DateTime-TimeZone/issues>.
|
|
|
|
I am also usually active on IRC as 'autarch' on C<irc://irc.perl.org>.
|
|
|
|
=head1 SOURCE
|
|
|
|
The source code repository for DateTime-TimeZone can be found at L<https://github.com/houseabsolute/DateTime-TimeZone>.
|
|
|
|
=head1 AUTHOR
|
|
|
|
Dave Rolsky <autarch@urth.org>
|
|
|
|
=head1 COPYRIGHT AND LICENSE
|
|
|
|
This software is copyright (c) 2020 by Dave Rolsky.
|
|
|
|
This is free software; you can redistribute it and/or modify it under
|
|
the same terms as the Perl 5 programming language system itself.
|
|
|
|
The full text of the license can be found in the
|
|
F<LICENSE> file included with this distribution.
|
|
|
|
=cut
|