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 = ; 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) = @_; 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'}); 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)/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)/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/ (? [+-] (?: $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/(?$zone)/; $$self{'data'}{'abbrx'} = qr/(?$abb)/; $$self{'data'}{'zonerx'} = qr/(?(?:$abb|$zone))/; $$self{'data'}{'offrx'} = qr/(?$off)/; $$self{'data'}{'offabbrx'} = qr/(?$off\s+$abb)/; $$self{'data'}{'offparrx'} = qr/(?$off\s*\($abb\))/; $$self{'data'}{'zrx'} = qr/(?(?:$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: