Gecko [ www.thearyasamaj.org ]

Name	Size	Permission
Lang	[ DIR ]	drwxr-xr-x
Offset	[ DIR ]	drwxr-xr-x
TZ	[ DIR ]	drwxr-xr-x
Base.pm	64.21 KB	-rw-r--r--
Base.pod	12.73 KB	-rw-r--r--
Calc.pod	26.37 KB	-rw-r--r--
Changes5.pod	44.8 KB	-rw-r--r--
Changes5to6.pod	24.34 KB	-rw-r--r--
Changes6.pod	37.75 KB	-rw-r--r--
Config.pod	23.75 KB	-rw-r--r--
ConfigFile.pod	4.82 KB	-rw-r--r--
DM5.pm	230.51 KB	-rw-r--r--
DM5.pod	85.36 KB	-rw-r--r--
DM5abbrevs.pm	7.81 KB	-rw-r--r--
DM6.pm	20.5 KB	-rw-r--r--
DM6.pod	21.83 KB	-rw-r--r--
Date.pm	147.87 KB	-rw-r--r--
Date.pod	60.75 KB	-rw-r--r--
Delta.pm	26.73 KB	-rw-r--r--
Delta.pod	21.36 KB	-rw-r--r--
Examples.pod	9.61 KB	-rw-r--r--
History.pod	7.42 KB	-rw-r--r--
Holidays.pod	9.96 KB	-rw-r--r--
Interfaces.pod	7.83 KB	-rw-r--r--
Lang.pod	4.48 KB	-rw-r--r--
Migration5to6.pod	3.88 KB	-rw-r--r--
Misc.pod	13.52 KB	-rw-r--r--
Obj.pm	7.87 KB	-rw-r--r--
Obj.pod	8.2 KB	-rw-r--r--
Objects.pod	13.25 KB	-rw-r--r--
Problems.pod	22.32 KB	-rw-r--r--
Recur.pm	70.1 KB	-rw-r--r--
Recur.pod	43.54 KB	-rw-r--r--
TZ.pm	53.4 KB	-rw-r--r--
TZ.pod	29.3 KB	-rw-r--r--
TZ_Base.pm	10.7 KB	-rw-r--r--
TZ_Base.pod	1.34 KB	-rw-r--r--
TZdata.pm	38.38 KB	-rw-r--r--
TZdata.pod	2.25 KB	-rw-r--r--
Zones.pm	137.01 KB	-rw-r--r--
Zones.pod	152.53 KB	-rw-r--r--

Code Editor : TZ.pm

package Date::Manip::TZ;
# Copyright (c) 2008-2017 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;
use Date::Manip::TZ_Base;
@ISA = qw(Date::Manip::Obj Date::Manip::TZ_Base);

require 5.010000;
use warnings;
use strict;

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

our $VERSION;
$VERSION='6.60';
END { undef $VERSION; }

# To get rid of a 'used only once' warnings.
END {
   my $tmp = \%Date::Manip::Zones::Module;
   $tmp    = \%Date::Manip::Zones::ZoneNames;
   $tmp    = \%Date::Manip::Zones::Alias;
   $tmp    = \%Date::Manip::Zones::Abbrev;
   $tmp    = \%Date::Manip::Zones::Offmod;
   $tmp    = $Date::Manip::Zones::FirstDate;
   $tmp    = $Date::Manip::Zones::LastDate;
   $tmp    = $Date::Manip::Zones::LastYear;
   $tmp    = $Date::Manip::Zones::TzcodeVersion;
   $tmp    = $Date::Manip::Zones::TzdataVersion;
}

########################################################################
# 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
      # path        the PATH to set 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'        => [],
      'path'           => undef,
      'zonerx'         => undef,
      'abbrx'          => undef,
      'offrx'          => undef,
      'zrx'            => undef,
     };

# OS specific stuff

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

