local-lib5/lib/perl5/DateTime/TimeZone/OlsonDB.pm

   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