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_Base.pm

package Date::Manip::TZ_Base;
# Copyright (c) 2010-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.

########################################################################
########################################################################

require 5.010000;
use warnings;
use strict;
use IO::File;

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

########################################################################
# METHODS
########################################################################

sub _config_var {
   my($self,$var,$val) = @_;
   $var = lc($var);

# A simple flag used to force a new configuration, but has
   # no other affect.
   return  if ($var eq 'ignore');

my $istz     = ref($self) eq 'Date::Manip::TZ';

if ($istz  &&  ($var eq 'tz'         ||
                   $var eq 'forcedate'  ||
                   $var eq 'setdate'    ||
                   $var eq 'configfile')) {
      if ($var eq 'tz') {
         warn "WARNING: the TZ Date::Manip config variable is deprecated\n" .
              "         and will be removed in March 2017.  Please use\n" .
              "         the SetDate or ForceDate config variables instead.\n";
      }
      return $self->_config_var_tz($var,$val);
   } else {
      my $base  = ($istz ? $$self{'base'} : $self);
      return $base->_config_var_base($var,$val);
   }
}

# This reads a config file
#
sub _config_file {
   my($self,$file) = @_;

return  if (! $file);

if (! -f $file) {
      warn "ERROR: [config_file] file doesn't exist: $file\n";
      return;
   }
   if (! -r $file) {
      warn "ERROR: [config_file] file not readable: $file\n";
      return;
   }

my $in = new IO::File;
   if (! $in->open($file)) {
      warn "ERROR: [config_file] unable to open file: $file: $!\n";
      return;
   }
   my @in = <$in>;
   $in->close();

my $sect = 'conf';
   my %sect;

chomp(@in);
   foreach my $line (@in) {
      $line =~ s/^\s+//o;
      $line =~ s/\s+$//o;
      next  if (! $line  or  $line =~ /^\043/o);

if ($line =~ /^\*/o) {
         # New section
         $sect = $self->_config_file_section($line);
      } else {
         $sect{$sect} = 1;
         $self->_config_file_var($sect,$line);
      }
   }

# If we did a holidays section, we need to create a regular
   # expression with all of the holiday names.

my $istz  = ref($self) eq 'Date::Manip::TZ';
   my $base  = ($istz ? $$self{'base'} : $self);

if (exists $sect{'holidays'}) {
      my @hol = @{ $$base{'data'}{'sections'}{'holidays'} };
      my @nam;
      while (@hol) {
         my $junk = shift(@hol);
         my $hol  = shift(@hol);
         push(@nam,$hol)  if ($hol);
      }

if (@nam) {
         @nam    = sort _sortByLength(@nam);
         my $hol = '(?<holiday>' . join('|',map { "\Q$_\E" } @nam) . ')';
         my $yr  = '(?<y>\d\d\d\d|\d\d)';

my $rx  = "$hol\\s*$yr|" .      # Christmas 2009
                   "$yr\\s*$hol|" .      # 2009 Christmas
                   "$hol";               # Christmas

$$base{'data'}{'rx'}{'holidays'} = qr/^(?:$rx)$/i;
      }
   }
}

sub _config_file_section {
   my($self,$line) = @_;

my $istz  = ref($self) eq 'Date::Manip::TZ';
   my $base  = ($istz ? $$self{'base'} : $self);

$line    =~ s/^\*//o;
   $line    =~ s/\s*$//o;
   my $sect = lc($line);
   if (! exists $$base{'data'}{'sections'}{$sect}) {
      warn "WARNING: [config_file] unknown section created: $sect\n";
      $base->_section($sect);
   }
   return $sect;
}

sub _config_file_var {
   my($self,$sect,$line) = @_;

my $istz  = ref($self) eq 'Date::Manip::TZ';
   my $base  = ($istz ? $$self{'base'} : $self);

my($var,$val);
   if ($line =~ /^\s*(.*?)\s*=\s*(.*?)\s*$/o) {
      ($var,$val) = ($1,$2);
   } else {
      die "ERROR: invalid Date::Manip config file line:\n  $line\n";
   }

if ($sect eq 'conf') {
      $var = lc($var);
      $self->_config($var,$val);
   } else {
      $base->_section($sect,$var,$val);
   }
}

# $val = $self->config(VAR);
#    Returns the value of a variable.
#
# $self->config([SECT], VAR, VAL)  sets the value of a variable
#    Sets the value of a variable.
#
sub _config {
   my($self,$var,$val) = @_;

my $sect = 'conf';

#
   # $self->_conf(VAR, VAL)  sets the value of a variable
   #

$var = lc($var);
   if (defined $val) {
      return $self->_config_var($var,$val);
   }

#
   # $self->_conf(VAR)       returns the value of a variable
   #

if (exists $$self{'data'}{'sections'}{$sect}{$var}) {
      return $$self{'data'}{'sections'}{$sect}{$var};
   } else {
      warn "ERROR: [config] invalid config variable: $var\n";
      return '';
   }
}

########################################################################

sub _fix_year {
   my($self,$y) = @_;
   my $istz     = ref($self) eq 'Date::Manip::TZ';
   my $base     = ($istz ? $self->base() : $self);

my $method   = $base->_config('yytoyyyy');

return $y     if (length($y)==4);
   return undef  if (length($y)!=2);

my $curr_y;
   if (ref($self) eq 'Date::Manip::TZ') {
      $curr_y  = $self->_now('y',1);
   } else {
      $curr_y  = ( localtime(time) )[5];
      $curr_y += 1900;
   }

if ($method eq 'c') {
      return substr($curr_y,0,2) . $y;

} elsif ($method =~ /^c(\d\d)$/) {
      return "$1$y";

} elsif ($method =~ /^c(\d\d)(\d\d)$/) {
      return "$1$y" + ($y<$2 ? 100 : 0);

} else {
      my $y1      = $curr_y - $method;
      my $y2      = $y1 + 99;
      $y1         =~ /^(\d\d)/;
      $y          = "$1$y";
      if ($y<$y1) {
         $y += 100;
      }
      if ($y>$y2) {
         $y -= 100;
      }
      return $y;
   }
}