if ($os eq 'Unix') {
      $$self{'data'}{'path'}    = '/bin:/usr/bin';
      $$self{'data'}{'methods'} = [
                                   qw(main   TZ
                                      env    zone TZ
                                      file   /etc/TIMEZONE
                                      file   /etc/timezone
                                      file   /etc/sysconfig/clock
                                      file   /etc/default/init
                                      tzdata /etc/localtime /usr/share/zoneinfo
                                    ),
                                   '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
                                    ),
                                   'command',  '/bin/date +%z',
                                   'command',  '/usr/bin/date +%z',
                                   'command',  '/usr/local/bin/date +%z',
                                   'gmtoff'
                                  ];

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

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

} else {
      $$self{'data'}{'methods'} = [
                                   qw(main TZ
                                      env  zone 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{'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{'base'};

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

my($ret) = $self->_now('systz',1);
   return $$self{'data'}{'ZoneNames'}{$ret}
}

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{'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{'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'} };
   my $debug     = ($ENV{DATE_MANIP_DEBUG} ? 1 : 0);

defined $$self{'data'}{'path'}
     and local $ENV{PATH} = $$self{'data'}{'path'};

METHOD:
   while (@methods) {
      my $method = shift(@methods);
      my @zone   = ();

print "*** DEBUG *** METHOD: $method ["  if ($debug);

if ($method eq 'main') {

if (! @methods) {
            print "]\n"  if ($debug);
            warn "ERROR: [_set_curr_zone] main requires argument\n";
            return;
         }
         my $var = shift(@methods);
         print "$var] "  if ($debug);
         no strict "refs";
         my $val = ${ "::$var" };
         use strict "refs";
         if (defined $val) {
            push(@zone,$val);
            print "$val\n"  if ($debug);
         } else {
            print "undef\n"  if ($debug);
         }

} elsif ($method eq 'env') {
         if (@methods < 2) {
            print "]\n"  if ($debug);
            warn "ERROR: [_set_curr_zone] env requires 2 argument\n";
            return;
         }
         my $type = lc( shift(@methods) );
         print "$type,"  if ($debug);

if ($type ne 'zone'  &&
             $type ne 'offset') {
            print "?]\n"  if ($debug);
            warn "ERROR: [_set_curr_zone] env requires 'offset' or 'zone' " .
                 "as the first argument\n";
            return;
         }
         my $var  = shift(@methods);
         print "$var] "  if ($debug);
         if (exists $ENV{$var}) {
            if ($type eq 'zone') {
               push(@zone,$ENV{$var});
               print "$ENV{$var}\n"  if ($debug);
            } else {
               my $off = $ENV{$var};
               print "$ENV{$var} = "  if ($debug);
               $off    = $dmb->_delta_convert('time',"0:0:$off");
               $off    = $dmb->_delta_convert('offset',$off);
               print "$off\n"  if ($debug);
               push(@zone,$off);
            }
         } else {
            print "undef\n"  if ($debug);
         }

} elsif ($method eq 'file') {
         if (! @methods) {
            print "]\n"  if ($debug);
            warn "ERROR: [_set_curr_zone] file requires argument\n";
            return;
         }
         my $file = shift(@methods);
         print "$file] "  if ($debug);
         if (! -f $file) {
            print "not found\n"  if ($debug);
            next;
         }

my $in = new IO::File;
         $in->open($file)  ||  next;
         my $firstline = 1;

my @z;
         while (! $in->eof) {
            my $line = <$in>;
            chomp($line);
            next  if ($line =~ /^\s*\043/  ||
                      $line =~ /^\s*$/);
            if ($firstline) {
               $firstline = 0;
               $line      =~ s/^\s*//;
               $line      =~ s/\s*$//;
               $line      =~ s/["']//g;  # "
               $line      =~ s/\s+/_/g;
               @z         = ($line);
            }

# We're looking for lines of the form:
            #   TZ = string
            #   TIMEZONE = string
            #   ZONE = string
            # Alternately, we may use a 1-line file (ignoring comments and
            # whitespace) which contains only the zone name (it may be
            # quoted or contain embedded whitespace).
            #
            # 'string' can be:
            #   the name of a timezone enclosed in single/double quotes
            #   with everything after the closing quote ignored (the
            #   name of the timezone may have spaces instead of underscores)
            #
            #   a space delimited list of tokens, the first of which
            #   is the time zone
            #
            #   the name of a timezone with underscores replaced by
            #   spaces and nothing after the timezone
            #
            # For some reason, RHEL6 desktop version stores timezones as
            #   America/New York
            # instead of
            #   America/New_York
            # which is why we have to handle the space/underscore
            # substitution.

if ($line =~ /^\s*(?:TZ|TIMEZONE|ZONE)\s*=\s*(.*)\s*$/) {
               my $val  = $1;
               @z       = ();
               last  if (! $val);

if ($val =~ /^(["'])(.*?)\1/) {
                  my $z = $2;
                  last  if (! $z);
                  $z    =~ s/\s+/_/g;
                  push(@zone,$z);

} elsif ($val =~ /\s/) {
                  $val  =~ /^(\S+)/;
                  push(@zone,$1);
                  $val  =~ s/\s+/_/g;
                  push(@zone,$val);

} else {
                  push(@zone,$val);
               }

last;
            }
         }
         close(IN);

push(@zone,@z)  if (@z);

if ($debug) {
            if (@zone) {
               print "@zone\n";
            } else {
               print "no result\n";
            }
         }

} elsif ($method eq 'tzdata') {
         if (@methods < 2) {
            print "]\n"  if ($debug);
            warn "ERROR: [_set_curr_zone] tzdata requires two arguments\n";
            return;
         }
         my $file    = shift(@methods);
         my $dir     = shift(@methods);

my $z;
         if (-f $file  &&  -d $dir) {
            $z = _get_zoneinfo_zone($file,$dir);
         }
 	 if (defined($z)) {
 	    push @zone, $z;
 	    print "] $z\n"  if ($debug);
 	 } elsif ($debug) {
 	    print "] no result\n";
 	 }

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

if ($debug) {
            if ($out) {
               print "$out\n";
            } else {
               print "no output\n";
            }
         }

} elsif ($method eq 'cmdfield') {
         if ($#methods < 1) {
            print "]\n"  if ($debug);
            warn "ERROR: [_set_curr_zone] cmdfield requires 2 arguments\n";
            return;
         }
         my $command = shift(@methods);
         my $n       = shift(@methods);
         print "$command,$n]\n"  if ($debug);
         my ($out)   = _cmd($command);
         my $val;

if ($out) {
            $out    =~ s/^\s*//;
            $out    =~ s/\s*$//;
            my @out = split(/\s+/,$out);
            $val    = $out[$n]  if (defined $out[$n]);
            push(@zone,$val);
         }

if ($debug) {
            if ($val) {
               print "$val\n";
            } else {
               print "no result\n";
            }
         }

} elsif ($method eq 'gmtoff') {
         print "] "  if ($debug);
         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);
         print "$off\n"  if ($debug);

} elsif ($method eq 'registry') {
         print "] "  if ($debug);
         my $z = $self->_windows_registry_val();
         if ($z) {
            push(@zone,$z);
            print "$z\n"  if ($debug);
         } else {
            print "no result\n"  if ($debug);
         }

} else {
         print "]\n"  if ($debug);
         warn "ERROR: [_set_curr_zone] invalid method: $method\n";
         return;
      }

while (@zone) {
         my $zone = lc(shift(@zone));

# OpenUNIX puts a colon at the start
         $zone =~ s/^://;

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

#######################
# The following section comes from the DateTime-TimeZone module

{
   my $want_content;
   my $want_size;
   my $zoneinfo;

sub _get_zoneinfo_zone {
      my($localtime,$z) = @_;
      $zoneinfo = $z;

# /etc/localtime should be either a link to a tzdata file in
      # /usr/share/zoneinfo or a copy of one of the files there.

return ''  if (! -d $zoneinfo || ! -f $localtime);

require Cwd;
      if (-l $localtime) {
         return _zoneinfo_file_name_to_zone(
                                            Cwd::abs_path($localtime),
                                            $zoneinfo,
                                           );
      }

$want_content = _zoneinfo_file_slurp($localtime);
      $want_size    = -s $localtime;

# File::Find can't bail in the middle of a find, and we only want the
      # first match, so we'll call it in an eval.

local $@ = undef;
      eval {
         require File::Find;
         File::Find::find
             ({
               wanted      => \&_zoneinfo_find_file,
               no_chdir    => 1,
              },
              $zoneinfo,
           );
           1;
      } and return;
      ref $@
        and return $@->{zone};
      die $@;
   }

sub _zoneinfo_find_file {
      my $zone;
      defined($zone = _zoneinfo_file_name_to_zone($File::Find::name,
                                                  $zoneinfo))
        and -f $_
        and $want_size == -s _
        and ($want_content eq _zoneinfo_file_slurp($File::Find::name))
        and die { zone => $zone };
   }
}

sub _zoneinfo_file_name_to_zone {
   my($file,$zoneinfo) = @_;
   require File::Spec;
   my $zone = File::Spec->abs2rel($file,$zoneinfo);
   return $zone  if (exists $Date::Manip::Zones::ZoneNames{lc($zone)});
   return;
}

sub _zoneinfo_file_slurp {
   my($file) = @_;
   open my $fh, '<', $file
     or return;
   binmode $fh;
   local $/ = undef;
   return <$fh>;
}

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');
   my $z = $self->_zone($stdnam);
   return $z  if ($z);

#
   # For non-English versions, we have to determine which timezone it
   # actually is.
   #

my $atz = $lmachine->Open('SOFTWARE/Microsoft/Windows NT/CurrentVersion/Time Zones/');
   if (! defined($atz)  ||  ! $atz) {
      $atz = $lmachine->Open('SOFTWARE/Microsoft/Windows/CurrentVersion/Time Zones/');
   }

return ""  if (! defined($atz)  ||  ! $atz);

foreach my $z ($atz->SubKeyNames()) {
      my $tmp  = $atz->Open("$z/");
      my $znam = $tmp->GetValue('Std');
      return $z  if ($znam eq $stdnam);
   }
}

# End of DateTime-TimeZone section
#######################

# 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{'base'};
   if (! @args) {
      my($tz) = $self->_now('tz',1);
      return $$self{'data'}{'ZoneNames'}{$tz}
   }

# Parse the arguments

my($zone,$abbrev,$offset,$dstflag) = ('','','','');
   my $date = [];
   my $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}  ||
                  exists $$self{'data'}{'Abbrev'}{$arg}) {
            return undef  if ($abbrev);
            $abbrev       = $arg;
         } elsif (exists $$self{'data'}{'Abbrev'}{$arg}) {
            return undef  if ($abbrev);
            $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;
         }
      }
   }

return $self->__zone($date,$offset,$zone,$abbrev,$dstflag);
}

# $date   = [Y,M,D,H,Mn,S]
# $offset = '-HH:Mn:SS'
# $zone   = 'us/eastern'   (lowercase)
# $abbrev = 'est'          (lowercase)
# $dstflag= 'stdonly'      (lowercase)
#
sub __zone {
   my($self,$date,$offset,$zone,$abbrev,$dstflag) = @_;
   my $dmb          = $$self{'base'};

#
   # Determine the zones that match all data.
   #

my @zone;

while (1) {

# No information

if (! $zone  &&
          ! $abbrev  &&
          ! $offset) {
         my($z) = $self->_now('tz',1);
         @zone = (lc($z));
      }

# $dstflag
      #
      # $dstflag is "dst' if
      #    zone is passed in as an offset
      #    date is passed in

$dstflag = "dst"  if ($offset  &&  @$date  &&  ! $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);
      }

# We may pass in $zone and not $abbrev when it really should be
      # $abbrev.

if ($zone  &&  ! $abbrev) {
         if (exists $$self{'data'}{'Alias'}{$zone}) {
            # no change
         } elsif (exists $$self{'data'}{'MyAbbrev'}{$zone}  ||
                  exists $$self{'data'}{'Abbrev'}{$zone}) {
            $abbrev = $zone;
            $zone   = '';
         }
      }

# $zone

if ($zone) {
         my $z = (exists $$self{'data'}{'Alias'}{$zone} ?
                  $$self{'data'}{'Alias'}{$zone} : $zone);
         @zone = ($z);
      }

# $abbrev

if ($abbrev) {
         my @abbrev_zones;
         if (exists $$self{'data'}{'MyAbbrev'}{$abbrev}) {
            @abbrev_zones = @{ $$self{'data'}{'MyAbbrev'}{$abbrev} };
         } elsif (exists $$self{'data'}{'Abbrev'}{$abbrev}) {
            @abbrev_zones = @{ $$self{'data'}{'Abbrev'}{$abbrev} };
         }

my @z;
         foreach my $isdst (@isdst) {
            my @tmp = $self->_check_abbrev_isdst($abbrev,$isdst,@abbrev_zones);
            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 = $$self{'data'}{'MyOffsets'}{$offset}{$isdst} ||
                      $$self{'data'}{'Offsets'}{$offset}{$isdst};

my @tmp;
            if ($abbrev) {
               @tmp = $self->_check_offset_abbrev_isdst($offset,$abbrev,$isdst,$tmp);
            } else {
               @tmp = @$tmp  if ($tmp);
            }

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)  if (! exists $$self{'data'}{'Zones'}{$z}{'Loaded'});
            my $y       = $$date[0];
            my @periods = $self->_all_periods($z,$y);

foreach my $period (@periods) {
               next  if (($abbrev ne ''  &&  lc($abbrev) ne lc($$period[4]))  ||
                         ($offset ne ''  &&  $offset ne $$period[2])  ||
                         ($isdst  ne ''  &&  $isdst  ne $$period[5])  ||
                         $dmb->cmp($date,$$period[1]) == -1  ||
                         $dmb->cmp($date,$$period[7]) == 1
                        );
               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)  if (! exists $$self{'data'}{'Zones'}{$zone}{'Loaded'});

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)  if (! exists $$self{'data'}{'Zones'}{$zone}{'Loaded'});

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)  if (! exists $$self{'data'}{'Zones'}{$zone}{'Loaded'});

# Run a faster 'dclone' so we don't return the actual data.

my @tmp = $self->_all_periods($zone,$year);
   my @ret;
   foreach my $ele (@tmp) {
      push(@ret,
           [ [ @{$$ele[0]} ],[ @{$$ele[1]} ],$$ele[2],[ @{$$ele[3]} ],$$ele[4],
             $$ele[5], [ @{$$ele[6]} ],[ @{$$ele[7]} ],$$ele[8],$$ele[9],
             $$ele[10],$$ele[11] ]);
   }
   return @ret;
}

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'}  &&
          exists $$self{'data'}{'Zones'}{$zone}{'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 @{ $$self{'data'}{'Zones'}{$zone}{'AllDates'}{$year} };
}

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

if (! defined($year1)) {
      return $self->_periods($zone,$year);
   }

$year = 1  if (! defined($year));

my @ret;
   my $lastyear = $$self{'data'}{'LastYear'};

if ($year <= $lastyear) {
      foreach my $y (sort { $a <=> $b }
                     keys %{ $$self{'data'}{'Zones'}{$zone}{'Dates'} }) {
         last  if ($y > $year1  ||  $y > $lastyear);
         next  if ($y < $year);
         push(@ret,$self->_periods($zone,$y));
      }
   }

if ($year1 > $lastyear) {
      $year = $lastyear + 1  if ($year <= $lastyear);
      foreach my $y ($year..$year1) {
         push(@ret,$self->_periods($zone,$y));
      }
   }

return @ret;
}

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

