package Date::Manip::TZ;
# Copyright (c) 2008-2009 Sullivan Beck. All rights reserved.
# This program is free software; you can redistribute it and/or modify it
# under the same terms as Perl itself.

########################################################################
# Any routine that starts with an underscore (_) is NOT intended for
# public use.  They are for internal use in the the Date::Manip
# modules and are subject to change without warning or notice.
#
# ABSOLUTELY NO USER SUPPORT IS OFFERED FOR THESE ROUTINES!
########################################################################

use Date::Manip::Obj;
@ISA = ("Date::Manip::Obj");

require 5.010000;
use warnings;
use strict;
use Storable qw(dclone);
use feature "switch";

use IO::File;
require Date::Manip::Zones;
use Date::Manip::Base;

use vars qw($VERSION);
$VERSION="6.02";

########################################################################
# BASE METHODS
########################################################################

sub _init {
   my($self) = @_;

   $$self{"data"} =
     {
      # These are the variables defined in Date::Manip::Zones
      "Module"         => \%Date::Manip::Zones::Module,
      "ZoneNames"      => \%Date::Manip::Zones::ZoneNames,
      "Alias"          => \%Date::Manip::Zones::Alias,
      "Abbrev"         => \%Date::Manip::Zones::Abbrev,
      "Offmod"         => \%Date::Manip::Zones::Offmod,
      "FirstDate"      => $Date::Manip::Zones::FirstDate,
      "LastDate"       => $Date::Manip::Zones::LastDate,
      "LastYear"       => $Date::Manip::Zones::LastYear,

      # These override values from Date::Manip::Zones
      "MyAlias"        => {},
      "MyAbbrev"       => {},
      "MyOffsets"      => {},

      # Each timezone/offset module that is loaded goes here
      "Zones"          => {},
      "Offsets"        => {},

      # methods     a list of methods used for determining the
      #             current zone
      # dates       critical dates on a per/year (UT) basis
      # zonerx      the regular expression for matching timezone
      #             names/aliases
      # abbrx       the regular expression for matching timezone
      #             abbreviations
      # offrx       the regular expression for matching a valid
      #             timezone offset
      # zrx         the regular expression to match all timezone
      #             information
      "methods"        => [],
      "zonerx"         => undef,
      "abbrx"          => undef,
      "offrx"          => undef,
      "zrx"            => undef,
     };

   # OS specific stuff

   my $dmb = $$self{"objs"}{"base"};
   my $os  = $dmb->_os();

   if ($os eq "Unix") {
      $$self{"data"}{"methods"} = [
                                   qw(main TZ
                                      env  TZ
                                      file /etc/TIMEZONE
                                      file /etc/timezone
                                      file /etc/sysconfig/clock
                                      file /etc/default/init
                                    ),
                                   'command',  '/bin/date +%Z',
                                   'command',  '/usr/bin/date +%Z',
                                   'command',  '/usr/local/bin/date +%Z',
                                   qw(cmdfield /bin/date -2
                                      cmdfield /usr/bin/date -2
                                      cmdfield /usr/local/bin/date -2
                                      gmtoff
                                    ),
                                  ];

   } elsif ($os eq "Windows") {
      $$self{"data"}{"methods"} = [
                                   qw(main TZ
                                      env  TZ
                                      registry
                                      gmtoff),
                                  ];

   } elsif ($os eq "VMS") {
      $$self{"data"}{"methods"} = [
                                   qw(main TZ
                                      env  TZ
                                      env  SYS$TIMEZONE_RULE
                                      env  SYS$TIMEZONE_NAME
                                      env  UCX$TZ
                                      env  TCPIP$TZ
                                      env  MULTINET_TIMEZONE
                                      env  SYS$TIMEZONE_DIFFERENTIAL
                                      gmtoff
                                    ),
                                  ];

   } else {
      $$self{"data"}{"methods"} = [
                                   qw(main TZ
                                      env  TZ
                                      gmtoff
                                    ),
                                  ];
   }
}

sub _init_final {
   my($self) = @_;

   $self->_set_curr_zone();
}

no strict 'refs';
# This loads data from an offset module
#
sub _offmod {
   my($self,$offset) = @_;
   return  if (exists $$self{"data"}{"Offsets"}{$offset});

   my $mod  = $$self{"data"}{"Offmod"}{$offset};
   eval "require Date::Manip::Offset::${mod}";
   my %off  = %{ "Date::Manip::Offset::${mod}::Offset" };

   $$self{"data"}{"Offsets"}{$offset} = { %off };
}

# This loads data from a zone module (takes a lowercase zone)
#
sub _module {
   my($self,$zone) = @_;
   return  if (exists $$self{"data"}{"Zones"}{$zone}{"Loaded"});

   my $mod   = $$self{"data"}{"Module"}{$zone};
   eval "require Date::Manip::TZ::${mod}";
   my %dates = %{ "Date::Manip::TZ::${mod}::Dates" };
   my %last  = %{ "Date::Manip::TZ::${mod}::LastRule" };
   $$self{"data"}{"Zones"}{$zone} =
     {
      "Dates"    => { %dates },
      "LastRule" => { %last },
      "Loaded"   => 1
     };
}
use strict 'refs';

