[catagits/Gitalist.git] / local-lib5 / lib / perl5 / DateTime / TimeZone / OlsonDB.pm

package DateTime::TimeZone::OlsonDB;

use strict;
use warnings;

use vars qw( %MONTHS %DAYS $PLUS_ONE_DAY_DUR $MINUS_ONE_DAY_DUR );

use DateTime::TimeZone::OlsonDB::Rule;
use DateTime::TimeZone::OlsonDB::Zone;
use Params::Validate qw( validate SCALAR );


my $x = 1;
%MONTHS = map { $_ => $x++ }
          qw( Jan Feb Mar Apr May Jun
	      Jul Aug Sep Oct Nov Dec);

$x = 1;
%DAYS = map { $_ => $x++ }
        qw( Mon Tue Wed Thu Fri Sat Sun );

$PLUS_ONE_DAY_DUR =  DateTime::Duration->new( days => 1 );
$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($_);
    }
}

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);
        }
    }
}

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};
}

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 = validate( @_, { name => { type => SCALAR },
                            expand_to_year => { type => SCALAR,
                                                default => (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 $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->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->day;
    }
    else
    {
        die "Invalid on spec for rule: $day\n";
    }
}

sub utc_datetime_for_time_spec
{
    my %p = validate( @_, { spec  => { type => SCALAR },
                            year  => { type => SCALAR },
                            month => { type => SCALAR },
                            day   => { type => SCALAR },
                            offset_from_utc => { type => SCALAR },
                            offset_from_std => { type => SCALAR },
                          },
                    );

    # '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$//;

    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 = 0;
        $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;

__END__

=head1 NAME

DateTime::TimeZone::OlsonDB - An object to represent an Olson time zone database

=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 AUTHOR

Dave Rolsky, <autarch@urth.org>

=head1 COPYRIGHT & LICENSE

Copyright (c) 2003-2008 David Rolsky.  All rights reserved.  This
program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

The full text of the license can be found in the LICENSE file included
with this module.

=cut
Commit	Line	Data
3fea05b9	1	package DateTime::TimeZone::OlsonDB;
	2
	3	use strict;
	4	use warnings;
	5
	6	use vars qw( %MONTHS %DAYS $PLUS_ONE_DAY_DUR $MINUS_ONE_DAY_DUR );
	7
	8	use DateTime::TimeZone::OlsonDB::Rule;
	9	use DateTime::TimeZone::OlsonDB::Zone;
	10	use Params::Validate qw( validate SCALAR );
	11
	12
	13	my $x = 1;
	14	%MONTHS = map { $_ => $x++ }
	15	qw( Jan Feb Mar Apr May Jun
	16	Jul Aug Sep Oct Nov Dec);
	17
	18	$x = 1;
	19	%DAYS = map { $_ => $x++ }
	20	qw( Mon Tue Wed Thu Fri Sat Sun );
	21
	22	$PLUS_ONE_DAY_DUR = DateTime::Duration->new( days => 1 );
	23	$MINUS_ONE_DAY_DUR = DateTime::Duration->new( days => -1 );
	24
	25	sub new
	26	{
	27	my $class = shift;
	28
	29	return bless { rules => {},
	30	zones => {},
	31	links => {},
	32	}, $class;
	33	}
	34
	35	sub parse_file
	36	{
	37	my $self = shift;
	38	my $file = shift;
	39
	40	open my $fh, "<$file"
	41	or die "Cannot read $file: $!";
	42
	43	while (<$fh>)
	44	{
	45	chomp;
	46	$self->_parse_line($_);
	47	}
	48	}
	49
	50	sub _parse_line
	51	{
	52	my $self = shift;
	53	my $line = shift;
	54
	55	return if $line =~ /^\s+$/;
	56	return if $line =~ /^#/;
	57
	58	# remove any comments at the end of the line
	59	$line =~ s/\s*#.+$//;
	60
	61	if ( $self->{in_zone} && $line =~ /^\t/ )
	62	{
	63	$self->_parse_zone( $line, $self->{in_zone} );
	64	return;
65	}
66
67	foreach ( qw( Rule Zone Link ) )
68	{
69	if ( substr( $line, 0, 4 ) eq $_ )
70	{
71	my $m = '_parse_' . lc $_;
72	$self->$m($line);
73	}
74	}
75	}
76
77	sub _parse_rule
78	{
79	my $self = shift;
80	my $rule = shift;
81
82	my @items = split /\s+/, $rule, 10;
83
84	shift @items;
85	my $name = shift @items;
86
87	my %rule;
88	@rule{ qw( from to type in on at save letter ) } = @items;
89	delete $rule{letter} if $rule{letter} eq '-';
90
91	# As of the 2003a data, there are no rules with a type set
92	delete $rule{type} if $rule{type} eq '-';
93
94	push @{ $self->{rules}{$name} },
95	DateTime::TimeZone::OlsonDB::Rule->new( name => $name, %rule );
96
97	undef $self->{in_zone};
98	}
99
100	sub _parse_zone
101	{
102	my $self = shift;
103	my $zone = shift;
104	my $name = shift;
105
106	my $expect = $name ? 5 : 6;
107	my @items = grep { defined && length } split /\s+/, $zone, $expect;
108
109	my %obs;
110	unless ($name)
111	{
112	shift @items; # remove "Zone"
113	$name = shift @items;
114	}
115
116	@obs{ qw( gmtoff rules format until ) } = @items;
117
118	if ( $obs{rules} =~ /\d\d?:\d\d/ )
119	{
120	$obs{offset_from_std} = delete $obs{rules};
121	}
122	else
123	{
124	delete $obs{rules} if $obs{rules} eq '-';
125	}
126
127	delete $obs{until} unless defined $obs{until};
128
129	push @{ $self->{zones}{$name} }, \%obs;
130
131	$self->{in_zone} = $name;
132	}
133
134	sub _parse_link
135	{
136	my $self = shift;
137	my $link = shift;
138
139	my @items = split /\s+/, $link, 3;
140
141	$self->{links}{ $items[2] } = $items[1];
142
143	undef $self->{in_zone};
144	}
145
146	sub links { %{ $_[0]->{links} } }
147
148	sub zone_names { keys %{ $_[0]->{zones} } }
149
150	sub zone
151	{
152	my $self = shift;
153	my $name = shift;
154
155	die "Invalid zone name $name"
156	unless exists $self->{zones}{$name};
157
158	return
159	DateTime::TimeZone::OlsonDB::Zone->new
160	( name => $name,
161	observances => $self->{zones}{$name},
162	olson_db => $self,
163	);
164	}
165
166	sub expanded_zone
167	{
168	my $self = shift;
169	my %p = validate( @_, { name => { type => SCALAR },
170	expand_to_year => { type => SCALAR,
171	default => (localtime)[5] + 1910 },
172	} );
173
174	my $zone = $self->zone( $p{name} );
175
176	$zone->expand_observances( $self, $p{expand_to_year} );
177
178	return $zone;
179	}
180
181	sub rules_by_name
182	{
183	my $self = shift;
184	my $name = shift;
185
186	return unless defined $name;
187
188	die "Invalid rule name $name"
189	unless exists $self->{rules}{$name};
190
191	return @{ $self->{rules}{$name} };
192	}
193
194	sub parse_day_spec
195	{
196	my ( $day, $month, $year ) = @_;
197
198	return $day if $day =~ /^\d+$/;
199
200	if ( $day =~ /^last(\w\w\w)$/ )
201	{
202	my $dow = $DAYS{$1};
203
204	my $last_day = DateTime->last_day_of_month( year => $year,
205	month => $month,
206	time_zone => 'floating',
207	);
208
209	my $dt =
210	DateTime->new( year => $year,
211	month => $month,
212	day => $last_day->day,
213	time_zone => 'floating',
214	);
215
216	while ( $dt->day_of_week != $dow )
217	{
218	$dt -= $PLUS_ONE_DAY_DUR;
219	}
220
221	return $dt->day;
222	}
223	elsif ( $day =~ /^(\w\w\w)([><])=(\d\d?)$/ )
224	{
225	my $dow = $DAYS{$1};
226
227	my $dt = DateTime->new( year => $year,
228	month => $month,
229	day => $3,
230	time_zone => 'floating',
231	);
232
233	my $dur = $2 eq '<' ? $MINUS_ONE_DAY_DUR : $PLUS_ONE_DAY_DUR;
234
235	while ( $dt->day_of_week != $dow )
236	{
237	$dt += $dur;
238	}
239
240	return $dt->day;
241	}
242	else
243	{
244	die "Invalid on spec for rule: $day\n";
245	}
246	}
247
248	sub utc_datetime_for_time_spec
249	{
250	my %p = validate( @_, { spec => { type => SCALAR },
251	year => { type => SCALAR },
252	month => { type => SCALAR },
253	day => { type => SCALAR },
254	offset_from_utc => { type => SCALAR },
255	offset_from_std => { type => SCALAR },
256	},
257	);
258
259	# 'w'all - ignore it, because that's the default
260	$p{spec} =~ s/w$//;
261
262	# 'g'reenwich, 'u'tc, or 'z'ulu
263	my $is_utc = $p{spec} =~ s/[guz]$//;
264
265	# 's'tandard time - ignore DS offset
266	my $is_std = $p{spec} =~ s/s$//;
267
268	my ($hour, $minute, $second) = split /:/, $p{spec};
269	$minute = 0 unless defined $minute;
270	$second = 0 unless defined $second;
271
272	my $add_day = 0;
273	if ( $hour == 24 )
274	{
275	$hour = 0;
276	$add_day = 1;
277	}
278
279	my $utc;
280	if ($is_utc)
281	{
282	$utc = DateTime->new( year => $p{year},
283	month => $p{month},
284	day => $p{day},
285	hour => $hour,
286	minute => $minute,
287	second => $second,
288	time_zone => 'floating',
289	);
290	}
291	else
292	{
293	my $local = DateTime->new( year => $p{year},
294	month => $p{month},
295	day => $p{day},
296	hour => $hour,
297	minute => $minute,
298	second => $second,
299	time_zone => 'floating',
300	);
301
302	$p{offset_from_std} = 0 if $is_std;
303
304	my $dur =
305	DateTime::Duration->new
306	( seconds => $p{offset_from_utc} + $p{offset_from_std} );
307
308	$utc = $local - $dur;
309	}
310
311	$utc->add( days => 1 ) if $add_day;
312
313	return $utc;
314	}
315
316	1;
317
318	__END__
319
320	=head1 NAME
321
322	DateTime::TimeZone::OlsonDB - An object to represent an Olson time zone database
323
324	=head1 SYNOPSIS
325
326	none yet
327
328	=head1 DESCRIPTION
329
330	This module parses the Olson database time zone definition files and
331	creates various objects representing time zone data.
332
333	Each time zone is broken down into several parts. The first piece is
334	an observance, which is an offset from UTC and an abbreviation. A
335	single zone may contain many observances, reflecting historical
336	changes in that time zone over time. An observance may also refer to
337	a set of rules.
338
339	Rules are named, and may apply to many different zones. For example,
340	the "US" rules apply to most of the time zones in the US,
341	unsurprisingly. Rules are made of an offset from standard time and a
342	definition of when that offset changes. Changes can be a one time
343	thing, or they can recur at regular times through a span of years.
344
345	Each rule may have an associated letter, which is used to generate an
346	abbreviated name for the time zone, along with the offset's
347	abbreviation. For example, if the offset's abbreviation is "C%sT",
348	and the a rule specifies the letter "S", then the abbreviation when
349	that rule is in effect is "CST".
350
351	=head1 USAGE
352
353	Not yet documented. This stuff is a mess.
354
355	=head1 AUTHOR
356
357	Dave Rolsky, <autarch@urth.org>
358
359	=head1 COPYRIGHT & LICENSE
360
361	Copyright (c) 2003-2008 David Rolsky. All rights reserved. This
362	program is free software; you can redistribute it and/or modify it
363	under the same terms as Perl itself.
364
365	The full text of the license can be found in the LICENSE file included
366	with this module.
367
368	=cut