# A faster 'dclone' so we don't return the actual data
   my @ret;
   foreach my $ele (@{ $$self{'data'}{'Zones'}{$zone}{'Dates'}{$year} }) {
      push(@ret,
           [ [ @{$$ele[0]} ],[ @{$$ele[1]} ],$$ele[2],[ @{$$ele[3]} ],$$ele[4],$$ele[5],
             [ @{$$ele[6]} ],[ @{$$ele[7]} ],$$ele[8],$$ele[9],$$ele[10],$$ele[11] ]);
   }
   return @ret;
}

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)  if (! exists $$self{'data'}{'Zones'}{$zone}{'Loaded'});

my $dmb  = $$self{'base'};
   my @date = @$date;
   my $year = $date[0];
   my $dates= $dmb->_date_fields(@$date);

if ($wallclock) {
      # A wallclock date

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

my(@per);
      foreach my $period (@period) {
         my($begUT,$begLT,$offsetstr,$offset,$abbrev,$dst,$endUT,$endLT,
            $begUTs,$begLTs,$endUTs,$endLTs) = @$period;
         if (($dates cmp $begLTs) != -1  &&  ($dates cmp $endLTs) != 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($begUT,$begLT,$offsetstr,$offset,$abbrev,$isdst,$endUT,$endLT,
            $begUTs,$begLTs,$endUTs,$endLTs) = @$period;
         if (($dates cmp $begUTs) != -1  &&  ($dates cmp $endUTs) != 1) {
            return $period;
         }
      }
      warn "ERROR: [date_period] Impossible error\n";
      return;
   }
}