########################################################################
# CHECKING/MODIFYING ZONEINFO DATA
########################################################################

sub _zone {
   my($self,$zone) = @_;
   $zone = lc($zone);

   if (exists $$self{"data"}{"MyAlias"}{$zone}) {
      return $$self{"data"}{"MyAlias"}{$zone};
   } elsif (exists $$self{"data"}{"Alias"}{$zone}) {
      return  $$self{"data"}{"Alias"}{$zone};
   } else {
      return "";
   }
}

sub tzdata {
   my($self) = @_;
   return $Date::Manip::Zones::TzdataVersion;
}

sub tzcode {
   my($self) = @_;
   return $Date::Manip::Zones::TzcodeVersion;
}

sub define_alias {
   my($self,$alias,$zone) = @_;
   $alias = lc($alias);

   if ($alias eq "reset") {
      $$self{"data"}{"MyAlias"} = {};
      $$self{"data"}{"zonerx"}  = undef;
      return 0;
   }
   if (lc($zone) eq "reset") {
      delete $$self{"data"}{"MyAlias"}{$alias};
      $$self{"data"}{"zonerx"} = undef;
      return 0;
   }

   $zone  = $self->_zone($zone);

   return 1  if (! $zone);
   $$self{"data"}{"MyAlias"}{$alias} = $zone;
   $$self{"data"}{"zonerx"} = undef;
   return 0;
}

sub define_abbrev {
   my($self,$abbrev,@zone) = @_;
   $abbrev = lc($abbrev);

   if ($abbrev eq "reset") {
      $$self{"data"}{"MyAbbrev"} = {};
      $$self{"data"}{"abbrx"}    = undef;
      return 0;
   }
   if ($#zone == 0  &&  lc($zone[0]) eq "reset") {
      delete $$self{"data"}{"MyAbbrev"}{$abbrev};
      $$self{"data"}{"abbrx"} = undef;
      return (0);
   }

   if (! exists $$self{"data"}{"Abbrev"}{$abbrev}) {
      return (1);
   }

   my (@z,%z);
   my %zone = map { $_,1 } @{ $$self{"data"}{"Abbrev"}{$abbrev} };
   foreach my $z (@zone) {
      my $zone = $self->_zone($z);
      return (2,$z)  if (! $zone);
      return (3,$z)  if (! exists $zone{$zone});
      next  if (exists $z{$zone});
      $z{$zone} = 1;
      push(@z,$zone);
   }

   $$self{"data"}{"MyAbbrev"}{$abbrev} = [ @z ];
   $$self{"data"}{"abbrx"}             = undef;
   return ();
}

sub define_offset {
   my($self,$offset,@args) = @_;
   my $dmb                 = $$self{"objs"}{"base"};

   if (lc($offset) eq "reset") {
      $$self{"data"}{"MyOffsets"} = {};
      return (0);
   }
   if ($#args == 0  &&  lc($args[0]) eq "reset") {
      delete $$self{"data"}{"MyOffsets"}{$offset};
      return (0);
   }

   # Check that $offset is valid. If it is, load the
   # appropriate module.

   if (ref($offset)) {
      $offset = $dmb->join("offset",$offset);
   } else {
      $offset = $dmb->_delta_convert("offset",$offset);
   }
   return (9)  if (! $offset);
   return (1)  if (! exists $$self{"data"}{"Offmod"}{$offset});

   $self->_offmod($offset);

   # Find out whether we're handling STD, DST, or both.

   my(@isdst) = (0,1);
   if ($args[0] =~ /^std|dst|stdonly|dstonly$/i) {
      my $tmp = lc(shift(@args));
      if ($tmp eq "stdonly") {
         @isdst = (0);
      } elsif ($tmp eq "dstonly") {
         @isdst = (1);
      }
   }
   my @zone = @args;

   if ($#isdst == 0  &&
       ! exists($$self{"data"}{"Offsets"}{$offset}{$isdst[0]})) {
      return (2);
   }

   # Check to see that each zone is valid, and contains this offset.

   my %tmp;
   foreach my $isdst (0,1) {
      next  if (! exists $$self{"data"}{"Offsets"}{$offset}{$isdst});
      my @z = @{ $$self{"data"}{"Offsets"}{$offset}{$isdst} };
      $tmp{$isdst} = { map { $_,1 } @z };
   }

   foreach my $z (@zone) {
      my $lcz = lc($z);
      if (! exists $$self{"data"}{"ZoneNames"}{$lcz}) {
         return (3,$z);
      } elsif (! exists $tmp{0}{$lcz}  &&
               ! exists $tmp{1}{$lcz}) {
         return (4,$z);
      } elsif ($#isdst == 0  &&
               ! exists $tmp{$isdst[0]}{$lcz}) {
         return (5,$z);
      }
      $z = $lcz;
   }

   # Set the zones accordingly.

   foreach my $isdst (@isdst) {
      my @z;
      foreach my $z (@zone) {
         push(@z,$z)  if (exists $tmp{$isdst}{$z});
      }
      $$self{"data"}{"MyOffsets"}{$offset}{$isdst} = [ @z ];
   }

   return (0);
}

########################################################################
# SYSTEM ZONE
########################################################################