###############################################################################
# Functions for setting the default date/time

# Many date operations use a default time and/or date to set some
# or all values.  This function may be used to set or examine the
# default time.
#
# _now allows you to get the current date and/or time in the
# local timezone.
#
# The function performed depends on $op and are described in the
# following table:
#
#    $op                  function
#    ------------------   ----------------------------------
#    undef                Returns the current default values
#                         (y,m,d,h,mn,s) without updating
#                         the time (it'll update if it has
#                         never been set).
#
#    'now'                Updates now and returns
#                         (y,m,d,h,mn,s)
#
#    'time'               Updates now and Returns (h,mn,s)
#
#    'y'                  Returns the default value of one
#    'm'                  of the fields (no update)
#    'd'
#    'h'
#    'mn'
#    's'
#
#    'systz'              Returns the system timezone
#
#    'isdst'              Returns the 'now' values if set,
#    'tz'                 or system time values otherwise.
#    'offset'
#    'abb'
#
sub _now {
   my($self,$op,$noupdate) = @_;
   my $istz      = ref($self) eq 'Date::Manip::TZ';
   my $base      = ($istz ? $self->base() : $self);

# Update "NOW" if we're checking 'now', 'time', or the date
   # is not set already.

if (! defined $noupdate) {
      if ($op =~ /(?:now|time)/) {
         $noupdate = 0;
      } else {
         $noupdate = 1;
      }
   }
   $noupdate = 0  if (! exists $$base{'data'}{'now'}{'date'});
   $self->_update_now()  unless ($noupdate);

# Now return the value of the operation

my @tmpnow   = @{ $$base{'data'}{'tmpnow'} };
   my @now      = (@tmpnow ? @tmpnow : @{ $$base{'data'}{'now'}{'date'} });

if ($op eq 'tz') {
      if (exists $$base{'data'}{'now'}{'tz'}) {
         return $$base{'data'}{'now'}{'tz'};
      } else {
         return $$base{'data'}{'now'}{'systz'};
      }

} elsif ($op eq 'systz') {
      return $$base{'data'}{'now'}{'systz'};

} elsif ($op eq 'isdst') {
      return $$base{'data'}{'now'}{'isdst'};

} elsif ($op eq 'offset') {
      return @{ $$base{'data'}{'now'}{'offset'} };

} elsif ($op eq 'abb') {
      return $$base{'data'}{'now'}{'abb'};

} elsif ($op eq 'now') {
      return @now;

} elsif ($op eq 'y') {
      return $now[0];

} elsif ($op eq 'time') {
      return @now[3..5];

} elsif ($op eq 'm') {
      return $now[1];

} elsif ($op eq 'd') {
      return $now[2];

} elsif ($op eq 'h') {
      return $now[3];

} elsif ($op eq 'mn') {
      return $now[4];

} elsif ($op eq 's') {
      return $now[5];

} else {
      warn "ERROR: [now] invalid argument list: $op\n";
      return ();
   }
}

sub _update_now {
   my($self) = @_;
   my $istz     = ref($self) eq 'Date::Manip::TZ';
   my $base     = ($istz ? $self->base() : $self);

# If we've called ForceDate, don't change it.
   return  if ($$base{'data'}{'now'}{'force'});

# If we've called SetDate (which will only happen if a
   # Date::Manip:TZ object is available), figure out what 'now' is
   # based on the number of seconds that have elapsed since it was
   # set.  This will ONLY happen if TZ has been loaded.

if ($$base{'data'}{'now'}{'set'}) {
      my $date = $$base{'data'}{'now'}{'setdate'};
      my $secs = time - $$base{'data'}{'now'}{'setsecs'};

$date      = $base->calc_date_time($date,[0,0,$secs]);  # 'now' in GMT
      my $zone   = $self->_now('tz',1);
      my ($err,$date2,$offset,$isdst,$abbrev) = $self->convert_from_gmt($date,$zone);

$$base{'data'}{'now'}{'date'}   = $date2;
      $$base{'data'}{'now'}{'isdst'}  = $isdst;
      $$base{'data'}{'now'}{'offset'} = $offset;
      $$base{'data'}{'now'}{'abb'}    = $abbrev;
      return;
   }

# Otherwise, we'll use the system time.

my $time = time;
   my($s,$mn,$h,$d,$m,$y,$wday,$yday,$isdst) = localtime($time);
   my($s0,$mn0,$h0,$d0,$m0,$y0)              = gmtime($time);

$y += 1900;
   $m++;

$y0 += 1900;
   $m0++;

my $off = $base->calc_date_date([$y,$m,$d,$h,$mn,$s],[$y0,$m0,$d0,$h0,$mn0,$s0],1);

$$base{'data'}{'now'}{'date'}  = [$y,$m,$d,$h,$mn,$s];
   $$base{'data'}{'now'}{'isdst'} = $isdst;
   $$base{'data'}{'now'}{'offset'}= $off;

my $abb = '???';
   if (ref($self) eq 'Date::Manip::TZ') {
      my $zone   = $self->_now('tz',1);
      my $per    = $self->date_period([$y,$m,$d,$h,$mn,$s],$zone,1,$isdst);
      $abb = $$per[4];
   }

$$base{'data'}{'now'}{'abb'}   = $abb;

return;
}

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

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

${this.title}

Code Editor : TZ_Base.pm