# 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,
#    begUTstr, begLTstr, endUTstr, endLTstr]
# 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{'base'};

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

my (@period);

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

# The end of the current period and the beginning of the next
      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]);

foreach my $period (@dates) {
      my($begUT,$begLT,$offsetstr,$offset,$abbrev,$dst,$endUT,$endLT) = @$period;
      my $begUTstr = $dmb->join("date",$begUT);
      my $begLTstr = $dmb->join("date",$begLT);
      my $endUTstr = $dmb->join("date",$endUT);
      my $endLTstr = $dmb->join("date",$endLT);
      $period = [$begUT,$begLT,$offsetstr,$offset,$abbrev,$dst,$endUT,$endLT,
                 $begUTstr,$begLTstr,$endUTstr,$endLTstr];
   }

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{'base'};

if (! $from) {
      $from = $self->_now('tz',1);
   }
   $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{'base'};

if (! $to) {
      $to = $self->_now('tz',1);
   }
   $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{'base'};

if (! $from) {
      $from = 'GMT';
   }
   $self->_convert('convert_to_local',$date,$from,$self->_now('tz',1),$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{'base'};

if (! $to) {
      $to = 'GMT';
   }
   $self->_convert('convert_from_local',$date,$self->_now('tz',1),$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{'base'};

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

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

$tmp = $self->_zone($to);
      if (! $tmp) {
         return (3);
      }
      $to = $tmp;
   }

if ($from eq $to) {
      my $per = $self->date_period($date,$from,1,$isdst);
      my $offset = $$per[3];
      my $abb    = $$per[4];
      return (0,$date,$offset,$isdst,$abb);
   }

# 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 regular expressions capable of matching timezones.
#
# The timezone regular expressions are:
#   namerx   : this will match a zone name or alias (America/New_York)
#   abbrx    : this will match a zone abbreviation (EDT)
#   zonerx   : this will match a zone name or an abbreviation
#   offrx    : this will match a pure offset (+0400)
#   offabbrx : this will match an offset with an abbreviation (+0400 WET)
#   offparrx : this will match an offset and abbreviation if parentheses
#              ("+0400 (WET)")
#   zrx      : this will match all forms
#
# The regular expression will have the following named matches:
#   tzstring : the full string matched
#   zone     : the name/alias
#   abb      : the zone abbrevation
#   off      : the offset
#
sub _zrx {
   my($self,$re) = @_;
   return $$self{'data'}{$re}  if (defined $$self{'data'}{$re});

# Zone name

my @zone;
   if (exists $ENV{'DATE_MANIP_DEBUG_ZONES'}) {
      @zone  = split(/\s+/,$ENV{'DATE_MANIP_DEBUG_ZONES'});
   } else {
      @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 $zone  = join('|',@zone);
   $zone     = qr/(?<zone>$zone)/i;

# Abbreviation

my @abb;
   if (exists $ENV{'DATE_MANIP_DEBUG_ABBREVS'}) {
      @abb  = split(/\s+/,$ENV{'DATE_MANIP_DEBUG_ABBREVS'});
   } else {
      @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 $abb  = join('|',@abb);
   $abb     = qr/(?<abb>$abb)/i;

# Offset (+HH, +HHMM, +HH:MM, +HH:MM:SS, +HHMMSS)

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($off) = qr/ (?<off> [+-] (?: $hr:$mn:$ss |
                                   $hr$mn$ss   |
                                   $hr:?$mn    |
                                   $hr
                               )
                  ) /ix;

# Assemble everything
   #
   # A timezone can be any of the following in this order:
   #    Offset (ABB)
   #    Offset ABB
   #    ABB
   #    Zone
   #    Offset
   # We put ABB before Zone so CET gets parse as the more common abbreviation
   # than the less common zone name.

$$self{'data'}{'namerx'}   = qr/(?<tzstring>$zone)/;
   $$self{'data'}{'abbrx'}    = qr/(?<tzstring>$abb)/;
   $$self{'data'}{'zonerx'}   = qr/(?<tzstring>(?:$abb|$zone))/;
   $$self{'data'}{'offrx'}    = qr/(?<tzstring>$off)/;
   $$self{'data'}{'offabbrx'} = qr/(?<tzstring>$off\s+$abb)/;
   $$self{'data'}{'offparrx'} = qr/(?<tzstring>$off\s*$$abb$)/;
   $$self{'data'}{'zrx'}      = qr/(?<tzstring>(?:$off\s*$$abb$|$off\s+$abb|$abb|$zone|$off))/;

return $$self{'data'}{$re};
}

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

########################################################################
# CONFIG VARS
########################################################################

# This sets a config variable. It also performs all side effects from
# setting that variable.
#
sub _config_var_tz {
   my($self,$var,$val) = @_;

if ($var eq 'tz') {
      my $err = $self->_config_var_setdate("now,$val",0);
      return  if ($err);
      $$self{'data'}{'sections'}{'conf'}{'forcedate'} = 0;
      $val = 1;

} elsif ($var eq 'setdate') {
      my $err = $self->_config_var_setdate($val,0);
      return  if ($err);
      $$self{'data'}{'sections'}{'conf'}{'forcedate'} = 0;
      $val = 1;

} elsif ($var eq 'forcedate') {
      my $err = $self->_config_var_setdate($val,1);
      return  if ($err);
      $$self{'data'}{'sections'}{'conf'}{'setdate'} = 0;
      $val = 1;

} elsif ($var eq 'configfile') {
      $self->_config_file($val);
      return;
   }

my $base = $$self{'base'};
   $$base{'data'}{'sections'}{'conf'}{$var} = $val;
   return;
}

sub _config_var_setdate {
   my($self,$val,$force) = @_;
   my $base = $$self{'base'};

my $dstrx = qr/(?:,\s*(stdonly|dstonly|std|dst))?/i;
   my $zonrx = qr/,\s*(.+)/;
   my $da1rx = qr/(\d\d\d\d)(\d\d)(\d\d)(\d\d):(\d\d):(\d\d)/;
   my $da2rx = qr/(\d\d\d\d)\-(\d\d)\-(\d\d)\-(\d\d):(\d\d):(\d\d)/;
   my $time  = time;

my($op,$date,$dstflag,$zone,@date,$offset,$abb);

#
   # Parse the argument
   #

if ($val =~ /^now${dstrx}${zonrx}$/oi) {
      # now,ZONE
      # now,DSTFLAG,ZONE
      #    Sets now to the system date/time but sets the timezone to be ZONE

$op = 'nowzone';
      ($dstflag,$zone) = ($1,$2);

} elsif ($val =~ /^zone${dstrx}${zonrx}$/oi) {
      # zone,ZONE
      # zone,DSTFLAG,ZONE
      #    Converts 'now' to the alternate zone

$op = 'zone';
      ($dstflag,$zone) = ($1,$2);

} elsif ($val =~ /^${da1rx}${dstrx}${zonrx}$/o  ||
            $val =~ /^${da2rx}${dstrx}${zonrx}$/o) {
      # DATE,ZONE
      # DATE,DSTFLAG,ZONE
      #    Sets the date and zone

$op = 'datezone';
      my($y,$m,$d,$h,$mn,$s);
      ($y,$m,$d,$h,$mn,$s,$dstflag,$zone) = ($1,$2,$3,$4,$5,$6,$7,$8);
      $date = [$y,$m,$d,$h,$mn,$s];

} elsif ($val =~ /^${da1rx}$/o  ||
            $val =~ /^${da2rx}$/o) {
      # DATE
      #    Sets the date in the system timezone

$op = 'date';
      my($y,$m,$d,$h,$mn,$s) = ($1,$2,$3,$4,$5,$6);
      $date   = [$y,$m,$d,$h,$mn,$s];
      $zone   = $self->_now('systz',1);

} elsif (lc($val) eq 'now') {
      # now
      #    Resets everything

my $systz = $$base{'data'}{'now'}{'systz'};
      $base->_init_now();
      $$base{'data'}{'now'}{'systz'} = $systz;
      return 0;

} else {
      warn "ERROR: [config_var] invalid SetDate/ForceDate value: $val\n";
      return 1;
   }

$dstflag = 'std'  if (! $dstflag);

#
   # Get the date we're setting 'now' to
   #

if ($op eq 'nowzone') {
      # Use the system localtime

my($s,$mn,$h,$d,$m,$y) = localtime($time);
      $y += 1900;
      $m++;
      $date = [$y,$m,$d,$h,$mn,$s];

} elsif ($op eq 'zone') {
      # Use the system GMT time

my($s,$mn,$h,$d,$m,$y) = gmtime($time);
      $y += 1900;
      $m++;
      $date = [$y,$m,$d,$h,$mn,$s];
   }

#
   # Find out what zone was passed in. It can be an alias or an offset.
   #

if ($zone) {
      my ($err,@args);
      my $dmb = $$self{'base'};
      $date = []  if (! defined $date);
      $zone = $self->__zone($date,'',lc($zone),'',lc($dstflag));
      if (! $zone) {
         warn "ERROR: [config_var] invalid zone in SetDate: @args\n";
         return 1;
      }

} else {
      $zone = $$base{'data'}{'now'}{'systz'};
   }

#
   # Handle the zone
   #

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

if ($op eq 'nowzone'  ||
       $op eq 'datezone' ||
       $op eq 'date') {

# Check to make sure that the date can exist in this zone.
      my $per;
      foreach my $dst (@isdst) {
         next  if ($per);
         $per = $self->date_period($date,$zone,1,$dst);
      }

if (! $per) {
         warn "ERROR: [config_var] invalid date: SetDate: $date, $zone\n";
         return 1;
      }
      $isdst  = $$per[5];
      $abb    = $$per[4];
      $offset = $$per[3];

} elsif ($op eq 'zone') {

# Convert to that zone
      my($err);
      ($err,$date,$offset,$isdst,$abb) = $self->convert_from_gmt($date,$zone);
      if ($err) {
         warn "ERROR: [config_var] invalid SetDate date/offset values: $date, $zone\n";
         return 1;
      }
   }

#
   # Set NOW
   #

$$base{'data'}{'now'}{'date'}   = $date;
   $$base{'data'}{'now'}{'tz'}     = $self->_zone($zone);
   $$base{'data'}{'now'}{'isdst'}  = $isdst;
   $$base{'data'}{'now'}{'abb'}    = $abb;
   $$base{'data'}{'now'}{'offset'} = $offset;

#
   # Treate SetDate/ForceDate
   #

if ($force) {
      $$base{'data'}{'now'}{'force'}   = 1;
      $$base{'data'}{'now'}{'set'}     = 0;
   } else {
      $$base{'data'}{'now'}{'force'}   = 0;
      $$base{'data'}{'now'}{'set'}     = 1;
      $$base{'data'}{'now'}{'setsecs'} = $time;
      my($err,$setdate)                = $self->convert_to_gmt($date,$zone);
      $$base{'data'}{'now'}{'setdate'} = $setdate;
   }

return 0;
}

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: 0
# End:

${this.title}

Code Editor : TZ.pm