sub curr_zone {
   my($self,$reset) = @_;
   my $dmb = $$self{"objs"}{"base"};

   if ($reset) {
      $self->_set_curr_zone();
   }

   return $dmb->_now("systz");
}

sub curr_zone_methods {
   my($self,@methods) = @_;

   if (${^TAINT}) {
      warn "ERROR: [curr_zone_methods] not allowed when taint checking on\n";
      return;
   }

   $$self{"data"}{"methods"}  = [ @methods ];
}

sub _set_curr_zone {
   my($self) = @_;
   my $dmb   = $$self{"objs"}{"base"};
   my $currzone = $self->_get_curr_zone();

   $$dmb{"data"}{"now"}{"systz"} = $self->_zone($currzone);
}

# This determines the system timezone using all of the methods
# applicable to the operating system. The first match is used.
#
sub _get_curr_zone {
   my($self) = @_;
   my $dmb   = $$self{"objs"}{"base"};

   my $t = time;
   my($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($t);
   my $currzone = "";
   my $dstflag = ($isdst ? "dstonly" : "stdonly");

   my (@methods) = @{ $$self{"data"}{"methods"} };
 METHOD: while (@methods) {
      my $method = shift(@methods);
      my @zone   = ();

      given ($method) {

         when ("main") {
            if (! @methods) {
               warn "ERROR: [_set_curr_zone] main requires argument\n";
               return;
            }
            my $var = shift(@methods);
            push(@zone,$$::var)  if (defined $$::var);
         }

         when ("env") {
            if (! @methods) {
               warn "ERROR: [_set_curr_zone] env requires argument\n";
               return;
            }
            my $var = shift(@methods);
            push(@zone,$ENV{$var})  if (exists $ENV{$var});
         }

         when ("file") {
            if (! @methods) {
               warn "ERROR: [_set_curr_zone] file requires argument\n";
               return;
            }
            my $file = shift(@methods);
            next  if (! -f $file);

            my $in = new IO::File;
            $in->open($file)  ||  next;
            my $firstline = 1;
            while (! $in->eof) {
               my $line = <$in>;
               next  if ($line =~ /^\s*\043/  ||
                         $line =~ /^\s*$/);
               if ($line =~ /^\s*(?:TZ|TIMEZONE|ZONE)\s*=\s*(\S+)/i) {
                  my $zone = $1;
                  $zone    =~ s/["']//g;  # "
                  push(@zone,$zone);
                  last;
               }
               if ($firstline) {
                  $firstline = 0;
                  $line      =~ s/\s//g;
                  $line      =~ s/["']//g;  # "
                  push(@zone,$line);
               }
            }
            close(IN);
         }

         when ("command") {
            if (! @methods) {
               warn "ERROR: [_set_curr_zone] command requires argument\n";
               return;
            }
            my $command = shift(@methods);
            my ($out)   = _cmd($command);
            push(@zone,$out)  if ($out);
         }

         when ("cmdfield") {
            if ($#methods < 1) {
               warn "ERROR: [_set_curr_zone] cmdfield requires 2 arguments\n";
               return;
            }
            my $command = shift(@methods);
            my $n       = shift(@methods);
            my ($out)   = _cmd($command);
            if ($out) {
               $out    =~ s/^\s*//;
               $out    =~ s/\s*$//;
               my @out = split(/\s+/,$out);
               push(@zone,$out[$n])  if (defined $out[$n]);
            }
         }

         when ("gmtoff") {
            my($secUT,$minUT,$hourUT,$mdayUT,$monUT,$yearUT,$wdayUT,$ydayUT,
               $isdstUT) = gmtime($t);
            if ($mdayUT>($mday+1)) {
               # UT = 28-31   LT = 1
               $mdayUT=0;
            } elsif ($mdayUT<($mday-1)) {
               # UT = 1       LT = 28-31
               $mday=0;
            }
            $sec    = (($mday*24   + $hour)*60   + $min)*60 + $sec;
            $secUT  = (($mdayUT*24 + $hourUT)*60 + $minUT)*60 + $secUT;
            my $off = $sec-$secUT;

            $off    = $dmb->_delta_convert("time","0:0:$off");
            $off    = $dmb->_delta_convert("offset",$off);
            push(@zone,$off);
         }

         when ("registry") {
            my $z = $self->_windows_registry_val();
            push(@zone,$z)  if ($z);
         }

         default {
            warn "ERROR: [_set_curr_zone] invalid method: $method\n";
            return;
         }
      }

      foreach my $zone (@zone) {
         $zone = lc($zone);

         # If we got a zone name/alias
         $currzone = $self->_zone($zone);
         last METHOD  if ($currzone);

         # If we got an abbreviation (EST)
         if (exists $$self{"data"}{"Abbrev"}{$zone}) {
            $currzone = $$self{"data"}{"Abbrev"}{$zone}[0];
            last METHOD;
         }

         # If we got an offset

         $currzone = $self->zone($zone,$dstflag);
         last METHOD  if ($currzone);
      }
   }

   if (! $currzone) {
      warn "ERROR: Date::Manip unable to determine Time Zone.\n";
      die;
   }

   return $currzone;
}

# This comes from the DateTime-TimeZone module
#
sub _windows_registry_val {
   my($self) = @_;

   require Win32::TieRegistry;

   my $lmachine = new Win32::TieRegistry "LMachine",
                      { Access => Win32::TieRegistry::KEY_READ(),
                        Delimiter => "/" }
      or return "";

   my $tzinfo = $lmachine->Open('SYSTEM/CurrentControlSet/Control/TimeZoneInformation/');

   #
   # Windows Vista, Windows 2008 Server
   #

   my $tzkn = $tzinfo->GetValue('TimeZoneKeyName');
   if (defined($tzkn)  &&  $tzkn) {
      # For some reason, Vista is tacking on a bunch of stuff at the
      # end of the timezone, starting with a chr(0). Strip it off.

      my $c = chr(0);
      my $i = index($tzkn,$c);
      if ($i != -1) {
         $tzkn = substr($tzkn,0,$i);
      }
      my $z = $self->_zone($tzkn);
      return $z  if ($z);
   }

   #
   # Windows NT, Windows 2000, Windows XP, Windows 2003 Server
   #

   my $stdnam = $tzinfo->GetValue('StandardName');
   return $self->_zone($stdnam);
}

# We will be testing commands that don't exist on all architectures,
# so disable warnings.
#
no warnings;
sub _cmd {
   my($cmd) = @_;
   local(*IN);
   open(IN,"$cmd |")  ||  return ();
   my @out  = <IN>;
   close(IN);
   chomp(@out);
   return @out;
}
use warnings;

########################################################################
# DETERMINING A TIMEZONE
########################################################################

sub zone {
   my($self,@args) = @_;
   my $dmb         = $$self{"objs"}{"base"};
   if (! @args) {
      my $tz = $dmb->_now("tz");
      return $$self{"data"}{"ZoneNames"}{$tz}
   }

   # Parse the arguments

   my($zone,$abbrev,$offset,$dstflag) = ("","","","");
   my(@abbrev,$date,$tmp);
   foreach my $arg (@args) {

      if (ref($arg) eq "ARRAY") {
         if ($#$arg == 5) {
            # [Y,M,D,H,Mn,S]
            return undef  if ($date);
            $date = $arg;

         } elsif ($#$arg == 2) {
            # [H,Mn,S]
            return undef  if ($offset);
            $offset = $dmb->join("offset",$arg);
            return undef  if (! $offset);

         } else {
            return undef;
         }

      } elsif (ref($arg)) {
         return undef;

      } else {
         $arg = lc($arg);

         if ($arg =~ /^(std|dst|stdonly|dstonly)$/) {
            return undef  if ($dstflag);
            $dstflag = $arg;

         } elsif ($tmp = $self->_zone($arg)) {
            return undef  if ($zone);
            $zone = $tmp;

         } elsif (exists $$self{"data"}{"MyAbbrev"}{$arg}) {
            return undef  if (@abbrev);
            $abbrev = $arg;
            @abbrev = @{ $$self{"data"}{"MyAbbrev"}{$arg} };
         } elsif (exists $$self{"data"}{"Abbrev"}{$arg}) {
            return undef  if (@abbrev);
            $abbrev = $arg;
            @abbrev = @{ $$self{"data"}{"Abbrev"}{$arg} };

         } elsif ($tmp = $dmb->split("offset",$arg)) {
            return undef  if ($offset);
            $offset = $dmb->_delta_convert("offset",$arg);

         } elsif ($tmp = $dmb->split("date",$arg)) {
            return undef  if ($date);
            $date = $tmp;

         } else {
            return undef;
         }
      }
   }

   #
   # Determine the zones that match all data.
   #

   my @zone;

   while (1) {

      # No information

      if (! $zone  &&
          ! $abbrev  &&
          ! $offset) {
         @zone = (lc($dmb->_now("tz")));
      }

      # $dstflag

      my(@isdst);
      if      ($dstflag eq "stdonly") {
         @isdst = (0);
      } elsif ($dstflag eq "dstonly") {
         @isdst = (1);
      } elsif ($dstflag eq "dst") {
         @isdst = (1,0);
      } else {
         @isdst = (0,1);
      }

      # $zone

      if ($zone) {
         @zone = ($zone);
      }

      # $abbrev

      if ($abbrev) {
         my @z;
         foreach my $isdst (@isdst) {
            my @tmp = $self->_check_abbrev_isdst($abbrev,$isdst,@abbrev);
            if (@tmp) {
               if (@z) {
                  @z = _list_add(\@z,\@tmp);
               } else {
                  @z = @tmp;
               }
            }
         }

         if (@zone) {
            @zone = _list_union(\@z,\@zone);
         } else {
            @zone = @z;
         }
         last  if (! @zone);
      }

      # $offset

      if ($offset) {
         return undef  if (! exists $$self{"data"}{"Offmod"}{$offset});
         $self->_offmod($offset);

         my @z;
         foreach my $isdst (@isdst) {
            my @tmp;
            if      (exists $$self{"data"}{"MyOffsets"}{$offset}{$isdst}) {
               @tmp = @{ $$self{"data"}{"MyOffsets"}{$offset}{$isdst} };
            } elsif (exists $$self{"data"}{"Offsets"}{$offset}{$isdst}) {
               @tmp = @{ $$self{"data"}{"Offsets"}{$offset}{$isdst} };
            }
            @tmp = $self->_check_offset_abbrev_isdst($offset,$abbrev,$isdst,@tmp)
              if ($abbrev);
            if (@tmp) {
               if (@z) {
                  @z = _list_add(\@z,\@tmp);
               } else {
                  @z = @tmp;
               }
            }
         }

         if (@zone) {
            @zone = _list_union(\@zone,\@z);
         } else {
            @zone = @z;
         }
         last  if (! @zone);
      }

      # $date

      if ($date) {
         # Get all periods for the year.
         #
         # Test all periods to make sure that $date is between the
         # wallclock times AND matches other criteria. All periods
         # must be tested since the same wallclock time can be in
         # multiple periods.

         my @tmp;
         my $isdst = "";
         $isdst    = 0  if ($dstflag eq "stdonly");
         $isdst    = 1  if ($dstflag eq "dstonly");
       ZONE: foreach my $z (@zone) {
            $self->_module($z);
            my $y       = $$date[0];
            my @periods = $self->_all_periods($z,$y);

            foreach my $period (@periods) {
               my($begUT,$begLT,$off,$offref,$abb,$dst,$endUT,$endLT) = @$period;
               next  if ($dmb->cmp($date,$begLT) == -1  ||
                         $dmb->cmp($date,$endLT) == 1 ||
                         ($offset ne ""  &&  $offset ne $off)  ||
                         ($isdst  ne ""  &&  $isdst  ne $dst)  ||
                         ($abbrev ne ""  &&  lc($abbrev) ne lc($abb))
                        );
               push(@tmp,$z);
               next ZONE;
            }
         }
         @zone = @tmp;
         last  if (! @zone);
      }

      last;
   }

   # Return the value/list

   if (wantarray) {
      my @ret;
      foreach my $z (@zone) {
         push(@ret,$$self{"data"}{"ZoneNames"}{$z});
      }
      return @ret;
   }

   return "" if (! @zone);
   return $$self{"data"}{"ZoneNames"}{$zone[0]}
}

# This returns a list of all timezones which have the correct
# abbrev/isdst combination.
#
sub _check_abbrev_isdst {
   my($self,$abbrev,$isdst,@zones) = @_;

   my @ret;
 ZONE: foreach my $zone (@zones) {
      $self->_module($zone);

      foreach my $y (sort keys %{ $$self{"data"}{"Zones"}{$zone}{"Dates"} }) {
         my @periods = @{ $$self{"data"}{"Zones"}{$zone}{"Dates"}{$y} };
         foreach my $period (@periods) {
            my($dateUT,$dateLT,$off,$offref,$abb,$dst,$endUT,$endLT) = @$period;
            next  if (lc($abbrev)  ne lc($abb)  ||
                      $isdst != $dst);
            push(@ret,$zone);
            next ZONE;
         }
      }
   }

   return @ret;
}

# This returns a list of all timezones which have the correct
# abbrev/isdst combination.
#
sub _check_offset_abbrev_isdst {
   my($self,$offset,$abbrev,$isdst,@zones) = @_;

   my @ret;
 ZONE: foreach my $zone (@zones) {
      $self->_module($zone);

      foreach my $y (sort keys %{ $$self{"data"}{"Zones"}{$zone}{"Dates"} }) {
         my @periods = @{ $$self{"data"}{"Zones"}{$zone}{"Dates"}{$y} };
         foreach my $period (@periods) {
            my($dateUT,$dateLT,$off,$offref,$abb,$dst,$endUT,$endLT) = @$period;
            next  if (lc($abbrev)  ne lc($abb)  ||
                      $offset ne $off  ||
                      $isdst != $dst);
            push(@ret,$zone);
            next ZONE;
         }
      }
   }

   return @ret;
}

# This finds the elements common to two lists, and preserves the order
# from the first list.
#
sub _list_union {
   my($list1,$list2) = @_;
   my(%list2) = map { $_,1 } @$list2;
   my(@ret);
   foreach my $ele (@$list1) {
      push(@ret,$ele)  if (exists $list2{$ele});
   }
   return @ret;
}

# This adds elements from the second list to the first list, provided
# they are not already there.
#
sub _list_add {
   my($list1,$list2) = @_;
   my(%list1) = map { $_,1 } @$list1;
   my(@ret) = @$list1;
   foreach my $ele (@$list2) {
      next  if (exists $list1{$ele});
      push(@ret,$ele);
      $list1{$ele} = 1;
   }
   return @ret;
}

########################################################################
# PERIODS METHODS
########################################################################

sub all_periods {
   my($self,$zone,$year) = @_;

   my $z = $self->_zone($zone);
   if (! $z) {
      warn "ERROR: [periods] Invalid zone: $zone\n";
      return;
   }
   $zone = $z;
   $self->_module($zone);

   return $self->_all_periods($zone,$year);
}

sub _all_periods {
   my($self,$zone,$year) = @_;
   $year += 0;

   if (! exists $$self{"data"}{"Zones"}{$zone}{"AllDates"}{$year}) {

      #
      # $ym1 is the year prior to $year which contains a rule (which will
      # end in $year or later). $y is $year IF the zone contains rules
      # for this year.
      #

      my($ym1,$ym0);
      if ($year > $$self{"data"}{"LastYear"}  &&  $self->_use_lastrule($zone)) {
         $ym1 = $year-1;
         $ym0 = $year;

      } else {
         foreach my $y (sort { $a <=> $b }
                        keys %{ $$self{"data"}{"Zones"}{$zone}{"Dates"} }) {
            if ($y < $year) {
               $ym1 = $y;
               next;
            }
            $ym0 = $year  if ($year == $y);
            last;
         }
      }
      $ym1 = 0  if (! $ym1);

      #
      # Get the periods from the prior year.  The last one is used (any others
      # are discarded).
      #

      my(@periods);

      # $ym1 will be 0 in 0001
      if ($ym1) {
         my @tmp = $self->_periods($zone,$ym1);
         push(@periods,pop(@tmp))  if (@tmp);
      }

      #
      # Add on any periods from the current year.
      #

      if ($ym0) {
         push(@periods,$self->_periods($zone,$year));
      }

      $$self{"data"}{"Zones"}{$zone}{"AllDates"}{$year} = [ @periods ];
   }

   return @{ dclone($$self{"data"}{"Zones"}{$zone}{"AllDates"}{$year}) };
}

sub periods {
   my($self,$zone,$year) = @_;

   my $z = $self->_zone($zone);
   if (! $z) {
      warn "ERROR: [periods] Invalid zone: $zone\n";
      return;
   }
   $zone = $z;
   $self->_module($zone);

   return $self->_periods($zone,$year);
}

sub _periods {
   my($self,$zone,$year) = @_;
   $year += 0;

   if (! exists $$self{"data"}{"Zones"}{$zone}{"Dates"}{$year}) {

      my @periods = ();
      if ($year > $$self{"data"}{"LastYear"}) {
         # Calculate periods using the LastRule method
         @periods = $self->_lastrule($zone,$year);
      }

      $$self{"data"}{"Zones"}{$zone}{"Dates"}{$year} = [ @periods ];
   }

   return @{ dclone($$self{"data"}{"Zones"}{$zone}{"Dates"}{$year}) };
}

sub date_period {
   my($self,$date,$zone,$wallclock,$isdst) = @_;
   $wallclock = 0  if (! $wallclock);
   $isdst     = 0  if (! $isdst);

   my $z = $self->_zone($zone);
   if (! $z) {
      warn "ERROR: [date_period] Invalid zone: $zone\n";
      return;
   }
   $zone = $z;
   $self->_module($zone);

   my $dmb  = $$self{"objs"}{"base"};
   my @date = @$date;
   my $year = $date[0];

   if ($wallclock) {
      # A wallclock date

      my @period = $self->_all_periods($zone,$year);
      my $beg    = $period[0]->[1];
      my $end    = $period[-1]->[-1];
      if      ($dmb->cmp($date,$beg) == -1) {
         @period = $self->_all_periods($zone,$year-1);
      } elsif ($dmb->cmp($date,$end) == 1) {
         @period = $self->_all_periods($zone,$year+1);
      }

      my(@per);
      foreach my $period (@period) {
         my($begUT,$begLT,$offsetstr,$offset,$abbrev,$dst,$endUT,$endLT) = @$period;
         if ($dmb->cmp($date,$begLT) != -1  &&  $dmb->cmp($date,$endLT) != 1) {
            push(@per,$period);
         }
      }

      if ($#per == -1) {
         return ();
      } elsif ($#per == 0) {
         return $per[0];
      } elsif ($#per == 1) {
         if ($per[0][5] == $isdst) {
            return $per[0];
         } else {
            return $per[1];
         }
      } else {
         warn "ERROR: [date_period] Impossible error\n";
         return;
      }

   } else {
      # A GMT date

      my @period = $self->_all_periods($zone,$year);
      foreach my $period (@period) {
         my($dateUT,$dateLT,$offsetstr,$offset,$abbrev,$isdst,$endUT,$endLT) = @$period;
         if ($dmb->cmp($date,$dateUT) != -1  &&  $dmb->cmp($date,$endUT) != 1) {
            return $period;
         }
      }
      warn "ERROR: [date_period] Impossible error\n";
      return;
   }
}

# Determines whether or not to use the LAST RULE for a zone.
#
sub _use_lastrule {
   my($self,$zone) = @_;

   my @mon = (sort keys
              %{ $$self{"data"}{"Zones"}{$zone}{"LastRule"}{"rules"} });
   return 0  if (! @mon);
   return 1;
}

# Calculate critical dates from the last rule. If $endonly is passed
# in, it only calculates the ending of the zone period before the
# start of the first one. This is necessary so that the last period in
# one year can find out when it ends (which is determined in the
# following year).
#
# Returns:
#   [begUT, begLT, offsetstr, offset, abb, ISDST, endUT, endLT]
# for each.
#
sub _lastrule {
   my($self,$zone,$year,$endonly) = @_;

   #
   # Get the list of rules (actually, the month in which the
   # rule triggers a time change). If there are none, then
   # this zone doesn't have a LAST RULE.
   #

   my @mon = (sort keys
              %{ $$self{"data"}{"Zones"}{$zone}{"LastRule"}{"rules"} });
   return ()  if (! @mon);

   #
   # Analyze each time change.
   #

   my @dates = ();
   my $dmb   = $$self{"objs"}{"base"};

   my $stdoff = $$self{"data"}{"Zones"}{$zone}{"LastRule"}{"zone"}{"stdoff"};
   my $dstoff = $$self{"data"}{"Zones"}{$zone}{"LastRule"}{"zone"}{"dstoff"};

   my (@period,$endUT,$endLT,$begUT,$begLT);

   foreach my $mon (@mon) {
      my $flag =
        $$self{"data"}{"Zones"}{$zone}{"LastRule"}{"rules"}{$mon}{"flag"};
      my $dow  =
        $$self{"data"}{"Zones"}{$zone}{"LastRule"}{"rules"}{$mon}{"dow"};
      my $num  =
        $$self{"data"}{"Zones"}{$zone}{"LastRule"}{"rules"}{$mon}{"num"};
      my $isdst=
        $$self{"data"}{"Zones"}{$zone}{"LastRule"}{"rules"}{$mon}{"isdst"};
      my $time =
        $$self{"data"}{"Zones"}{$zone}{"LastRule"}{"rules"}{$mon}{"time"};
      my $type =
        $$self{"data"}{"Zones"}{$zone}{"LastRule"}{"rules"}{$mon}{"type"};
      my $abb  =
        $$self{"data"}{"Zones"}{$zone}{"LastRule"}{"rules"}{$mon}{"abb"};

      my($endUT,$endLT,$begUT,$begLT) =
        $dmb->_critical_date($year,$mon,$flag,$num,$dow,
                             $isdst,$time,$type,$stdoff,$dstoff);
      return ($endUT,$endLT)  if ($endonly);

      if (@period) {
         push(@period,$endUT,$endLT);
         push(@dates,[@period]);
      }
      my $offsetstr = ($isdst ? $dstoff : $stdoff);
      my $offset    = $dmb->split("offset",$offsetstr);

      @period = ($begUT,$begLT,$offsetstr,$offset,$abb,$isdst);
   }

   push(@period,$self->_lastrule($zone,$year+1,1));
   push(@dates,[@period]);
   return @dates;
}

########################################################################
# CONVERSION
########################################################################

sub convert {
   my($self,$date,$from,$to,$isdst) = @_;
   $self->_convert("convert",$date,$from,$to,$isdst);
}

sub convert_to_gmt {
   my($self,$date,@arg) = @_;
   my($err,$from,$isdst) = _convert_args("convert_to_gmt",@arg);
   return (1) if ($err);

   my $dmb = $$self{"objs"}{"base"};

   if (! $from) {
      $from = $dmb->_now("tz");
   }
   $self->_convert("convert_to_gmt",$date,$from,"GMT",$isdst);
}

sub convert_from_gmt {
   my($self,$date,@arg) = @_;
   my($err,$to,$isdst) = _convert_args("convert_from_gmt",@arg);
   return (1) if ($err);

   my $dmb = $$self{"objs"}{"base"};

   if (! $to) {
      $to = $dmb->_now("tz");
   }
   $self->_convert("convert_from_gmt",$date,"GMT",$to,$isdst);
}

sub convert_to_local {
   my($self,$date,@arg) = @_;
   my($err,$from,$isdst) = _convert_args("convert_to_local",@arg);
   return (1) if ($err);

   my $dmb = $$self{"objs"}{"base"};

   if (! $from) {
      $from = "GMT";
   }
   $self->_convert("convert_to_local",$date,$from,$dmb->_now("tz"),$isdst);
}

sub convert_from_local {
   my($self,$date,@arg) = @_;
   my($err,$to,$isdst) = _convert_args("convert_from_local",@arg);
   return (1) if ($err);

   my $dmb = $$self{"objs"}{"base"};

   if (! $to) {
      $to = "GMT";
   }
   $self->_convert("convert_from_local",$date,$dmb->_now("tz"),$to,$isdst);
}

sub _convert_args {
   my($caller,@args) = @_;

   if ($#args == -1) {
      return (0,"",0);
   } elsif ($#args == 0) {
      if ($args[0] eq "0"  ||
          $args[0] eq "1") {
         return (0,"",$args[0]);
      } else {
         return (0,$args[0],0);
      }
   } elsif ($#args == 1) {
      return (0,@args);
   } else {
      return (1,"",0);
   }
}

sub _convert {
   my($self,$caller,$date,$from,$to,$isdst) = @_;
   my $dmb = $$self{"objs"}{"base"};

   # Handle $date as a reference and a string
   my (@date);
   if (ref($date)) {
      @date = @$date;
   } else {
      @date = @{ $dmb->split("date",$date) };
      $date = [@date];
   }

   return (0,$date)  if ($from eq $to);

   my $tmp = $self->_zone($from);
   if (! $tmp) {
      return (2);
   }
   $from = $tmp;

   $tmp = $self->_zone($to);
   if (! $tmp) {
      return (3);
   }
   $to = $tmp;
   return (0,$date)  if ($from eq $to);

   # Convert $date from $from to GMT


   if ($from ne "Etc/GMT") {
      my $per = $self->date_period($date,$from,1,$isdst);
      if (! $per) {
         return (4);
      }
      my $offset = $$per[3];
      @date = @{ $dmb->calc_date_time(\@date,$offset,1) };
   }

   # Convert $date from GMT to $to

   $isdst     = 0;
   my $offset = [0,0,0];
   my $abb    = "GMT";

   if ($to ne "Etc/GMT") {
      my $per    = $self->date_period([@date],$to,0);
      $offset    = $$per[3];
      $isdst     = $$per[5];
      $abb       = $$per[4];
      @date      = @{ $dmb->calc_date_time(\@date,$offset) };
   }

   return (0,[@date],$offset,$isdst,$abb);
}

########################################################################
# REGULAR EXPRESSIONS FOR TIMEZONE INFORMATION
########################################################################

# Returns a regular expression capable of matching all timezone names
# and aliases.
#
# The regular expression will have the following named matches:
#   zone  = a zone name or alias
#
sub _zonerx {
   my($self) = @_;
   return $$self{"data"}{"zonerx"}  if (defined $$self{"data"}{"zonerx"});
   my @zone  = (keys %{ $$self{"data"}{"Alias"} },
                keys %{ $$self{"data"}{"MyAlias"} });
   @zone     = sort _sortByLength(@zone);
   foreach my $zone (@zone) {
      $zone =~ s/\057/\\057/g;   # /
      $zone =~ s/\055/\\055/g;   # -
      $zone =~ s/\056/\\056/g;   # .
      $zone =~ s/\050/\\050/g;   # (
      $zone =~ s/\051/\\051/g;   # )
      $zone =~ s/\053/\\053/g;   # +
   }
   my $re    = join('|',@zone);
   $$self{"data"}{"zonerx"} = qr/(?<zone>$re)/i;
   return $$self{"data"}{"zonerx"};
}

# Returns a regular expression capable of matching all abbreviations.
#
# The regular expression will have the following named matches:
#   abb  = a zone abbreviation
#
sub _abbrx {
   my($self) = @_;
   return $$self{"data"}{"abbrx"}  if (defined $$self{"data"}{"abbrx"});
   my @abb  = (keys %{ $$self{"data"}{"Abbrev"} },
               keys %{ $$self{"data"}{"MyAbbrev"} });
   @abb     = sort _sortByLength(@abb);
   foreach my $abb (@abb) {
      $abb =~ s/\055/\\055/g;   # -
      $abb =~ s/\053/\\053/g;   # +
   }
   my $re    = join('|',@abb);
   $$self{"data"}{"abbrx"} = qr/(?<abb>$re)/i;
   return $$self{"data"}{"abbrx"};
}

# Returns a regular expression capable of matching a valid timezone as
# an offset. Known formats are:
#    +07              +07 (HST)
#    +0700            +0700 (HST)
#    +07:00           +07:00 (HST)
#    +070000          +070000 (HST)
#    +07:00:00        +07:00:00 (HST)
#
# The regular expression will have the following named matches:
#   off   = the offset
#   abb   = the abbreviation
#
sub _offrx {
   my($self) = @_;
   return $$self{"data"}{"offrx"}  if (defined $$self{"data"}{"offrx"});

   my($hr) = qr/(?:[0-1][0-9]|2[0-3])/;  # 00 - 23
   my($mn) = qr/(?:[0-5][0-9])/;         # 00 - 59
   my($ss) = qr/(?:[0-5][0-9])/;         # 00 - 59

   my($re) = qr/ (?<off> [+-] (?: $hr:$mn:$ss |
                                  $hr$mn$ss   |
                                  $hr:?$mn    |
                                  $hr
                              )
                 )
                 (?: \s* \( (?<abb>.*?) \))? /ix;

   $$self{"data"}{"offrx"} = $re;
   return $$self{"data"}{"offrx"};
}

# Returns a regular expression capable of matching all timezone
# information available. It will match a full timezone, an
# abbreviation, or an offset/abbreviation combination. The regular
# expression will have the following named matches:
#    tzstring  = the full string matched
# in addition to the matches from the _zonerx, _abbrx, and _offrx
# functions.
#
sub _zrx {
   my($self) = @_;
   return $$self{"data"}{"zrx"}  if (defined $$self{"data"}{"zrx"});

   my $zonerx    = $self->_zonerx();          # (america/new_york|...)
   my $zoneabbrx = $self->_abbrx();           # (edt|est|...)
   my $zoneoffrx = $self->_offrx();           # (07:00) (GMT)

   my $zrx       = qr/(?<tzstring>$zonerx|$zoneabbrx|$zoneoffrx)/;
   $$self{"data"}{"zrx"} = $zrx;
   return $zrx;
}

# This sorts from longest to shortest element
#
no strict "vars";
sub _sortByLength {
  return (length $b <=> length $a);
}
use strict "vars";

1;
# Local Variables:
# mode: cperl
# indent-tabs-mode: nil
# cperl-indent-level: 3
# cperl-continued-statement-offset: 2
# cperl-continued-brace-offset: 0
# cperl-brace-offset: 0
# cperl-brace-imaginary-offset: 0
# cperl-label-offset: -2
# End:
