Blame lib/Date/Manip/Base.pm

Packit 95306a
package Date::Manip::Base;
Packit 95306a
# Copyright (c) 1995-2017 Sullivan Beck.  All rights reserved.
Packit 95306a
# This program is free software; you can redistribute it and/or modify it
Packit 95306a
# under the same terms as Perl itself.
Packit 95306a
Packit 95306a
###############################################################################
Packit 95306a
# Any routine that starts with an underscore (_) is NOT intended for
Packit 95306a
# public use.  They are for internal use in the the Date::Manip
Packit 95306a
# modules and are subject to change without warning or notice.
Packit 95306a
#
Packit 95306a
# ABSOLUTELY NO USER SUPPORT IS OFFERED FOR THESE ROUTINES!
Packit 95306a
###############################################################################
Packit 95306a
Packit 95306a
require 5.010000;
Packit 95306a
use strict;
Packit 95306a
use warnings;
Packit 95306a
use integer;
Packit 95306a
use utf8;
Packit 95306a
#use re 'debug';
Packit 95306a
Packit 95306a
use Date::Manip::Obj;
Packit 95306a
use Date::Manip::TZ_Base;
Packit 95306a
our @ISA = qw(Date::Manip::Obj Date::Manip::TZ_Base);
Packit 95306a
Packit 95306a
use Encode qw(encode_utf8 from_to find_encoding decode _utf8_off _utf8_on is_utf8);
Packit 95306a
require Date::Manip::Lang::index;
Packit 95306a
Packit 95306a
our $VERSION;
Packit 95306a
$VERSION='6.60';
Packit 95306a
END { undef $VERSION; }
Packit 95306a
Packit 95306a
###############################################################################
Packit 95306a
# BASE METHODS
Packit 95306a
###############################################################################
Packit 95306a
Packit 95306a
sub _init {
Packit 95306a
   my($self) = @_;
Packit 95306a
Packit 95306a
   $self->_init_cache();
Packit 95306a
   $self->_init_language();
Packit 95306a
   $self->_init_config();
Packit 95306a
   $self->_init_events();
Packit 95306a
   $self->_init_holidays();
Packit 95306a
   $self->_init_now();
Packit 95306a
Packit 95306a
   return;
Packit 95306a
}
Packit 95306a
Packit 95306a
# The base object has some config-independant information which is
Packit 95306a
# always reused, and only needs to be initialized once.
Packit 95306a
sub _init_cache {
Packit 95306a
   my($self) = @_;
Packit 95306a
   return  if (exists $$self{'cache'}{'init'});
Packit 95306a
   $$self{'cache'}{'init'}    = 1;
Packit 95306a
Packit 95306a
   # ly          => {Y}    = 0/1  1 if it is a leap year
Packit 95306a
   # ds1_mon     => {Y}{M} = N    days since 1BC for Y/M/1
Packit 95306a
   # dow_mon     => {Y}{M} = DOW  day of week of Y/M/1
Packit 95306a
Packit 95306a
   $$self{'cache'}{'ly'}      = {};
Packit 95306a
   $$self{'cache'}{'ds1_mon'} = {};
Packit 95306a
   $$self{'cache'}{'dow_mon'} = {};
Packit 95306a
Packit 95306a
   return;
Packit 95306a
}
Packit 95306a
Packit 95306a
# Config dependent data. Needs to be reset every time the config is reset.
Packit 95306a
sub _init_data {
Packit 95306a
   my($self,$force) = @_;
Packit 95306a
   return  if (exists $$self{'data'}{'calc'}  &&  ! $force);
Packit 95306a
Packit 95306a
   $$self{'data'}{'calc'}     = {};     # Calculated values
Packit 95306a
Packit 95306a
   return;
Packit 95306a
}
Packit 95306a
Packit 95306a
# Initializes config dependent data
Packit 95306a
sub _init_config {
Packit 95306a
   my($self,$force) = @_;
Packit 95306a
   return  if (exists $$self{'data'}{'sections'}{'conf'}  &&  ! $force);
Packit 95306a
   $self->_init_data();
Packit 95306a
Packit 95306a
   #
Packit 95306a
   # Set config defaults
Packit 95306a
   #
Packit 95306a
Packit 95306a
   $$self{'data'}{'sections'}{'conf'} =
Packit 95306a
     {
Packit 95306a
      # Reset config, holiday lists, or events lists
Packit 95306a
Packit 95306a
      'defaults'         => '',
Packit 95306a
      'eraseholidays'    => '',
Packit 95306a
      'eraseevents'      => '',
Packit 95306a
Packit 95306a
      # Which language to use when parsing dates.
Packit 95306a
Packit 95306a
      'language'         => '',
Packit 95306a
Packit 95306a
      # 12/10 = Dec 10 (US) or Oct 12 (anything else)
Packit 95306a
Packit 95306a
      'dateformat'       => '',
Packit 95306a
Packit 95306a
      # Define the work week (1=monday, 7=sunday)
Packit 95306a
      #
Packit 95306a
      # These have to be predefined to avoid a bootstrap issue, but
Packit 95306a
      # the true defaults are defined below.
Packit 95306a
Packit 95306a
      'workweekbeg'      => 1,
Packit 95306a
      'workweekend'      => 5,
Packit 95306a
Packit 95306a
      # If non-nil, a work day is treated as 24 hours long
Packit 95306a
      # (WorkDayBeg/WorkDayEnd ignored)
Packit 95306a
Packit 95306a
      'workday24hr'      => '',
Packit 95306a
Packit 95306a
      # Start and end time of the work day (any time format allowed,
Packit 95306a
      # seconds ignored). If the defaults change, be sure to change
Packit 95306a
      # the starting value of bdlength above.
Packit 95306a
Packit 95306a
      'workdaybeg'       => '',
Packit 95306a
      'workdayend'       => '',
Packit 95306a
Packit 95306a
      # 2 digit years fall into the 100 year period given by [ CURR-N,
Packit 95306a
      # CURR+(99-N) ] where N is 0-99.  Default behavior is 89, but
Packit 95306a
      # other useful numbers might be 0 (forced to be this year or
Packit 95306a
      # later) and 99 (forced to be this year or earlier).  It can
Packit 95306a
      # also be set to 'c' (current century) or 'cNN' (i.e.  c18
Packit 95306a
      # forces the year to bet 1800-1899).  Also accepts the form
Packit 95306a
      # cNNNN to give the 100 year period NNNN to NNNN+99.
Packit 95306a
Packit 95306a
      'yytoyyyy'         => '',
Packit 95306a
Packit 95306a
      # First day of the week (1=monday, 7=sunday).  ISO 8601 says
Packit 95306a
      # monday.
Packit 95306a
Packit 95306a
      'firstday'         => '',
Packit 95306a
Packit 95306a
      # If this is 0, use the ISO 8601 standard that Jan 4 is in week
Packit 95306a
      # 1.  If 1, make week 1 contain Jan 1.
Packit 95306a
Packit 95306a
      'jan1week1'        => '',
Packit 95306a
Packit 95306a
      # Date::Manip printable format
Packit 95306a
      #   0 = YYYYMMDDHH:MN:SS
Packit 95306a
      #   1 = YYYYHHMMDDHHMNSS
Packit 95306a
      #   2 = YYYY-MM-DD-HH:MN:SS
Packit 95306a
Packit 95306a
      'printable'        => '',
Packit 95306a
Packit 95306a
      # If 'today' is a holiday, we look either to 'tomorrow' or
Packit 95306a
      # 'yesterday' for the nearest business day.  By default, we'll
Packit 95306a
      # always look 'tomorrow' first.
Packit 95306a
Packit 95306a
      'tomorrowfirst'    => 1,
Packit 95306a
Packit 95306a
      # Used to set the current date/time/timezone.
Packit 95306a
Packit 95306a
      'forcedate'        => 0,
Packit 95306a
      'setdate'          => 0,
Packit 95306a
Packit 95306a
      # Use this to set the default range of the recurrence.
Packit 95306a
Packit 95306a
      'recurrange'       => '',
Packit 95306a
Packit 95306a
      # Use this to set the default time.
Packit 95306a
Packit 95306a
      'defaulttime'      => 'midnight',
Packit 95306a
Packit 95306a
      # Whether or not to use a period as a time separator.
Packit 95306a
Packit 95306a
      'periodtimesep'    => 0,
Packit 95306a
Packit 95306a
      # How to parse mmm#### strings
Packit 95306a
Packit 95306a
      'format_mmmyyyy'   => '',
Packit 95306a
Packit 95306a
      # *** DEPRECATED ***
Packit 95306a
Packit 95306a
      'tz'               => '',
Packit 95306a
     };
Packit 95306a
Packit 95306a
   #
Packit 95306a
   # Calculate delta field lengths
Packit 95306a
   #
Packit 95306a
Packit 95306a
   # non-business
Packit 95306a
   $$self{'data'}{'len'}{'yrlen'} = 365.2425;
Packit 95306a
   $$self{'data'}{'len'}{'0'} =
Packit 95306a
     { 'yl'   => 31556952,  # 365.2425 * 24 * 3600
Packit 95306a
       'ml'   => 2629746,   # yl / 12
Packit 95306a
       'wl'   => 604800,    # 6 * 24 * 3600
Packit 95306a
       'dl'   => 86400,     # 24 * 3600
Packit 95306a
     };
Packit 95306a
   $self->_calc_workweek();
Packit 95306a
Packit 95306a
   #
Packit 95306a
   # Initialize some config variables that do some additional work.
Packit 95306a
   #
Packit 95306a
Packit 95306a
   $self->_config_var('workday24hr',  1);
Packit 95306a
   $self->_config_var('workdaybeg',   '08:00:00');
Packit 95306a
   $self->_config_var('workdayend',   '17:00:00');
Packit 95306a
   $self->_config_var('workday24hr',  0);
Packit 95306a
Packit 95306a
   $self->_config_var('dateformat',   'US');
Packit 95306a
   $self->_config_var('yytoyyyy',     89);
Packit 95306a
   $self->_config_var('jan1week1',    0);
Packit 95306a
   $self->_config_var('printable',    0);
Packit 95306a
   $self->_config_var('firstday',     1);
Packit 95306a
   $self->_config_var('workweekbeg',  1);
Packit 95306a
   $self->_config_var('workweekend',  5);
Packit 95306a
   $self->_config_var('language',     'english');
Packit 95306a
   $self->_config_var('recurrange',   'none');
Packit 95306a
   $self->_config_var('defaulttime',  'midnight');
Packit 95306a
Packit 95306a
   # Set OS specific defaults
Packit 95306a
Packit 95306a
   my $os = $self->_os();
Packit 95306a
Packit 95306a
   return;
Packit 95306a
}
Packit 95306a
Packit 95306a
sub _calc_workweek {
Packit 95306a
   my($self,$beg,$end) = @_;
Packit 95306a
Packit 95306a
   $beg = $self->_config('workweekbeg')  if (! $beg);
Packit 95306a
   $end = $self->_config('workweekend')  if (! $end);
Packit 95306a
Packit 95306a
   $$self{'data'}{'len'}{'workweek'} = $end - $beg + 1;
Packit 95306a
Packit 95306a
   return;
Packit 95306a
}
Packit 95306a
Packit 95306a
sub _calc_bdlength {
Packit 95306a
   my($self) = @_;
Packit 95306a
Packit 95306a
   my @beg = @{ $$self{'data'}{'calc'}{'workdaybeg'} };
Packit 95306a
   my @end = @{ $$self{'data'}{'calc'}{'workdayend'} };
Packit 95306a
Packit 95306a
   $$self{'data'}{'len'}{'bdlength'} =
Packit 95306a
     ($end[0]-$beg[0])*3600 + ($end[1]-$beg[1])*60 + ($end[2]-$beg[2]);
Packit 95306a
Packit 95306a
   return;
Packit 95306a
}
Packit 95306a
Packit 95306a
sub _init_business_length {
Packit 95306a
   my($self) = @_;
Packit 95306a
Packit 95306a
   no integer;
Packit 95306a
   my $x      = $$self{'data'}{'len'}{'workweek'};
Packit 95306a
   my $y_to_d = $x/7 * 365.2425;
Packit 95306a
   my $d_to_s = $$self{'data'}{'len'}{'bdlength'};
Packit 95306a
   my $w_to_d = $x;
Packit 95306a
Packit 95306a
   $$self{'data'}{'len'}{'1'} = { 'yl' => $y_to_d * $d_to_s,
Packit 95306a
                                  'ml' => $y_to_d * $d_to_s / 12,
Packit 95306a
                                  'wl' => $w_to_d * $d_to_s,
Packit 95306a
                                  'dl' => $d_to_s,
Packit 95306a
                                };
Packit 95306a
Packit 95306a
   return;
Packit 95306a
}
Packit 95306a
Packit 95306a
# Events and holidays are reset only when they are read in.
Packit 95306a
sub _init_events {
Packit 95306a
   my($self,$force) = @_;
Packit 95306a
   return  if (exists $$self{'data'}{'events'}  &&  ! $force);
Packit 95306a
Packit 95306a
   # {data}{sections}{events} = [ STRING, EVENT_NAME, ... ]
Packit 95306a
   #
Packit 95306a
   # {data}{events}{I}{type}  = TYPE
Packit 95306a
   #                  {name}  = NAME
Packit 95306a
   #    TYPE: specified         An event with a start/end date (only parsed once)
Packit 95306a
   #                  {beg}   = DATE_OBJECT
Packit 95306a
   #                  {end}   = DATE_OBJECT
Packit 95306a
   #    TYPE: ym
Packit 95306a
   #                  {beg}   = YM_STRING
Packit 95306a
   #                  {end}   = YM_STRING (only for YM;YM)
Packit 95306a
   #                  {YEAR}  = [ DATE_OBJECT, DATE_OBJECT ]
Packit 95306a
   #    TYPE: date              An event specified by a date string and delta
Packit 95306a
   #                  {beg}   = DATE_STRING
Packit 95306a
   #                  {end}   = DATE_STRING  (only for Date;Date)
Packit 95306a
   #                  {delta} = DELTA_OBJECT (only for Date;Delta)
Packit 95306a
   #                  {YEAR}  = [ DATE_OBJECT, DATE_OBJECT ]
Packit 95306a
   #    TYPE: recur
Packit 95306a
   #                  {recur} = RECUR_OBJECT
Packit 95306a
   #                  {delta} = DELTA_OBJECT
Packit 95306a
   #
Packit 95306a
   # {data}{eventyears}{YEAR} = 0/1
Packit 95306a
   # {data}{eventobjs}        = 0/1
Packit 95306a
Packit 95306a
   $$self{'data'}{'events'}             = {};
Packit 95306a
   $$self{'data'}{'sections'}{'events'} = [];
Packit 95306a
   $$self{'data'}{'eventyears'}         = {};
Packit 95306a
   $$self{'data'}{'eventobjs'}          = 0;
Packit 95306a
Packit 95306a
   return;
Packit 95306a
}
Packit 95306a
Packit 95306a
sub _init_holidays {
Packit 95306a
   my($self,$force) = @_;
Packit 95306a
   return  if (exists $$self{'data'}{'holidays'}  &&  ! $force);
Packit 95306a
Packit 95306a
   # {data}{sections}{holidays} = [ STRING, HOLIDAY_NAME, ... ]
Packit 95306a
   #
Packit 95306a
   # {data}{holidays}{init}     = 1  if holidays have been initialized
Packit 95306a
   #                 {ydone}    = { Y => 1 }
Packit 95306a
   #                 {yhols}    = { Y => NAME => [Y,M,D] }
Packit 95306a
   #                 {hols}     = { NAME => Y => [Y,M,D] }
Packit 95306a
   #                 {dates}    = { Y => M => D => NAME }
Packit 95306a
   #                 {defs}     = [ NAME DEF NAME DEF ... ]
Packit 95306a
   #                                 NAME is the name of a holiday (it will
Packit 95306a
   #                                 be 'DMunnamed I' for the Ith unnamed
Packit 95306a
   #                                 holiday)
Packit 95306a
   #                                 DEF is a string or a Recur
Packit 95306a
   # {data}{init_holidays}      = 1  if currently initializing holidays
Packit 95306a
Packit 95306a
   $$self{'data'}{'holidays'}             = {};
Packit 95306a
   $$self{'data'}{'sections'}{'holidays'} = [];
Packit 95306a
   $$self{'data'}{'init_holidays'}        = 0;
Packit 95306a
Packit 95306a
   return;
Packit 95306a
}
Packit 95306a
Packit 95306a
sub _init_now {
Packit 95306a
   my($self) = @_;
Packit 95306a
Packit 95306a
   #  {'data'}{'now'} = {
Packit 95306a
   #                     date     => [Y,M,D,H,MN,S]  now
Packit 95306a
   #                     isdst    => ISDST
Packit 95306a
   #                     offset   => [H,MN,S]
Packit 95306a
   #                     abb      => ABBREV
Packit 95306a
   #
Packit 95306a
   #                     force    => 0/1             SetDate/ForceDate information
Packit 95306a
   #                     set      => 0/1
Packit 95306a
   #                     setsecs  => SECS            time (in secs since epoch) when
Packit 95306a
   #                                                 SetDate was called
Packit 95306a
   #                     setdate  => [Y,M,D,H,MN,S]  the date (IN GMT) we're calling
Packit 95306a
   #                                                 now when SetDate was called
Packit 95306a
   #
Packit 95306a
   #                     tz       => ZONE            timezone we're working in
Packit 95306a
   #                     systz    => ZONE            timezone of the system
Packit 95306a
   #                    }
Packit 95306a
   #
Packit 95306a
Packit 95306a
   $$self{'data'}{'now'}          = {};
Packit 95306a
   $$self{'data'}{'now'}{'force'} = 0;
Packit 95306a
   $$self{'data'}{'now'}{'set'}   = 0;
Packit 95306a
   $$self{'data'}{'tmpnow'}       = [];
Packit 95306a
Packit 95306a
   return;
Packit 95306a
}
Packit 95306a
Packit 95306a
# Language information only needs to be initialized if the language changes.
Packit 95306a
sub _init_language {
Packit 95306a
   my($self,$force) = @_;
Packit 95306a
   return  if (exists $$self{'data'}{'lang'}  &&  ! $force);
Packit 95306a
Packit 95306a
   $$self{'data'}{'lang'}      = {};     # Current language info
Packit 95306a
   $$self{'data'}{'rx'}        = {};     # Regexps generated from language
Packit 95306a
   $$self{'data'}{'words'}     = {};     # Types of words in the language
Packit 95306a
   $$self{'data'}{'wordval'}   = {};     # Value of words in the language
Packit 95306a
Packit 95306a
   return;
Packit 95306a
}
Packit 95306a
Packit 95306a
###############################################################################
Packit 95306a
# MAIN METHODS
Packit 95306a
###############################################################################
Packit 95306a
Packit 95306a
sub leapyear {
Packit 95306a
   my($self,$y) = @_;
Packit 95306a
   $y += 0;
Packit 95306a
   return $$self{'cache'}{'ly'}{$y}
Packit 95306a
     if (exists $$self{'cache'}{'ly'}{$y});
Packit 95306a
Packit 95306a
   $$self{'cache'}{'ly'}{$y} = 0, return 0 unless ($y %   4 == 0);
Packit 95306a
   $$self{'cache'}{'ly'}{$y} = 1, return 1 unless ($y % 100 == 0);
Packit 95306a
   $$self{'cache'}{'ly'}{$y} = 0, return 0 unless ($y % 400 == 0);
Packit 95306a
   $$self{'cache'}{'ly'}{$y} = 1;
Packit 95306a
   return 1;
Packit 95306a
}
Packit 95306a
Packit 95306a
sub days_in_year {
Packit 95306a
   my($self,$y) = @_;
Packit 95306a
   return ($self->leapyear($y) ? 366 : 365);
Packit 95306a
}
Packit 95306a
Packit 95306a
{
Packit 95306a
   my(@leap)=(31,29,31,30, 31,30,31,31, 30,31,30,31);
Packit 95306a
   my(@nonl)=(31,28,31,30, 31,30,31,31, 30,31,30,31);
Packit 95306a
Packit 95306a
   sub days_in_month {
Packit 95306a
      my($self,$y,$m) = @_;
Packit 95306a
Packit 95306a
      if ($m) {
Packit 95306a
         return ($self->leapyear($y) ? $leap[$m-1] : $nonl[$m-1]);
Packit 95306a
      } else {
Packit 95306a
         return ($self->leapyear($y) ? @leap : @nonl);
Packit 95306a
      }
Packit 95306a
   }
Packit 95306a
}
Packit 95306a
Packit 95306a
{
Packit 95306a
   # DinM        =     (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31)
Packit 95306a
   my(@doy_days) = ( 0, 31, 59, 90,120,151,181,212,243,273,304,334,365);
Packit 95306a
Packit 95306a
   # Note: I tested storing both leap year and non-leap year days in
Packit 95306a
   # a hash, but it was slightly slower.
Packit 95306a
Packit 95306a
   my($lyd,$n,$remain,$day,$y,$m,$d,$h,$mn,$s,$arg);
Packit 95306a
Packit 95306a
   sub day_of_year {
Packit 95306a
      my($self,@args) = @_;
Packit 95306a
Packit 95306a
      no integer;
Packit 95306a
      if ($#args == 1) {
Packit 95306a
Packit 95306a
         # $date = day_of_year($y,$day);
Packit 95306a
         ($y,$n) = @args;
Packit 95306a
Packit 95306a
         $lyd    = $self->leapyear($y);
Packit 95306a
         $remain = ($n - int($n));
Packit 95306a
         $n      = int($n);
Packit 95306a
Packit 95306a
         # Calculate the month and the day
Packit 95306a
         for ($m=1; $m<=12; $m++) {
Packit 95306a
            last  if ($n<=($doy_days[$m] + ($m==1 ? 0 : $lyd)));
Packit 95306a
         }
Packit 95306a
         $d = $n-($doy_days[$m-1] + (($m-1)<2 ? 0 : $lyd));
Packit 95306a
         return [$y,$m,$d]  if (! $remain);
Packit 95306a
Packit 95306a
         # Calculate the hours, minutes, and seconds into the day.
Packit 95306a
         $remain *= 24;
Packit 95306a
         $h       = int($remain);
Packit 95306a
         $remain  = ($remain - $h)*60;
Packit 95306a
         $mn      = int($remain);
Packit 95306a
         $remain  = ($remain - $mn)*60;
Packit 95306a
         $s       = $remain;
Packit 95306a
Packit 95306a
         return [$y,$m,$d,$h,$mn,$s];
Packit 95306a
Packit 95306a
      } else {
Packit 95306a
         $arg  = $args[0];
Packit 95306a
         @args = @$arg;
Packit 95306a
Packit 95306a
         ($y,$m,$d,$h,$mn,$s) = @args;
Packit 95306a
         $lyd     = $self->leapyear($y);
Packit 95306a
         $lyd     = 0  if ($m <= 2);
Packit 95306a
         $day     = ($doy_days[$m-1]+$d+$lyd);
Packit 95306a
         return $day  if ($#args==2);
Packit 95306a
Packit 95306a
         $day    += ($h*3600 + $mn*60 + $s)/(24*3600);
Packit 95306a
         return $day;
Packit 95306a
      }
Packit 95306a
   }
Packit 95306a
}
Packit 95306a
Packit 95306a
sub days_since_1BC {
Packit 95306a
   my($self,$arg) = @_;
Packit 95306a
Packit 95306a
   if (ref($arg)) {
Packit 95306a
      my($y,$m,$d) = @$arg;
Packit 95306a
      $y += 0;
Packit 95306a
      $m += 0;
Packit 95306a
Packit 95306a
      if (! exists $$self{'cache'}{'ds1_mon'}{$y}{$m}) {
Packit 95306a
Packit 95306a
         if (! exists $$self{'cache'}{'ds1_mon'}{$y}{1}) {
Packit 95306a
Packit 95306a
            my($Ny,$N4,$N100,$N400,$cc,$yy);
Packit 95306a
Packit 95306a
            my $yyyy  = "0000$y";
Packit 95306a
Packit 95306a
            $yyyy     =~ /(\d\d)(\d\d)$/o;
Packit 95306a
            ($cc,$yy) = ($1,$2);
Packit 95306a
Packit 95306a
            # Number of full years since Dec 31, 1BC (starting at 0001)
Packit 95306a
            $Ny       = $y - 1;
Packit 95306a
Packit 95306a
            # Number of full 4th years (0004, 0008, etc.) since Dec 31, 1BC
Packit 95306a
            $N4       = int($Ny/4);
Packit 95306a
Packit 95306a
            # Number of full 100th years (0100, 0200, etc.)
Packit 95306a
Packit 95306a
            $N100     = $cc + 0;
Packit 95306a
            $N100--   if ($yy==0);
Packit 95306a
Packit 95306a
            # Number of full 400th years (0400, 0800, etc.)
Packit 95306a
            $N400     = int($N100/4);
Packit 95306a
Packit 95306a
            $$self{'cache'}{'ds1_mon'}{$y}{1} =
Packit 95306a
              $Ny*365 + $N4 - $N100 + $N400 + 1;
Packit 95306a
         }
Packit 95306a
Packit 95306a
         my($i,$j);
Packit 95306a
         my @mon   = $self->days_in_month($y,0);
Packit 95306a
         for ($i=2; $i<=12; $i++) {
Packit 95306a
            $j     = shift(@mon);
Packit 95306a
            $$self{'cache'}{'ds1_mon'}{$y}{$i} =
Packit 95306a
              $$self{'cache'}{'ds1_mon'}{$y}{$i-1} + $j;
Packit 95306a
         }
Packit 95306a
      }
Packit 95306a
Packit 95306a
      return ($$self{'cache'}{'ds1_mon'}{$y}{$m} + $d - 1);
Packit 95306a
Packit 95306a
   } else {
Packit 95306a
      my($days) = $arg;
Packit 95306a
      my($y,$m,$d);
Packit 95306a
Packit 95306a
      $y = int($days/$$self{'data'}{'len'}{'yrlen'})+1;
Packit 95306a
      while ($self->days_since_1BC([$y,1,1]) > $days) {
Packit 95306a
         $y--;
Packit 95306a
      }
Packit 95306a
      $m = 12;
Packit 95306a
      while ( ($d=$self->days_since_1BC([$y,$m,1])) > $days ) {
Packit 95306a
         $m--;
Packit 95306a
      }
Packit 95306a
      $d = ($days-$d+1);
Packit 95306a
      return [$y,$m,$d];
Packit 95306a
   }
Packit 95306a
}
Packit 95306a
Packit 95306a
sub day_of_week {
Packit 95306a
   my($self,$date) = @_;
Packit 95306a
   my($y,$m,$d) = @$date;
Packit 95306a
   $y += 0;
Packit 95306a
   $m += 0;
Packit 95306a
Packit 95306a
   my($dayofweek,$dec31) = ();
Packit 95306a
   if (! exists $$self{'cache'}{'dow_mon'}{$y}{$m}) {
Packit 95306a
      $dec31 = 7;               # Dec 31, 1BC was Sunday
Packit 95306a
      $$self{'cache'}{'dow_mon'}{$y}{$m} =
Packit 95306a
        ( $self->days_since_1BC([$y,$m,1])+$dec31 ) % 7;
Packit 95306a
   }
Packit 95306a
   $dayofweek = ($$self{'cache'}{'dow_mon'}{$y}{$m}+$d-1) % 7;
Packit 95306a
   $dayofweek = 7  if ($dayofweek==0);
Packit 95306a
   return $dayofweek;
Packit 95306a
}
Packit 95306a
Packit 95306a
# Can be the nth DoW of year or month (if $m given).  Returns undef if
Packit 95306a
# the date doesn't exists (i.e. 5th Sunday in a month with only 4).
Packit 95306a
#
Packit 95306a
sub nth_day_of_week {
Packit 95306a
   my($self,$y,$n,$dow,$m) = @_;
Packit 95306a
   $y += 0;
Packit 95306a
   $m  = ($m ? $m+0 : 0);
Packit 95306a
Packit 95306a
   # $d    is the current DoM (if $m) or DoY
Packit 95306a
   # $max  is the max value allowed for $d
Packit 95306a
   # $ddow is the DoW of $d
Packit 95306a
Packit 95306a
   my($d,$max,$ddow);
Packit 95306a
Packit 95306a
   if ($m) {
Packit 95306a
      $max = $self->days_in_month($y,$m);
Packit 95306a
      $d   = ($n<0 ? $max : 1);
Packit 95306a
      $ddow = $self->day_of_week([$y,$m,$d]);
Packit 95306a
   } else {
Packit 95306a
      $max = $self->days_in_year($y);
Packit 95306a
      $d   = ($n<0 ? $max : 1);
Packit 95306a
      if ($n<0) {
Packit 95306a
         $d = $max;
Packit 95306a
         $ddow = $self->day_of_week([$y,12,31]);
Packit 95306a
      } else {
Packit 95306a
         $d = 1;
Packit 95306a
         $ddow = $self->day_of_week([$y,1,1]);
Packit 95306a
      }
Packit 95306a
   }
Packit 95306a
Packit 95306a
   # Find the first occurrence of $dow on or after $d (if $n>0)
Packit 95306a
   # or the last occurrence of $dow on or before $d (if ($n<0);
Packit 95306a
Packit 95306a
   if ($dow < $ddow) {
Packit 95306a
      $d += 7 - ($ddow-$dow);
Packit 95306a
   } else {
Packit 95306a
      $d += ($dow-$ddow);
Packit 95306a
   }
Packit 95306a
   $d -= 7  if ($d > $max);
Packit 95306a
Packit 95306a
   # Find the nth occurrence of $dow
Packit 95306a
Packit 95306a
   if ($n > 1) {
Packit 95306a
      $d += 7*($n-1);
Packit 95306a
      return undef  if ($d > $max);
Packit 95306a
   } elsif ($n < -1) {
Packit 95306a
      $d -= 7*(-1*$n-1);
Packit 95306a
      return undef  if ($d < 1);
Packit 95306a
   }
Packit 95306a
Packit 95306a
   # Return the date
Packit 95306a
Packit 95306a
   if ($m) {
Packit 95306a
      return [$y,$m,$d];
Packit 95306a
   }
Packit 95306a
   return $self->day_of_year($y,$d);
Packit 95306a
}
Packit 95306a
Packit 95306a
{
Packit 95306a
   # Integer arithmetic doesn't work due to the size of the numbers.
Packit 95306a
   no integer;
Packit 95306a
   # my $sec_70 =($self->days_since_1BC([1970,1,1])-1)*24*3600;
Packit 95306a
   my $sec_70 = 62135596800;
Packit 95306a
Packit 95306a
   # Using 'global' variables saves 4%
Packit 95306a
   my($y,$m,$d,$h,$mn,$s,$sec,$sec_0,$tmp);
Packit 95306a
   sub secs_since_1970 {
Packit 95306a
      my($self,$arg) = @_;
Packit 95306a
Packit 95306a
      if (ref($arg)) {
Packit 95306a
         ($y,$m,$d,$h,$mn,$s) = @$arg;
Packit 95306a
         $sec_0 = ($self->days_since_1BC([$y,$m,$d])-1)*24*3600 + $h*3600 +
Packit 95306a
           $mn*60 + $s;
Packit 95306a
         $sec = $sec_0 - $sec_70;
Packit 95306a
         return $sec;
Packit 95306a
Packit 95306a
      } else {
Packit 95306a
         ($sec)     = $arg;
Packit 95306a
         $sec_0     = $sec_70 + $sec;
Packit 95306a
         $tmp       = int($sec_0/24/3600)+1;
Packit 95306a
         my $ymd    = $self->days_since_1BC($tmp);
Packit 95306a
         ($y,$m,$d) = @$ymd;
Packit 95306a
         $sec_0    -= ($tmp-1)*24*3600;
Packit 95306a
         $h         = int($sec_0/3600);
Packit 95306a
         $sec_0    -= $h*3600;
Packit 95306a
         $mn        = int($sec_0/60);
Packit 95306a
         $s         = $sec_0 - $mn*60;
Packit 95306a
         return [$y,$m,$d,$h,$mn,$s];
Packit 95306a
      }
Packit 95306a
   }
Packit 95306a
}
Packit 95306a
Packit 95306a
sub check {
Packit 95306a
   my($self,$date) = @_;
Packit 95306a
   my($y,$m,$d,$h,$mn,$s) = @$date;
Packit 95306a
Packit 95306a
   return 0  if (! $self->check_time([$h,$mn,$s])  ||
Packit 95306a
                 $y<1  ||  $y>9999  ||
Packit 95306a
                 $m<1  ||  $m>12);
Packit 95306a
Packit 95306a
   my $days = $self->days_in_month($y,$m);
Packit 95306a
Packit 95306a
   return 0  if ($d<1  ||  $d>$days);
Packit 95306a
   return 1;
Packit 95306a
}
Packit 95306a
Packit 95306a
sub check_time {
Packit 95306a
   my($self,$hms) = @_;
Packit 95306a
   my($h,$mn,$s) = @$hms;
Packit 95306a
Packit 95306a
   return 0  if ("$h:$mn:$s" !~ /^\d\d?:\d\d?:\d\d?$/o  ||
Packit 95306a
                 $h > 24  ||  $mn > 59  ||  $s > 59  ||
Packit 95306a
                 ($h == 24  &&  ($mn  ||  $s)));
Packit 95306a
   return 1;
Packit 95306a
}
Packit 95306a
Packit 95306a
sub week1_day1 {
Packit 95306a
   my($self,$year)  = @_;
Packit 95306a
   my $firstday  = $self->_config('firstday');
Packit 95306a
   return $self->_week1_day1($firstday,$year);
Packit 95306a
}
Packit 95306a
Packit 95306a
sub _week1_day1 {
Packit 95306a
   my($self,$firstday,$year) = @_;
Packit 95306a
   my $jan1week1 = $self->_config('jan1week1');
Packit 95306a
   return $$self{'cache'}{'week1day1'}{$firstday}{$jan1week1}{$year}
Packit 95306a
     if (exists $$self{'cache'}{'week1day1'}{$firstday}{$jan1week1}{$year});
Packit 95306a
Packit 95306a
   # First week contains either Jan 4 (default) or Jan 1
Packit 95306a
Packit 95306a
   my($y,$m,$d) = ($year,1,4);
Packit 95306a
   $d           = 1       if ($jan1week1);
Packit 95306a
Packit 95306a
   # Go back to the previous (counting today) $firstday
Packit 95306a
Packit 95306a
   my $dow = $self->day_of_week([$y,$m,$d]);
Packit 95306a
   if ($dow != $firstday) {
Packit 95306a
      $firstday = 0  if ($firstday == 7);
Packit 95306a
      $d -= ($dow-$firstday);
Packit 95306a
      if ($d<1) {
Packit 95306a
         $y--;
Packit 95306a
         $m = 12;
Packit 95306a
         $d += 31;
Packit 95306a
      }
Packit 95306a
   }
Packit 95306a
Packit 95306a
   $$self{'cache'}{'week1day1'}{$firstday}{$jan1week1}{$year} = [ $y,$m,$d ];
Packit 95306a
   return [$y,$m,$d];
Packit 95306a
}
Packit 95306a
Packit 95306a
sub weeks_in_year {
Packit 95306a
   my($self,$y)  = @_;
Packit 95306a
   my $firstday  = $self->_config('firstday');
Packit 95306a
   return $self->_weeks_in_year($firstday,$y);
Packit 95306a
}
Packit 95306a
Packit 95306a
sub _weeks_in_year {
Packit 95306a
   my($self,$firstday,$y) = @_;
Packit 95306a
   my $jan1week1 = $self->_config('jan1week1');
Packit 95306a
   return $$self{'cache'}{'wiy'}{$firstday}{$jan1week1}{$y}
Packit 95306a
     if (exists $$self{'cache'}{'wiy'}{$firstday}{$jan1week1}{$y});
Packit 95306a
Packit 95306a
   # Get the week1 day1 dates for this year and the next one.
Packit 95306a
   my ($y1,$m1,$d1) = @{ $self->_week1_day1($firstday,$y) };
Packit 95306a
   my ($y2,$m2,$d2) = @{ $self->_week1_day1($firstday,$y+1) };
Packit 95306a
Packit 95306a
   # Calculate the number of days between them.
Packit 95306a
   my $diy          = $self->days_in_year($y);
Packit 95306a
   if ($y1 < $y) {
Packit 95306a
      $diy += (32-$d1);
Packit 95306a
   } else {
Packit 95306a
      $diy -= ($d1-1);
Packit 95306a
   }
Packit 95306a
   if ($y2 < $y+1) {
Packit 95306a
      $diy -= (32-$d2);
Packit 95306a
   } else {
Packit 95306a
      $diy += ($d2-1);
Packit 95306a
   }
Packit 95306a
Packit 95306a
   $diy = $diy/7;
Packit 95306a
   $$self{'cache'}{'wiy'}{$firstday}{$jan1week1}{$y} = $diy;
Packit 95306a
   return $diy;
Packit 95306a
}
Packit 95306a
Packit 95306a
sub week_of_year {
Packit 95306a
   my($self,@args) = @_;
Packit 95306a
   my $firstday    = $self->_config('firstday');
Packit 95306a
   return $self->_week_of_year($firstday,@args);
Packit 95306a
}
Packit 95306a
Packit 95306a
sub _week_of_year {
Packit 95306a
   my($self,$firstday,@args) = @_;
Packit 95306a
   my $jan1week1   = $self->_config('jan1week1');
Packit 95306a
Packit 95306a
   if ($#args == 1) {
Packit 95306a
      # (y,m,d) = week_of_year(y,w)
Packit 95306a
      my($year,$w) = @args;
Packit 95306a
Packit 95306a
      return $$self{'cache'}{'woy1'}{$firstday}{$jan1week1}{$year}{$w}
Packit 95306a
        if (exists $$self{'cache'}{'woy1'}{$firstday}{$jan1week1}{$year}{$w});
Packit 95306a
Packit 95306a
      my $ymd = $self->_week1_day1($firstday,$year);
Packit 95306a
      $ymd = $self->calc_date_days($ymd,($w-1)*7)  if ($w > 1);
Packit 95306a
Packit 95306a
      $$self{'cache'}{'woy1'}{$firstday}{$jan1week1}{$year}{$w} = $ymd;
Packit 95306a
      return $ymd;
Packit 95306a
   }
Packit 95306a
Packit 95306a
   # (y,w) = week_of_year([y,m,d])
Packit 95306a
   my($y,$m,$d) = @{ $args[0] };
Packit 95306a
Packit 95306a
   # Get the first day of the first week. If the date is before that,
Packit 95306a
   # it's the last week of last year.
Packit 95306a
Packit 95306a
   my($y0,$m0,$d0) = @{ $self->_week1_day1($firstday,$y) };
Packit 95306a
   if ($y0==$y  &&  $m==1  &&  $d<$d0) {
Packit 95306a
      return($y-1,$self->_weeks_in_year($firstday,$y-1));
Packit 95306a
   }
Packit 95306a
Packit 95306a
   # Otherwise, we'll figure out how many days are between the two and
Packit 95306a
   # divide by 7 to figure out how many weeks in it is.
Packit 95306a
Packit 95306a
   my $n = $self->day_of_year([$y,$m,$d]);
Packit 95306a
   if ($y0<$y) {
Packit 95306a
      $n += (32-$d0);
Packit 95306a
   } else {
Packit 95306a
      $n -= ($d0-1);
Packit 95306a
   }
Packit 95306a
   my $w = 1+int(($n-1)/7);
Packit 95306a
Packit 95306a
   # Make sure we're not into the first week of next year.
Packit 95306a
Packit 95306a
   if ($w>$self->_weeks_in_year($firstday,$y)) {
Packit 95306a
      return($y+1,1);
Packit 95306a
   }
Packit 95306a
   return($y,$w);
Packit 95306a
}
Packit 95306a
Packit 95306a
###############################################################################
Packit 95306a
# CALC METHODS
Packit 95306a
###############################################################################
Packit 95306a
Packit 95306a
sub calc_date_date {
Packit 95306a
   my($self,$date0,$date1) = @_;
Packit 95306a
Packit 95306a
   # Order them so date0 < date1
Packit 95306a
   # If $minus = 1, then the delta is negative
Packit 95306a
Packit 95306a
   my $minus   = 0;
Packit 95306a
   my $cmp     = $self->cmp($date0,$date1);
Packit 95306a
Packit 95306a
   if ($cmp == 0) {
Packit 95306a
      return [0,0,0];
Packit 95306a
Packit 95306a
   } elsif ($cmp == 1) {
Packit 95306a
      $minus  = 1;
Packit 95306a
      my $tmp = $date1;
Packit 95306a
      $date1  = $date0;
Packit 95306a
      $date0  = $tmp;
Packit 95306a
   }
Packit 95306a
Packit 95306a
   my($y0,$m0,$d0,$h0,$mn0,$s0) = @$date0;
Packit 95306a
   my($y1,$m1,$d1,$h1,$mn1,$s1) = @$date1;
Packit 95306a
Packit 95306a
   my $sameday = ($y0 == $y1  &&  $m0 == $m1  &&  $d0 == $d1  ? 1 : 0);
Packit 95306a
Packit 95306a
   # Handle the various cases.
Packit 95306a
Packit 95306a
   my($dh,$dm,$ds);
Packit 95306a
   if ($sameday) {
Packit 95306a
      ($dh,$dm,$ds) = @{ $self->_calc_hms_hms([$h0,$mn0,$s0],[$h1,$mn1,$s1]) };
Packit 95306a
Packit 95306a
   } else {
Packit 95306a
      # y0-m0-d0 h0:mn0:s0 -> y0-m0-d0 24:00:00
Packit 95306a
      # y1-m1-d1 h1:mn1:s1 -> y1-m1-d1 00:00:00
Packit 95306a
Packit 95306a
      my $t1 = $self->_calc_hms_hms([$h0,$mn0,$s0],[24,0,0]);
Packit 95306a
      my $t2 = $self->_calc_hms_hms([0,0,0],[$h1,$mn1,$s1]);
Packit 95306a
      ($dh,$dm,$ds) = @{ $self->calc_time_time($t1,$t2) };
Packit 95306a
Packit 95306a
      my $dd0 = $self->days_since_1BC([$y0,$m0,$d0]);
Packit 95306a
      $dd0++;
Packit 95306a
      my $dd1 = $self->days_since_1BC([$y1,$m1,$d1]);
Packit 95306a
      $dh    += ($dd1-$dd0)*24;
Packit 95306a
   }
Packit 95306a
Packit 95306a
   if ($minus) {
Packit 95306a
      $dh *= -1;
Packit 95306a
      $dm *= -1;
Packit 95306a
      $ds *= -1;
Packit 95306a
   }
Packit 95306a
   return [$dh,$dm,$ds];
Packit 95306a
}
Packit 95306a
Packit 95306a
sub calc_date_days {
Packit 95306a
   my($self,$date,$n,$subtract) = @_;
Packit 95306a
   my($y,$m,$d,$h,$mn,$s)       = @$date;
Packit 95306a
   my($ymdonly)                 = (defined $h ? 0 : 1);
Packit 95306a
Packit 95306a
   $n        *= -1  if ($subtract);
Packit 95306a
   my $d1bc   = $self->days_since_1BC([$y,$m,$d]);
Packit 95306a
   $d1bc     += $n;
Packit 95306a
   my $ymd    = $self->days_since_1BC($d1bc);
Packit 95306a
Packit 95306a
   if ($ymdonly) {
Packit 95306a
      return $ymd;
Packit 95306a
   } else {
Packit 95306a
      return [@$ymd,$h*1,$mn*1,$s*1];
Packit 95306a
   }
Packit 95306a
}
Packit 95306a
Packit 95306a
sub calc_date_delta {
Packit 95306a
   my($self,$date,$delta,$subtract) = @_;
Packit 95306a
   my($y,$m,$d,$h,$mn,$s,$dy,$dm,$dw,$dd,$dh,$dmn,$ds) = (@$date,@$delta);
Packit 95306a
Packit 95306a
   ($y,$m,$d)           = @{ $self->_calc_date_ymwd([$y,$m,$d], [$dy,$dm,$dw,$dd],
Packit 95306a
                                                    $subtract) };
Packit 95306a
   return $self->calc_date_time([$y,$m,$d,$h,$mn,$s],[$dh,$dmn,$ds],$subtract);
Packit 95306a
}
Packit 95306a
Packit 95306a
sub calc_date_time {
Packit 95306a
   my($self,$date,$time,$subtract) = @_;
Packit 95306a
   my($y,$m,$d,$h,$mn,$s,$dh,$dmn,$ds) = (@$date,@$time);
Packit 95306a
Packit 95306a
   if ($ds > 59  ||  $ds < -59) {
Packit 95306a
      $dmn += int($ds/60);
Packit 95306a
      $ds   = $ds % 60;
Packit 95306a
   }
Packit 95306a
   if ($dmn > 59  ||  $dmn < -59) {
Packit 95306a
      $dh  += int($dmn/60);
Packit 95306a
      $dmn  = $dmn % 60;
Packit 95306a
   }
Packit 95306a
   my $dd = 0;
Packit 95306a
   if ($dh > 23  ||  $dh < -23) {
Packit 95306a
      $dd  = int($dh/24);
Packit 95306a
      $dh  = $dh % 24;
Packit 95306a
   }
Packit 95306a
Packit 95306a
   # Handle subtraction
Packit 95306a
   if ($subtract) {
Packit 95306a
      $dh  *= -1;
Packit 95306a
      $dmn *= -1;
Packit 95306a
      $ds  *= -1;
Packit 95306a
      $dd  *= -1;
Packit 95306a
   }
Packit 95306a
Packit 95306a
   if ($dd == 0) {
Packit 95306a
      $y *= 1;
Packit 95306a
      $m *= 1;
Packit 95306a
      $d *= 1;
Packit 95306a
   } else {
Packit 95306a
      ($y,$m,$d) = @{ $self->calc_date_days([$y,$m,$d],$dd) };
Packit 95306a
   }
Packit 95306a
Packit 95306a
   $self->_mod_add(60,$ds,\$s,\$mn);
Packit 95306a
   $self->_mod_add(60,$dmn,\$mn,\$h);
Packit 95306a
   $self->_mod_add(24,$dh,\$h,\$d);
Packit 95306a
Packit 95306a
   if ($d<1) {
Packit 95306a
      $m--;
Packit 95306a
      $y--, $m=12  if ($m<1);
Packit 95306a
      my $day_in_mon = $self->days_in_month($y,$m);
Packit 95306a
      $d += $day_in_mon;
Packit 95306a
   } else {
Packit 95306a
      my $day_in_mon = $self->days_in_month($y,$m);
Packit 95306a
      if ($d>$day_in_mon) {
Packit 95306a
         $d -= $day_in_mon;
Packit 95306a
         $m++;
Packit 95306a
         $y++, $m=1  if ($m>12);
Packit 95306a
      }
Packit 95306a
   }
Packit 95306a
Packit 95306a
   return [$y,$m,$d,$h,$mn,$s];
Packit 95306a
}
Packit 95306a
Packit 95306a
sub _calc_date_time_strings {
Packit 95306a
   my($self,$date,$time,$subtract) = @_;
Packit 95306a
   my @date = @{ $self->split('date',$date) };
Packit 95306a
   return ''  if (! @date);
Packit 95306a
   my @time = @{ $self->split('time',$time) };
Packit 95306a
Packit 95306a
   my @date2 = @{ $self->calc_date_time(\@date,\@time,$subtract) };
Packit 95306a
Packit 95306a
   return $self->join('date',\@date2);
Packit 95306a
}
Packit 95306a
Packit 95306a
sub _calc_date_ymwd {
Packit 95306a
   my($self,$date,$ymwd,$subtract) = @_;
Packit 95306a
   my($y,$m,$d,$h,$mn,$s)          = @$date;
Packit 95306a
   my($dy,$dm,$dw,$dd)             = @$ymwd;
Packit 95306a
   my($ymdonly)                    = (defined $h ? 0 : 1);
Packit 95306a
Packit 95306a
   $dd += $dw*7;
Packit 95306a
Packit 95306a
   if ($subtract) {
Packit 95306a
      $y -= $dy;
Packit 95306a
      $self->_mod_add(-12,-1*$dm,\$m,\$y);
Packit 95306a
      $dd *= -1;
Packit 95306a
Packit 95306a
   } else {
Packit 95306a
      $y += $dy;
Packit 95306a
      $self->_mod_add(-12,$dm,\$m,\$y);
Packit 95306a
   }
Packit 95306a
Packit 95306a
   my $dim = $self->days_in_month($y,$m);
Packit 95306a
   $d      = $dim  if ($d > $dim);
Packit 95306a
Packit 95306a
   my $ymd;
Packit 95306a
   if ($dd == 0) {
Packit 95306a
      $ymd = [$y,$m,$d];
Packit 95306a
   } else {
Packit 95306a
      $ymd = $self->calc_date_days([$y,$m,$d],$dd);
Packit 95306a
   }
Packit 95306a
Packit 95306a
   if ($ymdonly) {
Packit 95306a
      return $ymd;
Packit 95306a
   } else {
Packit 95306a
      return [@$ymd,$h,$mn,$s];
Packit 95306a
   }
Packit 95306a
}
Packit 95306a
Packit 95306a
sub _calc_hms_hms {
Packit 95306a
   my($self,$hms0,$hms1) = @_;
Packit 95306a
   my($h0,$m0,$s0,$h1,$m1,$s1) = (@$hms0,@$hms1);
Packit 95306a
Packit 95306a
   my($s) = ($h1-$h0)*3600 + ($m1-$m0)*60  +  $s1-$s0;
Packit 95306a
   my($m) = int($s/60);
Packit 95306a
   $s    -= $m*60;
Packit 95306a
   my($h) = int($m/60);
Packit 95306a
   $m    -= $h*60;
Packit 95306a
   return [$h,$m,$s];
Packit 95306a
}
Packit 95306a
Packit 95306a
sub calc_time_time {
Packit 95306a
   my($self,$time0,$time1,$subtract) = @_;
Packit 95306a
   my($h0,$m0,$s0,$h1,$m1,$s1)       = (@$time0,@$time1);
Packit 95306a
Packit 95306a
   if ($subtract) {
Packit 95306a
      $h1 *= -1;
Packit 95306a
      $m1 *= -1;
Packit 95306a
      $s1 *= -1;
Packit 95306a
   }
Packit 95306a
   my($s) = (($h0+$h1)*60 + ($m0+$m1))*60 + $s0+$s1;
Packit 95306a
   my($m) = int($s/60);
Packit 95306a
   $s    -= $m*60;
Packit 95306a
   my($h) = int($m/60);
Packit 95306a
   $m    -= $h*60;
Packit 95306a
Packit 95306a
   return [$h,$m,$s];
Packit 95306a
}
Packit 95306a
Packit 95306a
###############################################################################
Packit 95306a
Packit 95306a
# Returns -1 if date0 is before date1, 0 if date0 is the same as date1, and
Packit 95306a
# 1 if date0 is after date1.
Packit 95306a
#
Packit 95306a
sub cmp {
Packit 95306a
   my($self,$date0,$date1) = @_;
Packit 95306a
   return ($$date0[0]  <=> $$date1[0]  ||
Packit 95306a
           $$date0[1]  <=> $$date1[1]  ||
Packit 95306a
           $$date0[2]  <=> $$date1[2]  ||
Packit 95306a
           $$date0[3]  <=> $$date1[3]  ||
Packit 95306a
           $$date0[4]  <=> $$date1[4]  ||
Packit 95306a
           $$date0[5]  <=> $$date1[5]);
Packit 95306a
}
Packit 95306a
Packit 95306a
###############################################################################
Packit 95306a
# This determines the OS.
Packit 95306a
Packit 95306a
sub _os {
Packit 95306a
   my($self) = @_;
Packit 95306a
Packit 95306a
   my $os = '';
Packit 95306a
Packit 95306a
   if ($^O =~ /MSWin32/io    ||
Packit 95306a
       $^O =~ /Windows_95/io ||
Packit 95306a
       $^O =~ /Windows_NT/io
Packit 95306a
      ) {
Packit 95306a
      $os = 'Windows';
Packit 95306a
Packit 95306a
   } elsif ($^O =~ /MacOS/io  ||
Packit 95306a
            $^O =~ /MPE/io    ||
Packit 95306a
            $^O =~ /OS2/io    ||
Packit 95306a
            $^O =~ /NetWare/io
Packit 95306a
           ) {
Packit 95306a
      $os = 'Other';
Packit 95306a
Packit 95306a
   } elsif ($^O =~ /VMS/io) {
Packit 95306a
      $os = 'VMS';
Packit 95306a
Packit 95306a
   } else {
Packit 95306a
      $os = 'Unix';
Packit 95306a
   }
Packit 95306a
Packit 95306a
   return $os;
Packit 95306a
}
Packit 95306a
Packit 95306a
###############################################################################
Packit 95306a
# Config variable functions
Packit 95306a
Packit 95306a
# $self->config(SECT);
Packit 95306a
#    Creates a new section (if it doesn't already exist).
Packit 95306a
#
Packit 95306a
# $self->config(SECT,'_vars');
Packit 95306a
#    Returns a list of (VAR VAL VAR VAL ...)
Packit 95306a
#
Packit 95306a
# $self->config(SECT,VAR,VAL);
Packit 95306a
#    Adds (VAR,VAL) to the list.
Packit 95306a
#
Packit 95306a
sub _section {
Packit 95306a
   my($self,$sect,$var,$val) = @_;
Packit 95306a
   $sect = lc($sect);
Packit 95306a
Packit 95306a
   #
Packit 95306a
   # $self->_section(SECT)    creates a new section
Packit 95306a
   #
Packit 95306a
Packit 95306a
   if (! defined $var  &&
Packit 95306a
       ! exists $$self{'data'}{'sections'}{$sect}) {
Packit 95306a
      if ($sect eq 'conf') {
Packit 95306a
         $$self{'data'}{'sections'}{$sect} = {};
Packit 95306a
      } else {
Packit 95306a
         $$self{'data'}{'sections'}{$sect} = [];
Packit 95306a
      }
Packit 95306a
      return '';
Packit 95306a
   }
Packit 95306a
Packit 95306a
   if ($var eq '_vars') {
Packit 95306a
      return @{ $$self{'data'}{'sections'}{$sect} };
Packit 95306a
   }
Packit 95306a
Packit 95306a
   push @{ $$self{'data'}{'sections'}{$sect} },($var,$val);
Packit 95306a
   return;
Packit 95306a
}
Packit 95306a
Packit 95306a
# This sets a config variable. It also performs all side effects from
Packit 95306a
# setting that variable.
Packit 95306a
#
Packit 95306a
sub _config_var_base {
Packit 95306a
   my($self,$var,$val) = @_;
Packit 95306a
Packit 95306a
   if ($var eq 'defaults') {
Packit 95306a
      # Reset the configuration if desired.
Packit 95306a
      $self->_init_config(1);
Packit 95306a
      return;
Packit 95306a
Packit 95306a
   } elsif ($var eq 'eraseholidays') {
Packit 95306a
      $self->_init_holidays(1);
Packit 95306a
      return;
Packit 95306a
Packit 95306a
   } elsif ($var eq 'eraseevents') {
Packit 95306a
      $self->_init_events(1);
Packit 95306a
      return;
Packit 95306a
Packit 95306a
   } elsif ($var eq 'configfile') {
Packit 95306a
      $self->_config_file($val);
Packit 95306a
      return;
Packit 95306a
Packit 95306a
   } elsif ($var eq 'encoding') {
Packit 95306a
      my $err = $self->_config_var_encoding($val);
Packit 95306a
      return if ($err);
Packit 95306a
Packit 95306a
   } elsif ($var eq 'language') {
Packit 95306a
      my $err = $self->_language($val);
Packit 95306a
      return  if ($err);
Packit 95306a
      $err    = $self->_config_var_encoding();
Packit 95306a
      return  if ($err);
Packit 95306a
Packit 95306a
   } elsif ($var eq 'yytoyyyy') {
Packit 95306a
      $val = lc($val);
Packit 95306a
      if ($val ne 'c'  &&
Packit 95306a
          $val !~ /^c\d\d$/o  &&
Packit 95306a
          $val !~ /^c\d\d\d\d$/o  &&
Packit 95306a
          $val !~ /^\d+$/o) {
Packit 95306a
         warn "ERROR: [config_var] invalid: YYtoYYYY: $val\n";
Packit 95306a
         return;
Packit 95306a
      }
Packit 95306a
Packit 95306a
   } elsif ($var eq 'workweekbeg') {
Packit 95306a
      my $err = $self->_config_var_workweekbeg($val);
Packit 95306a
      return  if ($err);
Packit 95306a
Packit 95306a
   } elsif ($var eq 'workweekend') {
Packit 95306a
      my $err = $self->_config_var_workweekend($val);
Packit 95306a
      return  if ($err);
Packit 95306a
Packit 95306a
   } elsif ($var eq 'workday24hr') {
Packit 95306a
      my $err = $self->_config_var_workday24hr($val);
Packit 95306a
      return  if ($err);
Packit 95306a
Packit 95306a
   } elsif ($var eq 'workdaybeg') {
Packit 95306a
      my $err = $self->_config_var_workdaybegend(\$val,'WorkDayBeg');
Packit 95306a
      return  if ($err);
Packit 95306a
Packit 95306a
   } elsif ($var eq 'workdayend') {
Packit 95306a
      my $err = $self->_config_var_workdaybegend(\$val,'WorkDayEnd');
Packit 95306a
      return  if ($err);
Packit 95306a
Packit 95306a
   } elsif ($var eq 'firstday') {
Packit 95306a
      my $err = $self->_config_var_firstday($val);
Packit 95306a
      return  if ($err);
Packit 95306a
Packit 95306a
   } elsif ($var eq 'tz'  ||
Packit 95306a
            $var eq 'forcedate'  ||
Packit 95306a
            $var eq 'setdate') {
Packit 95306a
      # These can only be used if the Date::Manip::TZ module has been loaded
Packit 95306a
      warn "ERROR: [config_var] $var config variable requires TZ module\n";
Packit 95306a
      return;
Packit 95306a
Packit 95306a
   } elsif ($var eq 'recurrange') {
Packit 95306a
      my $err = $self->_config_var_recurrange($val);
Packit 95306a
      return  if ($err);
Packit 95306a
Packit 95306a
   } elsif ($var eq 'defaulttime') {
Packit 95306a
      my $err = $self->_config_var_defaulttime($val);
Packit 95306a
      return  if ($err);
Packit 95306a
Packit 95306a
   } elsif ($var eq 'periodtimesep') {
Packit 95306a
      # We have to redo the time regexp
Packit 95306a
      delete $$self{'data'}{'rx'}{'time'};
Packit 95306a
Packit 95306a
   } elsif ($var eq 'format_mmmyyyy') {
Packit 95306a
      my $err = $self->_config_var_format_mmmyyyy($val);
Packit 95306a
      return  if ($err);
Packit 95306a
Packit 95306a
   } elsif ($var eq 'dateformat'    ||
Packit 95306a
            $var eq 'jan1week1'     ||
Packit 95306a
            $var eq 'printable'     ||
Packit 95306a
            $var eq 'tomorrowfirst') {
Packit 95306a
      # do nothing
Packit 95306a
Packit 95306a
   } else {
Packit 95306a
      warn "ERROR: [config_var] invalid config variable: $var\n";
Packit 95306a
      return '';
Packit 95306a
   }
Packit 95306a
Packit 95306a
   $$self{'data'}{'sections'}{'conf'}{$var} = $val;
Packit 95306a
   return;
Packit 95306a
}
Packit 95306a
Packit 95306a
###############################################################################
Packit 95306a
# Specific config variable functions
Packit 95306a
Packit 95306a
sub _config_var_encoding {
Packit 95306a
   my($self,$val) = @_;
Packit 95306a
Packit 95306a
   if (! $val) {
Packit 95306a
      $$self{'data'}{'calc'}{'enc_in'}  = [ @{ $$self{'data'}{'enc'} } ];
Packit 95306a
      $$self{'data'}{'calc'}{'enc_out'} = 'UTF-8';
Packit 95306a
Packit 95306a
   } elsif ($val =~ /^(.*),(.*)$/o) {
Packit 95306a
      my($in,$out) = ($1,$2);
Packit 95306a
      if ($in) {
Packit 95306a
         my $o = find_encoding($in);
Packit 95306a
         if (! $o) {
Packit 95306a
            warn "ERROR: [config_var] invalid: Encoding: $in\n";
Packit 95306a
            return 1;
Packit 95306a
         }
Packit 95306a
      }
Packit 95306a
      if ($out) {
Packit 95306a
         my $o = find_encoding($out);
Packit 95306a
         if (! $o) {
Packit 95306a
            warn "ERROR: [config_var] invalid: Encoding: $out\n";
Packit 95306a
            return 1;
Packit 95306a
         }
Packit 95306a
      }
Packit 95306a
Packit 95306a
      if ($in  &&  $out) {
Packit 95306a
         $$self{'data'}{'calc'}{'enc_in'}  = [ $in ];
Packit 95306a
         $$self{'data'}{'calc'}{'enc_out'} = $out;
Packit 95306a
Packit 95306a
      } elsif ($in) {
Packit 95306a
         $$self{'data'}{'calc'}{'enc_in'}  = [ $in ];
Packit 95306a
         $$self{'data'}{'calc'}{'enc_out'} = 'UTF-8';
Packit 95306a
Packit 95306a
      } elsif ($out) {
Packit 95306a
         $$self{'data'}{'calc'}{'enc_in'}  = [ @{ $$self{'data'}{'enc'} } ];
Packit 95306a
         $$self{'data'}{'calc'}{'enc_out'} = $out;
Packit 95306a
Packit 95306a
      } else {
Packit 95306a
         $$self{'data'}{'calc'}{'enc_in'}  = [ @{ $$self{'data'}{'enc'} } ];
Packit 95306a
         $$self{'data'}{'calc'}{'enc_out'} = 'UTF-8';
Packit 95306a
      }
Packit 95306a
Packit 95306a
   } else {
Packit 95306a
      my $o = find_encoding($val);
Packit 95306a
      if (! $o) {
Packit 95306a
         warn "ERROR: [config_var] invalid: Encoding: $val\n";
Packit 95306a
         return 1;
Packit 95306a
      }
Packit 95306a
      $$self{'data'}{'calc'}{'enc_in'}  = [ $val ];
Packit 95306a
      $$self{'data'}{'calc'}{'enc_out'} = $val;
Packit 95306a
   }
Packit 95306a
Packit 95306a
   if (! @{ $$self{'data'}{'calc'}{'enc_in'} }) {
Packit 95306a
      $$self{'data'}{'calc'}{'enc_in'}  = [ qw(utf-8 perl) ];
Packit 95306a
   }
Packit 95306a
Packit 95306a
   return 0;
Packit 95306a
}
Packit 95306a
Packit 95306a
sub _config_var_recurrange {
Packit 95306a
   my($self,$val) = @_;
Packit 95306a
Packit 95306a
   $val = lc($val);
Packit 95306a
   if ($val =~ /^(none|year|month|week|day|all)$/o) {
Packit 95306a
      return 0;
Packit 95306a
   }
Packit 95306a
Packit 95306a
   warn "ERROR: [config_var] invalid: RecurRange: $val\n";
Packit 95306a
   return 1;
Packit 95306a
}
Packit 95306a
Packit 95306a
sub _config_var_workweekbeg {
Packit 95306a
   my($self,$val) = @_;
Packit 95306a
Packit 95306a
   if (! $self->_is_int($val,1,7)) {
Packit 95306a
      warn "ERROR: [config_var] invalid: WorkWeekBeg: $val\n";
Packit 95306a
      return 1;
Packit 95306a
   }
Packit 95306a
   if ($val >= $self->_config('workweekend')) {
Packit 95306a
      warn "ERROR: [config_var] WorkWeekBeg must be before WorkWeekEnd\n";
Packit 95306a
      return 1;
Packit 95306a
   }
Packit 95306a
Packit 95306a
   $self->_calc_workweek($val,'');
Packit 95306a
   $self->_init_business_length();
Packit 95306a
   return 0;
Packit 95306a
}
Packit 95306a
Packit 95306a
sub _config_var_workweekend {
Packit 95306a
   my($self,$val) = @_;
Packit 95306a
Packit 95306a
   if (! $self->_is_int($val,1,7)) {
Packit 95306a
      warn "ERROR: [config_var] invalid: WorkWeekBeg: $val\n";
Packit 95306a
      return 1;
Packit 95306a
   }
Packit 95306a
   if ($val <= $self->_config('workweekbeg')) {
Packit 95306a
      warn "ERROR: [config_var] WorkWeekEnd must be after WorkWeekBeg\n";
Packit 95306a
      return 1;
Packit 95306a
   }
Packit 95306a
Packit 95306a
   $self->_calc_workweek('',$val);
Packit 95306a
   $self->_init_business_length();
Packit 95306a
   return 0;
Packit 95306a
}
Packit 95306a
Packit 95306a
sub _config_var_workday24hr {
Packit 95306a
   my($self,$val) = @_;
Packit 95306a
Packit 95306a
   if ($val) {
Packit 95306a
      $$self{'data'}{'sections'}{'conf'}{'workdaybeg'} = '00:00:00';
Packit 95306a
      $$self{'data'}{'sections'}{'conf'}{'workdayend'} = '24:00:00';
Packit 95306a
      $$self{'data'}{'calc'}{'workdaybeg'}             = [0,0,0];
Packit 95306a
      $$self{'data'}{'calc'}{'workdayend'}             = [24,0,0];
Packit 95306a
Packit 95306a
      $self->_calc_bdlength();
Packit 95306a
      $self->_init_business_length();
Packit 95306a
   }
Packit 95306a
Packit 95306a
   return 0;
Packit 95306a
}
Packit 95306a
Packit 95306a
sub _config_var_workdaybegend {
Packit 95306a
   my($self,$val,$conf) = @_;
Packit 95306a
Packit 95306a
   # Must be a valid time.  Entered as H, H:M, or H:M:S
Packit 95306a
Packit 95306a
   my $tmp = $self->split('hms',$$val);
Packit 95306a
   if (! defined $tmp) {
Packit 95306a
      warn "ERROR: [config_var] invalid: $conf: $$val\n";
Packit 95306a
      return 1;
Packit 95306a
   }
Packit 95306a
   $$self{'data'}{'calc'}{lc($conf)} = $tmp;
Packit 95306a
   $$val = $self->join('hms',$tmp);
Packit 95306a
Packit 95306a
   # workdaybeg < workdayend
Packit 95306a
Packit 95306a
   my @beg = @{ $$self{'data'}{'calc'}{'workdaybeg'} };
Packit 95306a
   my @end = @{ $$self{'data'}{'calc'}{'workdayend'} };
Packit 95306a
   my $beg = $beg[0]*3600 + $beg[1]*60 + $beg[2];
Packit 95306a
   my $end = $end[0]*3600 + $end[1]*60 + $end[2];
Packit 95306a
Packit 95306a
   if ($beg > $end) {
Packit 95306a
      warn "ERROR: [config_var] WorkDayBeg not before WorkDayEnd\n";
Packit 95306a
      return 1;
Packit 95306a
   }
Packit 95306a
Packit 95306a
   # Calculate bdlength
Packit 95306a
Packit 95306a
   $$self{'data'}{'sections'}{'conf'}{'workday24hr'} = 0;
Packit 95306a
Packit 95306a
   $self->_calc_bdlength();
Packit 95306a
   $self->_init_business_length();
Packit 95306a
Packit 95306a
   return 0;
Packit 95306a
}
Packit 95306a
Packit 95306a
sub _config_var_firstday {
Packit 95306a
   my($self,$val) = @_;
Packit 95306a
Packit 95306a
   if (! $self->_is_int($val,1,7)) {
Packit 95306a
      warn "ERROR: [config_var] invalid: FirstDay: $val\n";
Packit 95306a
      return 1;
Packit 95306a
   }
Packit 95306a
Packit 95306a
   return 0;
Packit 95306a
}
Packit 95306a
Packit 95306a
sub _config_var_defaulttime {
Packit 95306a
   my($self,$val) = @_;
Packit 95306a
Packit 95306a
   if (lc($val) eq 'midnight'  ||
Packit 95306a
       lc($val) eq 'curr') {
Packit 95306a
      return 0;
Packit 95306a
   }
Packit 95306a
   warn "ERROR: [config_var] invalid: DefaultTime: $val\n";
Packit 95306a
   return 1;
Packit 95306a
}
Packit 95306a
Packit 95306a
sub _config_var_format_mmmyyyy {
Packit 95306a
   my($self,$val) = @_;
Packit 95306a
Packit 95306a
   if (lc($val) eq 'first'  ||
Packit 95306a
       lc($val) eq 'last'   ||
Packit 95306a
       lc($val) eq '') {
Packit 95306a
      return 0;
Packit 95306a
   }
Packit 95306a
   warn "ERROR: [config_var] invalid: Format_MMMYYYY: $val\n";
Packit 95306a
   return 1;
Packit 95306a
}
Packit 95306a
Packit 95306a
###############################################################################
Packit 95306a
# Language functions
Packit 95306a
Packit 95306a
# This reads in a langauge module and sets regular expressions
Packit 95306a
# and word lists based on it.
Packit 95306a
#
Packit 95306a
no strict 'refs';
Packit 95306a
sub _language {
Packit 95306a
   my($self,$lang) = @_;
Packit 95306a
   $lang = lc($lang);
Packit 95306a
Packit 95306a
   if (! exists $Date::Manip::Lang::index::Lang{$lang}) {
Packit 95306a
      warn "ERROR: [language] invalid: $lang\n";
Packit 95306a
      return 1;
Packit 95306a
   }
Packit 95306a
Packit 95306a
   return 0  if (exists $$self{'data'}{'sections'}{'conf'}  &&
Packit 95306a
                 $$self{'data'}{'sections'}{'conf'} eq $lang);
Packit 95306a
   $self->_init_language(1);
Packit 95306a
Packit 95306a
   my $mod = $Date::Manip::Lang::index::Lang{$lang};
Packit 95306a
   eval "require Date::Manip::Lang::${mod}";
Packit 95306a
   if ($@) {
Packit 95306a
      die "ERROR: failed to load Date::Manip::Lang::${mod}: $@\n";
Packit 95306a
   }
Packit 95306a
Packit 95306a
   no warnings 'once';
Packit 95306a
   $$self{'data'}{'lang'} = ${ "Date::Manip::Lang::${mod}::Language" };
Packit 95306a
   $$self{'data'}{'enc'}  = [ @{ "Date::Manip::Lang::${mod}::Encodings" } ];
Packit 95306a
Packit 95306a
   # Common words
Packit 95306a
   $self->_rx_wordlist('at');
Packit 95306a
   $self->_rx_wordlist('each');
Packit 95306a
   $self->_rx_wordlist('last');
Packit 95306a
   $self->_rx_wordlist('of');
Packit 95306a
   $self->_rx_wordlist('on');
Packit 95306a
   $self->_rx_wordlists('when');
Packit 95306a
Packit 95306a
   # Next/prev
Packit 95306a
   $self->_rx_wordlists('nextprev');
Packit 95306a
Packit 95306a
   # Field names (years, year, yr, ...)
Packit 95306a
   $self->_rx_wordlists('fields');
Packit 95306a
Packit 95306a
   # Numbers (first, 1st)
Packit 95306a
   $self->_rx_wordlists('nth');
Packit 95306a
   $self->_rx_wordlists('nth','nth_dom',31);  # 1-31
Packit 95306a
   $self->_rx_wordlists('nth','nth_wom',5);   # 1-5
Packit 95306a
Packit 95306a
   # Calendar names (Mon, Tue  and  Jan, Feb)
Packit 95306a
   $self->_rx_wordlists('day_abb');
Packit 95306a
   $self->_rx_wordlists('day_char');
Packit 95306a
   $self->_rx_wordlists('day_name');
Packit 95306a
   $self->_rx_wordlists('month_abb');
Packit 95306a
   $self->_rx_wordlists('month_name');
Packit 95306a
Packit 95306a
   # H:M:S separators
Packit 95306a
   $self->_rx_simple('sephm');
Packit 95306a
   $self->_rx_simple('sepms');
Packit 95306a
   $self->_rx_simple('sepfr');
Packit 95306a
Packit 95306a
   # Time replacement strings
Packit 95306a
   $self->_rx_replace('times');
Packit 95306a
Packit 95306a
   # Some offset strings
Packit 95306a
   $self->_rx_replace('offset_date');
Packit 95306a
   $self->_rx_replace('offset_time');
Packit 95306a
Packit 95306a
   # AM/PM strings
Packit 95306a
   $self->_rx_wordlists('ampm');
Packit 95306a
Packit 95306a
   # Business/non-business mode
Packit 95306a
   $self->_rx_wordlists('mode');
Packit 95306a
Packit 95306a
   return 0;
Packit 95306a
}
Packit 95306a
use strict 'refs';
Packit 95306a
Packit 95306a
# This takes a string or strings from the language file which is a
Packit 95306a
# regular expression and copies it to the regular expression cache.
Packit 95306a
#
Packit 95306a
# If the language file contains a list of strings, a list of strings
Packit 95306a
# is stored in the regexp cache.
Packit 95306a
#
Packit 95306a
sub _rx_simple {
Packit 95306a
   my($self,$ele) = @_;
Packit 95306a
Packit 95306a
   if (exists $$self{'data'}{'lang'}{$ele}) {
Packit 95306a
      if (ref($$self{'data'}{'lang'}{$ele})) {
Packit 95306a
         @{ $$self{'data'}{'rx'}{$ele} } = @{ $$self{'data'}{'lang'}{$ele} };
Packit 95306a
      } else {
Packit 95306a
         $$self{'data'}{'rx'}{$ele} = $$self{'data'}{'lang'}{$ele};
Packit 95306a
      }
Packit 95306a
   } else {
Packit 95306a
      $$self{'data'}{'rx'}{$ele} = undef;
Packit 95306a
   }
Packit 95306a
Packit 95306a
   return;
Packit 95306a
}
Packit 95306a
Packit 95306a
# We need to quote strings that will be used in regexps, but we don't
Packit 95306a
# want to quote UTF-8 characters.
Packit 95306a
#
Packit 95306a
sub _qe_quote {
Packit 95306a
   my($string) = @_;
Packit 95306a
   $string     =~ s/([-.+*?])/\\$1/g;
Packit 95306a
   return $string;
Packit 95306a
}
Packit 95306a
Packit 95306a
# This takes a list of words and creates a simple regexp which matches
Packit 95306a
# any of them.
Packit 95306a
#
Packit 95306a
# The first word in the list is the default way to express the word using
Packit 95306a
# a normal ASCII character set.
Packit 95306a
#
Packit 95306a
# The second word in the list is the default way to express the word using
Packit 95306a
# a locale character set. If it isn't defined, it defaults to the first word.
Packit 95306a
#
Packit 95306a
sub _rx_wordlist {
Packit 95306a
   my($self,$ele) = @_;
Packit 95306a
Packit 95306a
   if (exists $$self{'data'}{'lang'}{$ele}) {
Packit 95306a
      my @tmp = @{ $$self{'data'}{'lang'}{$ele} };
Packit 95306a
Packit 95306a
      $$self{'data'}{'wordlist'}{$ele} = $tmp[0];
Packit 95306a
Packit 95306a
      my @tmp2;
Packit 95306a
      foreach my $tmp (@tmp) {
Packit 95306a
         push(@tmp2,_qe_quote($tmp))  if ($tmp);
Packit 95306a
      }
Packit 95306a
      @tmp2  = sort _sortByLength(@tmp2);
Packit 95306a
Packit 95306a
      $$self{'data'}{'rx'}{$ele} = join('|',@tmp2);
Packit 95306a
Packit 95306a
   } else {
Packit 95306a
      $$self{'data'}{'rx'}{$ele} = undef;
Packit 95306a
   }
Packit 95306a
Packit 95306a
   return;
Packit 95306a
}
Packit 95306a
Packit 95306a
no strict 'vars';
Packit 95306a
sub _sortByLength {
Packit 95306a
   return (length $b <=> length $a);
Packit 95306a
}
Packit 95306a
use strict 'vars';
Packit 95306a
Packit 95306a
# This takes a hash of the form:
Packit 95306a
#    word => string
Packit 95306a
# and creates a regular expression to match word (which must be surrounded
Packit 95306a
# by word boundaries).
Packit 95306a
#
Packit 95306a
sub _rx_replace {
Packit 95306a
   my($self,$ele) = @_;
Packit 95306a
Packit 95306a
   if (! exists $$self{'data'}{'lang'}{$ele}) {
Packit 95306a
      $$self{'data'}{'rx'}{$ele} = [];
Packit 95306a
      return;
Packit 95306a
   }
Packit 95306a
Packit 95306a
   my(@key) = keys %{ $$self{'data'}{'lang'}{$ele} };
Packit 95306a
   my $i    = 1;
Packit 95306a
   foreach my $key (sort(@key)) {
Packit 95306a
      my $val = $$self{'data'}{'lang'}{$ele}{$key};
Packit 95306a
      my $k   = _qe_quote($key);
Packit 95306a
      $$self{'data'}{'rx'}{$ele}[$i++] = qr/(?:^|\b)($k)(?:\b|$)/i;
Packit 95306a
      $$self{'data'}{'wordmatch'}{$ele}{lc($key)} = $val;
Packit 95306a
   }
Packit 95306a
Packit 95306a
   @key   = sort _sortByLength(@key);
Packit 95306a
   @key   = map { _qe_quote($_) } @key;
Packit 95306a
   my $rx = join('|',@key);
Packit 95306a
Packit 95306a
   $$self{'data'}{'rx'}{$ele}[0] = qr/(?:^|\b)(?:$rx)(?:\b|$)/i;
Packit 95306a
Packit 95306a
   return;
Packit 95306a
}
Packit 95306a
Packit 95306a
# This takes a list of values, each of which can be expressed in multiple
Packit 95306a
# ways, and gets a regular expression which matches any of them, a default
Packit 95306a
# way to express each value, and a hash which matches a matched string to
Packit 95306a
# a value (the value is 1..N where N is the number of values).
Packit 95306a
#
Packit 95306a
sub _rx_wordlists {
Packit 95306a
   my($self,$ele,$subset,$max) = @_;
Packit 95306a
   $subset = $ele  if (! $subset);
Packit 95306a
Packit 95306a
   if (exists $$self{'data'}{'lang'}{$ele}) {
Packit 95306a
      my @vallist = @{ $$self{'data'}{'lang'}{$ele} };
Packit 95306a
      $max        = $#vallist+1  if (! $max  ||  $max > $#vallist+1);
Packit 95306a
      my (@all);
Packit 95306a
Packit 95306a
      for (my $i=1; $i<=$max; $i++) {
Packit 95306a
         my @tmp = @{ $$self{'data'}{'lang'}{$ele}[$i-1] };
Packit 95306a
         $$self{'data'}{'wordlist'}{$subset}[$i-1] = $tmp[0];
Packit 95306a
Packit 95306a
         my @str;
Packit 95306a
         foreach my $str (@tmp) {
Packit 95306a
            next  if (! $str);
Packit 95306a
            $$self{'data'}{'wordmatch'}{$subset}{lc($str)} = $i;
Packit 95306a
            push(@str,_qe_quote($str));
Packit 95306a
         }
Packit 95306a
         push(@all,@str);
Packit 95306a
Packit 95306a
         @str  = sort _sortByLength(@str);
Packit 95306a
         $$self{'data'}{'rx'}{$subset}[$i] = join('|',@str);
Packit 95306a
      }
Packit 95306a
Packit 95306a
      @all  = sort _sortByLength(@all);
Packit 95306a
      $$self{'data'}{'rx'}{$subset}[0] = join('|',@all);
Packit 95306a
Packit 95306a
   } else {
Packit 95306a
      $$self{'data'}{'rx'}{$subset} = undef;
Packit 95306a
   }
Packit 95306a
Packit 95306a
   return;
Packit 95306a
}
Packit 95306a
Packit 95306a
###############################################################################
Packit 95306a
# Year functions
Packit 95306a
#
Packit 95306a
# $self->_method(METHOD)      use METHOD as the method for YY->YYYY
Packit 95306a
#                             conversions
Packit 95306a
#
Packit 95306a
# YEAR = _fix_year(YR)        converts a 2-digit to 4-digit year
Packit 95306a
#                             _fix_year is in TZ_Base
Packit 95306a
Packit 95306a
sub _method {
Packit 95306a
   my($self,$method) = @_;
Packit 95306a
   $self->_config('yytoyyyy',$method);
Packit 95306a
Packit 95306a
   return;
Packit 95306a
}
Packit 95306a
Packit 95306a
###############################################################################
Packit 95306a
# $self->_mod_add($N,$add,\$val,\$rem);
Packit 95306a
#   This calculates $val=$val+$add and forces $val to be in a certain
Packit 95306a
#   range.  This is useful for adding numbers for which only a certain
Packit 95306a
#   range is allowed (for example, minutes can be between 0 and 59 or
Packit 95306a
#   months can be between 1 and 12).  The absolute value of $N determines
Packit 95306a
#   the range and the sign of $N determines whether the range is 0 to N-1
Packit 95306a
#   (if N>0) or 1 to N (N<0).  $rem is adjusted to force $val into the
Packit 95306a
#   appropriate range.
Packit 95306a
#   Example:
Packit 95306a
#     To add 2 hours together (with the excess returned in days) use:
Packit 95306a
#       $self->_mod_add(-24,$h1,\$h,\$day);
Packit 95306a
#     To add 2 minutes together (with the excess returned in hours):
Packit 95306a
#       $self->_mod_add(60,$mn1,\$mn,\$hr);
Packit 95306a
sub _mod_add {
Packit 95306a
   my($self,$N,$add,$val,$rem)=@_;
Packit 95306a
   return  if ($N==0);
Packit 95306a
   $$val+=$add;
Packit 95306a
   if ($N<0) {
Packit 95306a
      # 1 to N
Packit 95306a
      $N = -$N;
Packit 95306a
      if ($$val>$N) {
Packit 95306a
         $$rem+= int(($$val-1)/$N);
Packit 95306a
         $$val = ($$val-1)%$N +1;
Packit 95306a
      } elsif ($$val<1) {
Packit 95306a
         $$rem-= int(-$$val/$N)+1;
Packit 95306a
         $$val = $N-(-$$val % $N);
Packit 95306a
      }
Packit 95306a
Packit 95306a
   } else {
Packit 95306a
      # 0 to N-1
Packit 95306a
      if ($$val>($N-1)) {
Packit 95306a
         $$rem+= int($$val/$N);
Packit 95306a
         $$val = $$val%$N;
Packit 95306a
      } elsif ($$val<0) {
Packit 95306a
         $$rem-= int(-($$val+1)/$N)+1;
Packit 95306a
         $$val = ($N-1)-(-($$val+1)%$N);
Packit 95306a
      }
Packit 95306a
   }
Packit 95306a
Packit 95306a
   return;
Packit 95306a
}
Packit 95306a
Packit 95306a
# $flag = $self->_is_int($string [,$low, $high]);
Packit 95306a
#    Returns 1 if $string is a valid integer, 0 otherwise.  If $low is
Packit 95306a
#    entered, $string must be >= $low.  If $high is entered, $string must
Packit 95306a
#    be <= $high.  It is valid to check only one of the bounds.
Packit 95306a
sub _is_int {
Packit 95306a
   my($self,$N,$low,$high)=@_;
Packit 95306a
   return 0  if (! defined $N  or
Packit 95306a
                 $N !~ /^\s*[-+]?\d+\s*$/o  or
Packit 95306a
                 defined $low   &&  $N<$low  or
Packit 95306a
                 defined $high  &&  $N>$high);
Packit 95306a
   return 1;
Packit 95306a
}
Packit 95306a
Packit 95306a
###############################################################################
Packit 95306a
# Split/Join functions
Packit 95306a
Packit 95306a
sub split {
Packit 95306a
   my($self,$op,$string,$no_normalize) = @_;
Packit 95306a
   $no_normalize = 0  if (! $no_normalize);
Packit 95306a
Packit 95306a
   if ($op eq 'date') {
Packit 95306a
Packit 95306a
      if ($string =~ /^(\d\d\d\d)(\d\d)(\d\d)(\d\d):(\d\d):(\d\d)$/o  ||
Packit 95306a
          $string =~ /^(\d\d\d\d)\-(\d\d)\-(\d\d)\-(\d\d):(\d\d):(\d\d)$/o  ||
Packit 95306a
          $string =~ /^(\d\d\d\d)(\d\d)(\d\d)(\d\d)(\d\d)(\d\d)$/o) {
Packit 95306a
         my($y,$m,$d,$h,$mn,$s) = ($1+0,$2+0,$3+0,$4+0,$5+0,$6+0);
Packit 95306a
         return [$y,$m,$d,$h,$mn,$s];
Packit 95306a
      } else {
Packit 95306a
         return undef;
Packit 95306a
      }
Packit 95306a
Packit 95306a
   } elsif ($op eq 'offset') {
Packit 95306a
      if ($string =~ /^([-+]?\d\d)(\d\d)(\d\d)$/o       ||
Packit 95306a
          $string =~ /^([-+]?\d\d)(\d\d)()$/o           ||
Packit 95306a
          $string =~ /^([-+]?\d\d?):(\d\d?):(\d\d?)$/o  ||
Packit 95306a
          $string =~ /^([-+]?\d\d?):(\d\d?)()$/o        ||
Packit 95306a
          $string =~ /^([-+]?\d\d?)()()$/o) {
Packit 95306a
         my($err,$h,$mn,$s) = $self->_offset_fields( { 'source' => 'string',
Packit 95306a
                                                       'out'    => 'list'},
Packit 95306a
                                                     [$1,$2,$3]);
Packit 95306a
         return undef  if ($err);
Packit 95306a
         return [$h,$mn,$s];
Packit 95306a
      } else {
Packit 95306a
         return undef;
Packit 95306a
      }
Packit 95306a
Packit 95306a
   } elsif ($op eq 'hms') {
Packit 95306a
      if ($string =~ /^(\d\d)(\d\d)(\d\d)$/o     ||
Packit 95306a
          $string =~ /^(\d\d)(\d\d)()$/o         ||
Packit 95306a
          $string =~ /^(\d\d?):(\d\d):(\d\d)$/o  ||
Packit 95306a
          $string =~ /^(\d\d?):(\d\d)()$/o       ||
Packit 95306a
          $string =~ /^(\d\d?)()()$/o) {
Packit 95306a
         my($err,$h,$mn,$s) = $self->_hms_fields( { 'out' => 'list' },[$1,$2,$3]);
Packit 95306a
         return undef  if ($err);
Packit 95306a
         return [$h,$mn,$s];
Packit 95306a
      } else {
Packit 95306a
         return undef;
Packit 95306a
      }
Packit 95306a
Packit 95306a
   } elsif ($op eq 'time') {
Packit 95306a
      if ($string =~ /^[-+]?\d+(:[-+]?\d+){0,2}$/o) {
Packit 95306a
         my($err,$dh,$dmn,$ds) = $self->_time_fields( { 'nonorm'   => $no_normalize,
Packit 95306a
                                                        'source'   => 'string',
Packit 95306a
                                                        'sign'     => -1,
Packit 95306a
                                                      }, [split(/:/,$string)]);
Packit 95306a
         return undef  if ($err);
Packit 95306a
         return [$dh,$dmn,$ds];
Packit 95306a
      } else {
Packit 95306a
         return undef;
Packit 95306a
      }
Packit 95306a
Packit 95306a
   } elsif ($op eq 'delta'  ||  $op eq 'business') {
Packit 95306a
      my($err,@delta) = $self->_split_delta($string);
Packit 95306a
      return undef  if ($err);
Packit 95306a
Packit 95306a
      ($err,@delta) = $self->_delta_fields( { 'business' =>
Packit 95306a
                                              ($op eq 'business' ? 1 : 0),
Packit 95306a
                                              'nonorm'   => $no_normalize,
Packit 95306a
                                              'source'   => 'string',
Packit 95306a
                                              'sign'     => -1,
Packit 95306a
                                            }, [@delta]);
Packit 95306a
Packit 95306a
      return undef  if ($err);
Packit 95306a
      return [@delta];
Packit 95306a
   }
Packit 95306a
}
Packit 95306a
Packit 95306a
sub join{
Packit 95306a
   my($self,$op,$data,$no_normalize) = @_;
Packit 95306a
   my @data = @$data;
Packit 95306a
Packit 95306a
   if ($op eq 'date') {
Packit 95306a
Packit 95306a
      my($err,$y,$m,$d,$h,$mn,$s) = $self->_date_fields(@data);
Packit 95306a
      return undef  if ($err);
Packit 95306a
      my $form = $self->_config('printable');
Packit 95306a
      if ($form == 1) {
Packit 95306a
         return "$y$m$d$h$mn$s";
Packit 95306a
      } elsif ($form == 2) {
Packit 95306a
         return "$y-$m-$d-$h:$mn:$s";
Packit 95306a
      } else {
Packit 95306a
         return "$y$m$d$h:$mn:$s";
Packit 95306a
      }
Packit 95306a
Packit 95306a
   } elsif ($op eq 'offset') {
Packit 95306a
      my($err,$h,$mn,$s) = $self->_offset_fields( { 'source' => 'list',
Packit 95306a
                                                    'out'    => 'string'},
Packit 95306a
                                                  [@data]);
Packit 95306a
      return undef  if ($err);
Packit 95306a
      return "$h:$mn:$s";
Packit 95306a
Packit 95306a
   } elsif ($op eq 'hms') {
Packit 95306a
      my($err,$h,$mn,$s) = $self->_hms_fields( { 'out' => 'string' },[@data]);
Packit 95306a
      return undef  if ($err);
Packit 95306a
      return "$h:$mn:$s";
Packit 95306a
Packit 95306a
   } elsif ($op eq 'time') {
Packit 95306a
      my($err,$dh,$dmn,$ds) = $self->_time_fields( { 'nonorm'   => $no_normalize,
Packit 95306a
                                                     'source'   => 'list',
Packit 95306a
                                                     'sign'     => 0,
Packit 95306a
                                                   }, [@data]);
Packit 95306a
      return undef  if ($err);
Packit 95306a
      return "$dh:$dmn:$ds";
Packit 95306a
Packit 95306a
   } elsif ($op eq 'delta'  ||  $op eq 'business') {
Packit 95306a
      my ($err,@delta) = $self->_delta_fields( { 'business' =>
Packit 95306a
                                                 ($op eq 'business' ? 1 : 0),
Packit 95306a
                                                 'nonorm'   => $no_normalize,
Packit 95306a
                                                 'source'   => 'list',
Packit 95306a
                                                 'sign'     => 0,
Packit 95306a
                                               }, [@data]);
Packit 95306a
      return undef  if ($err);
Packit 95306a
      return join(':',@delta);
Packit 95306a
   }
Packit 95306a
}
Packit 95306a
Packit 95306a
sub _split_delta {
Packit 95306a
   my($self,$string) = @_;
Packit 95306a
Packit 95306a
   my $sign    = '[-+]?';
Packit 95306a
   my $num     = '(?:\d+(?:\.\d*)?|\.\d+)';
Packit 95306a
   my $f       = "(?:$sign$num)?";
Packit 95306a
Packit 95306a
   if ($string =~ /^$f(:$f){0,6}$/o) {
Packit 95306a
      $string =~ s/::/:0:/go;
Packit 95306a
      $string =~ s/^:/0:/o;
Packit 95306a
      $string =~ s/:$/:0/o;
Packit 95306a
      my(@delta) = split(/:/,$string);
Packit 95306a
      return(0,@delta);
Packit 95306a
   } else {
Packit 95306a
      return(1);
Packit 95306a
   }
Packit 95306a
}
Packit 95306a
Packit 95306a
# $opts = { business => 0/1,
Packit 95306a
#           nonorm   => 0/1,
Packit 95306a
#           source   => string, list
Packit 95306a
#           sign     => 0/1/-1
Packit 95306a
#         }
Packit 95306a
# $fields = [Y,M,W,D,H,Mn,S]
Packit 95306a
#
Packit 95306a
# This function formats the fields in a delta.
Packit 95306a
#
Packit 95306a
# If the business option is 1, treat it as a business delta.
Packit 95306a
#
Packit 95306a
# If the nonorm option is 1, fields are NOT normalized.  By
Packit 95306a
# default, they are normalized.
Packit 95306a
#
Packit 95306a
# If source is 'string', then the source of the fields is splitting
Packit 95306a
# a delta (so we need to handle carrying the signs).  If it's 'list',
Packit 95306a
# then the source is a valid delta, so each field is correctly signed
Packit 95306a
# already.
Packit 95306a
#
Packit 95306a
# If the sign option is 1, a sign is added to every field.  If the
Packit 95306a
# sign option is -1, all negative fields are signed.  If the sign
Packit 95306a
# option is 0, the minimum number of signs (for fields who's sign is
Packit 95306a
# different from the next higher field) will be added.
Packit 95306a
#
Packit 95306a
# It returns ($err,@fields)
Packit 95306a
#
Packit 95306a
sub _delta_fields {
Packit 95306a
   my($self,$opts,$fields) = @_;
Packit 95306a
   my @fields = @$fields;
Packit 95306a
   no integer;
Packit 95306a
Packit 95306a
   #
Packit 95306a
   # Make sure that all fields are defined, numerical, and that there
Packit 95306a
   # are 7 of them.
Packit 95306a
   #
Packit 95306a
Packit 95306a
   foreach my $f (@fields) {
Packit 95306a
      $f=0  if (! defined($f));
Packit 95306a
      return (1)  if ($f !~ /^[+-]?(?:\d+(?:\.\d*)?|\.\d+)$/o);
Packit 95306a
   }
Packit 95306a
   return (1)  if (@fields > 7);
Packit 95306a
   while (@fields < 7) {
Packit 95306a
      unshift(@fields,0);
Packit 95306a
   }
Packit 95306a
Packit 95306a
   #
Packit 95306a
   # Make sure each field is the correct sign so that the math will
Packit 95306a
   # work correctly.  Get rid of all positive signs and leading 0's.
Packit 95306a
   #
Packit 95306a
Packit 95306a
   if ($$opts{'source'} eq 'string') {
Packit 95306a
Packit 95306a
      # if the source is splitting a delta, not all fields are signed,
Packit 95306a
      # so we need to carry the negative signs.
Packit 95306a
Packit 95306a
      my $sign = '+';
Packit 95306a
      foreach my $f (@fields) {
Packit 95306a
         if ($f =~ /^([-+])/o) {
Packit 95306a
            $sign = $1;
Packit 95306a
         } else {
Packit 95306a
            $f = "$sign$f";
Packit 95306a
         }
Packit 95306a
         $f *= 1;
Packit 95306a
      }
Packit 95306a
Packit 95306a
   } else {
Packit 95306a
      foreach my $f (@fields) {
Packit 95306a
         $f *= 1;
Packit 95306a
      }
Packit 95306a
   }
Packit 95306a
Packit 95306a
   #
Packit 95306a
   # Normalize them.  Values will be signed only if they are
Packit 95306a
   # negative.  Handle fractional values.
Packit 95306a
   #
Packit 95306a
Packit 95306a
   my $nonorm = $$opts{'nonorm'};
Packit 95306a
   foreach my $f (@fields) {
Packit 95306a
      if ($f != int($f)) {
Packit 95306a
         $nonorm = 0;
Packit 95306a
         last;
Packit 95306a
      }
Packit 95306a
   }
Packit 95306a
Packit 95306a
   my($y,$m,$w,$d,$h,$mn,$s) = @fields;
Packit 95306a
   if (! $nonorm) {
Packit 95306a
      ($y,$m)           = $self->_normalize_ym($y,$m)    if ($y || $m);
Packit 95306a
      ($m,$w)           = $self->_normalize_mw($m,$w)    if (int($m) != $m);
Packit 95306a
      if ($$opts{'business'}) {
Packit 95306a
         ($w,$d)        = $self->_normalize_wd($w,$d,1)  if (int($w) != $w);
Packit 95306a
         ($d,$h,$mn,$s) = $self->_normalize_bus_dhms($d,$h,$mn,$s);
Packit 95306a
      } else {
Packit 95306a
         ($w,$d)        = $self->_normalize_wd($w,$d,0)  if ($w || $d);
Packit 95306a
         ($d,$h)        = $self->_normalize_dh($d,$h)    if (int($d) != $d);
Packit 95306a
         ($h,$mn,$s)    = $self->_normalize_hms($h,$mn,$s);
Packit 95306a
      }
Packit 95306a
   }
Packit 95306a
Packit 95306a
   #
Packit 95306a
   # Now make sure that the signs are included as appropriate.
Packit 95306a
   #
Packit 95306a
Packit 95306a
   if (! $$opts{'sign'}) {
Packit 95306a
      # Minimum number of signs
Packit 95306a
      my $sign;
Packit 95306a
      if ($y >= 0) {
Packit 95306a
         $sign = '+';
Packit 95306a
      } else {
Packit 95306a
         $sign = '-';
Packit 95306a
      }
Packit 95306a
      foreach my $f ($m,$w,$d,$h,$mn,$s) {
Packit 95306a
         if ($f > 0) {
Packit 95306a
            if ($sign eq '-') {
Packit 95306a
               $f    = "+$f";
Packit 95306a
               $sign = '+';
Packit 95306a
            }
Packit 95306a
Packit 95306a
         } elsif ($f < 0) {
Packit 95306a
            if ($sign eq '-') {
Packit 95306a
               $f *= -1;
Packit 95306a
            } else {
Packit 95306a
               $sign = '-';
Packit 95306a
            }
Packit 95306a
         }
Packit 95306a
      }
Packit 95306a
Packit 95306a
   } elsif ($$opts{'sign'} == 1) {
Packit 95306a
      # All fields signed
Packit 95306a
      foreach my $f ($y,$m,$w,$d,$h,$mn,$s) {
Packit 95306a
         $f = "+$f"  if ($f > 0);
Packit 95306a
      }
Packit 95306a
   }
Packit 95306a
Packit 95306a
   return (0,$y,$m,$w,$d,$h,$mn,$s);
Packit 95306a
}
Packit 95306a
Packit 95306a
# $opts = { out   => string, list
Packit 95306a
#         }
Packit 95306a
# $fields = [H,M,S]
Packit 95306a
#
Packit 95306a
# This function formats the fields in an HMS.
Packit 95306a
#
Packit 95306a
# If the out options is string, it prepares the fields to be joined (i.e.
Packit 95306a
# they are all 2 digits long).  Otherwise, they are just numerical values
Packit 95306a
# (not necessarily 2 digits long).
Packit 95306a
#
Packit 95306a
# HH:MN:SS is always between 00:00:00 and 24:00:00.
Packit 95306a
#
Packit 95306a
# It returns ($err,@fields)
Packit 95306a
#
Packit 95306a
sub _hms_fields {
Packit 95306a
   my($self,$opts,$fields) = @_;
Packit 95306a
   my @fields = @$fields;
Packit 95306a
Packit 95306a
   #
Packit 95306a
   # Make sure that all fields are defined, numerical (with no sign),
Packit 95306a
   # and that there are 3 of them.
Packit 95306a
   #
Packit 95306a
Packit 95306a
   foreach my $f (@fields) {
Packit 95306a
      $f=0  if (! $f);
Packit 95306a
      return (1)  if ($f !~ /^\d+$/o);
Packit 95306a
   }
Packit 95306a
   return (1)  if (@fields > 3);
Packit 95306a
   while (@fields < 3) {
Packit 95306a
      push(@fields,0);
Packit 95306a
   }
Packit 95306a
Packit 95306a
   #
Packit 95306a
   # Check validity.
Packit 95306a
   #
Packit 95306a
Packit 95306a
   my ($h,$m,$s) = @fields;
Packit 95306a
   return (1)  if ($h > 24  ||  $m > 59  ||  $s > 59  ||
Packit 95306a
                   ($h==24  &&  ($m > 0 ||  $s > 0)));
Packit 95306a
Packit 95306a
   #
Packit 95306a
   # Format
Packit 95306a
   #
Packit 95306a
Packit 95306a
   if ($$opts{'out'} eq 'list') {
Packit 95306a
      foreach my $f ($h,$m,$s) {
Packit 95306a
         $f *= 1;
Packit 95306a
      }
Packit 95306a
Packit 95306a
   } else {
Packit 95306a
      foreach my $f ($h,$m,$s) {
Packit 95306a
         $f = "0$f"  if (length($f)<2);
Packit 95306a
      }
Packit 95306a
   }
Packit 95306a
Packit 95306a
   return (0,$h,$m,$s);
Packit 95306a
}
Packit 95306a
Packit 95306a
# $opts = { nonorm   => 0/1,
Packit 95306a
#           source   => string, list
Packit 95306a
#           sign     => 0/1/-1
Packit 95306a
#         }
Packit 95306a
# $fields = [H,M,S]
Packit 95306a
#
Packit 95306a
# This function formats the fields in an amount of time measured in
Packit 95306a
# hours, minutes, and seconds.
Packit 95306a
#
Packit 95306a
# It is similar to how _delta_fields (above) works.
Packit 95306a
#
Packit 95306a
sub _time_fields {
Packit 95306a
   my($self,$opts,$fields) = @_;
Packit 95306a
   my @fields = @$fields;
Packit 95306a
Packit 95306a
   #
Packit 95306a
   # Make sure that all fields are defined, numerical, and that there
Packit 95306a
   # are 3 of them.
Packit 95306a
   #
Packit 95306a
Packit 95306a
   foreach my $f (@fields) {
Packit 95306a
      $f=0  if (! defined($f));
Packit 95306a
      return (1)  if ($f !~ /^[+-]?\d+$/o);
Packit 95306a
   }
Packit 95306a
   return (1)  if (@fields > 3);
Packit 95306a
   while (@fields < 3) {
Packit 95306a
      unshift(@fields,0);
Packit 95306a
   }
Packit 95306a
Packit 95306a
   #
Packit 95306a
   # Make sure each field is the correct sign so that the math will
Packit 95306a
   # work correctly.  Get rid of all positive signs and leading 0's.
Packit 95306a
   #
Packit 95306a
Packit 95306a
   if ($$opts{'source'} eq 'string') {
Packit 95306a
Packit 95306a
      # If the source is splitting a string, not all fields are signed,
Packit 95306a
      # so we need to carry the negative signs.
Packit 95306a
Packit 95306a
      my $sign = '+';
Packit 95306a
      foreach my $f (@fields) {
Packit 95306a
         if ($f =~ /^([-+])/o) {
Packit 95306a
            $sign = $1;
Packit 95306a
         } else {
Packit 95306a
            $f = "$sign$f";
Packit 95306a
         }
Packit 95306a
         $f *= 1;
Packit 95306a
      }
Packit 95306a
Packit 95306a
   } else {
Packit 95306a
      foreach my $f (@fields) {
Packit 95306a
         $f *= 1;
Packit 95306a
      }
Packit 95306a
   }
Packit 95306a
Packit 95306a
   #
Packit 95306a
   # Normalize them.  Values will be signed only if they are
Packit 95306a
   # negative.
Packit 95306a
   #
Packit 95306a
Packit 95306a
   my($h,$mn,$s) = @fields;
Packit 95306a
   unless ($$opts{'nonorm'}) {
Packit 95306a
      ($h,$mn,$s)       = $self->_normalize_hms($h,$mn,$s);
Packit 95306a
   }
Packit 95306a
Packit 95306a
   #
Packit 95306a
   # Now make sure that the signs are included as appropriate.
Packit 95306a
   #
Packit 95306a
Packit 95306a
   if (! $$opts{'sign'}) {
Packit 95306a
      # Minimum number of signs
Packit 95306a
      my $sign;
Packit 95306a
      if ($h >= 0) {
Packit 95306a
         $sign = '+';
Packit 95306a
      } else {
Packit 95306a
         $sign = '-';
Packit 95306a
      }
Packit 95306a
      foreach my $f ($mn,$s) {
Packit 95306a
         if ($f > 0) {
Packit 95306a
            if ($sign eq '-') {
Packit 95306a
               $f    = "+$f";
Packit 95306a
               $sign = '+';
Packit 95306a
            }
Packit 95306a
Packit 95306a
         } elsif ($f < 0) {
Packit 95306a
            if ($sign eq '-') {
Packit 95306a
               $f *= -1;
Packit 95306a
            } else {
Packit 95306a
               $sign = '-';
Packit 95306a
            }
Packit 95306a
         }
Packit 95306a
      }
Packit 95306a
Packit 95306a
   } elsif ($$opts{'sign'} == 1) {
Packit 95306a
      # All fields signed
Packit 95306a
      foreach my $f ($h,$mn,$s) {
Packit 95306a
         $f = "+$f"  if ($f > 0);
Packit 95306a
      }
Packit 95306a
   }
Packit 95306a
Packit 95306a
   return (0,$h,$mn,$s);
Packit 95306a
}
Packit 95306a
Packit 95306a
# $opts = { source     => string, list
Packit 95306a
#           out        => string, list
Packit 95306a
#         }
Packit 95306a
# $fields = [H,M,S]
Packit 95306a
#
Packit 95306a
# This function formats the fields in a timezone offset measured in
Packit 95306a
# hours, minutes, and seconds.
Packit 95306a
#
Packit 95306a
# All offsets must be -23:59:59 <= offset <= 23:59:59 .
Packit 95306a
#
Packit 95306a
# The data comes from an offset in string or list format, and is
Packit 95306a
# formatted so that it can be used to create a string or list format
Packit 95306a
# output.
Packit 95306a
#
Packit 95306a
sub _offset_fields {
Packit 95306a
   my($self,$opts,$fields) = @_;
Packit 95306a
   my @fields = @$fields;
Packit 95306a
Packit 95306a
   #
Packit 95306a
   # Make sure that all fields are defined, numerical, and that there
Packit 95306a
   # are 3 of them.
Packit 95306a
   #
Packit 95306a
Packit 95306a
   foreach my $f (@fields) {
Packit 95306a
      $f=0  if (! defined $f  ||  $f eq '');
Packit 95306a
      return (1)  if ($f !~ /^[+-]?\d+$/o);
Packit 95306a
   }
Packit 95306a
   return (1)  if (@fields > 3);
Packit 95306a
   while (@fields < 3) {
Packit 95306a
      push(@fields,0);
Packit 95306a
   }
Packit 95306a
Packit 95306a
   #
Packit 95306a
   # Check validity.
Packit 95306a
   #
Packit 95306a
Packit 95306a
   my ($h,$m,$s) = @fields;
Packit 95306a
   if ($$opts{'source'} eq 'string') {
Packit 95306a
      # Values = -23 59 59 to +23 59 59
Packit 95306a
      return (1)  if ($h < -23  ||  $h > 23  ||
Packit 95306a
                      $m < 0    ||  $m > 59  ||
Packit 95306a
                      $s < 0    ||  $s > 59);
Packit 95306a
   } else {
Packit 95306a
      # Values (-23,-59,-59) to (23,59,59)
Packit 95306a
      # Non-zero values must have the same sign
Packit 95306a
      if ($h >0) {
Packit 95306a
         return (1)  if (              $h > 23  ||
Packit 95306a
                         $m < 0    ||  $m > 59  ||
Packit 95306a
                         $s < 0    ||  $s > 59);
Packit 95306a
      } elsif ($h < 0) {
Packit 95306a
         return (1)  if ($h < -23  ||
Packit 95306a
                         $m < -59  ||  $m > 0   ||
Packit 95306a
                         $s < -59  ||  $s > 0);
Packit 95306a
      } elsif ($m > 0) {
Packit 95306a
         return (1)  if (              $m > 59  ||
Packit 95306a
                         $s < 0    ||  $s > 59);
Packit 95306a
      } elsif ($m < 0) {
Packit 95306a
         return (1)  if ($m < -59  ||
Packit 95306a
                         $s < -59  ||  $s > 0);
Packit 95306a
      } else {
Packit 95306a
         return (1)  if ($s < -59  ||  $s > 59);
Packit 95306a
      }
Packit 95306a
   }
Packit 95306a
Packit 95306a
   #
Packit 95306a
   # Make sure each field is the correct sign so that the math will
Packit 95306a
   # work correctly.  Get rid of all positive signs and leading 0's.
Packit 95306a
   #
Packit 95306a
Packit 95306a
   if ($$opts{'source'} eq 'string') {
Packit 95306a
Packit 95306a
      # In a string offset, only the first field is signed, so we need
Packit 95306a
      # to carry negative signs.
Packit 95306a
Packit 95306a
      if ($h =~ /^\-/) {
Packit 95306a
         $h *= 1;
Packit 95306a
         $m *= -1;
Packit 95306a
         $s *= -1;
Packit 95306a
      } elsif ($m =~ /^\-/) {
Packit 95306a
         $h *= 1;
Packit 95306a
         $m *= 1;
Packit 95306a
         $s *= -1;
Packit 95306a
      } else {
Packit 95306a
         $h *= 1;
Packit 95306a
         $m *= 1;
Packit 95306a
         $s *= 1;
Packit 95306a
      }
Packit 95306a
Packit 95306a
   } else {
Packit 95306a
      foreach my $f (@fields) {
Packit 95306a
         $f *= 1;
Packit 95306a
      }
Packit 95306a
   }
Packit 95306a
Packit 95306a
   #
Packit 95306a
   # Format them.  They're already done for 'list' output.
Packit 95306a
   #
Packit 95306a
Packit 95306a
   if ($$opts{'out'} eq 'string') {
Packit 95306a
      my $sign;
Packit 95306a
      if ($h<0 || $m<0 || $s<0) {
Packit 95306a
         $h = abs($h);
Packit 95306a
         $m = abs($m);
Packit 95306a
         $s = abs($s);
Packit 95306a
         $sign = '-';
Packit 95306a
      } else {
Packit 95306a
         $sign = '+';
Packit 95306a
      }
Packit 95306a
Packit 95306a
      $h = "0$h"  if (length($h) < 2);
Packit 95306a
      $m = "0$m"  if (length($m) < 2);
Packit 95306a
      $s = "0$s"  if (length($s) < 2);
Packit 95306a
      $h = "$sign$h";
Packit 95306a
   }
Packit 95306a
Packit 95306a
   return (0,$h,$m,$s);
Packit 95306a
}
Packit 95306a
Packit 95306a
# ($err,$y,$m,$d,$h,$mn,$s) = $self->_date_fields($y,$m,$d,$h,$mn,$s);
Packit 95306a
#
Packit 95306a
# Makes sure the fields are the right length.
Packit 95306a
#
Packit 95306a
sub _date_fields {
Packit 95306a
   my($self,@fields) = @_;
Packit 95306a
   return (1)  if (@fields != 6);
Packit 95306a
Packit 95306a
   my($y,$m,$d,$h,$mn,$s) = @fields;
Packit 95306a
Packit 95306a
   $y = "0$y"     while (length($y) < 4);
Packit 95306a
   $m  = "0$m"    if (length($m)==1);
Packit 95306a
   $d  = "0$d"    if (length($d)==1);
Packit 95306a
   $h  = "0$h"    if (length($h)==1);
Packit 95306a
   $mn = "0$mn"   if (length($mn)==1);
Packit 95306a
   $s  = "0$s"    if (length($s)==1);
Packit 95306a
Packit 95306a
   if (wantarray) {
Packit 95306a
      return (0,$y,$m,$d,$h,$mn,$s);
Packit 95306a
   } else {
Packit 95306a
      return "$y$m$d$h:$mn:$s";
Packit 95306a
   }
Packit 95306a
}
Packit 95306a
Packit 95306a
sub _normalize_ym {
Packit 95306a
   my($self,$y,$m) = @_;
Packit 95306a
   no integer;
Packit 95306a
Packit 95306a
   $m += $y*12;
Packit 95306a
   $y  = int($m/12);
Packit 95306a
   $m -= $y*12;
Packit 95306a
Packit 95306a
   return ($y,$m);
Packit 95306a
}
Packit 95306a
Packit 95306a
# This is only used for deltas with fractional months.
Packit 95306a
#
Packit 95306a
sub _normalize_mw {
Packit 95306a
   my($self,$m,$w) = @_;
Packit 95306a
   no integer;
Packit 95306a
Packit 95306a
   my $d  = ($m-int($m)) * $$self{'data'}{'len'}{'yrlen'}/12;
Packit 95306a
   $w    += $d/7;
Packit 95306a
   $m     = int($m);
Packit 95306a
Packit 95306a
   return ($m,$w);
Packit 95306a
}
Packit 95306a
Packit 95306a
sub _normalize_bus_dhms {
Packit 95306a
   my($self,$d,$h,$mn,$s) = @_;
Packit 95306a
   no integer;
Packit 95306a
Packit 95306a
   my $dl = $$self{'data'}{'len'}{'1'}{'dl'};
Packit 95306a
Packit 95306a
   $s  += $d*$dl + $h*3600 + $mn*60;
Packit 95306a
   $d   = int($s/$dl);
Packit 95306a
   $s  -= $d*$dl;
Packit 95306a
Packit 95306a
   $mn  = int($s/60);
Packit 95306a
   $s  -= $mn*60;
Packit 95306a
   $s   = int($s);
Packit 95306a
Packit 95306a
   $h   = int($mn/60);
Packit 95306a
   $mn -= $h*60;
Packit 95306a
Packit 95306a
   return ($d,$h,$mn,$s);
Packit 95306a
}
Packit 95306a
Packit 95306a
sub _normalize_hms {
Packit 95306a
   my($self,$h,$mn,$s) = @_;
Packit 95306a
   no integer;
Packit 95306a
Packit 95306a
   $s  += $h*3600 + $mn*60;
Packit 95306a
   $mn  = int($s/60);
Packit 95306a
   $s  -= $mn*60;
Packit 95306a
   $s   = int($s);
Packit 95306a
Packit 95306a
   $h   = int($mn/60);
Packit 95306a
   $mn -= $h*60;
Packit 95306a
Packit 95306a
   return ($h,$mn,$s);
Packit 95306a
}
Packit 95306a
Packit 95306a
# Business deltas only mix week and day if the week has a fractional
Packit 95306a
# part.
Packit 95306a
#
Packit 95306a
sub _normalize_wd {
Packit 95306a
   my($self,$w,$d,$business) = @_;
Packit 95306a
   no integer;
Packit 95306a
Packit 95306a
   my $weeklen = ($business ? $$self{'data'}{'len'}{'workweek'} : 7);
Packit 95306a
Packit 95306a
   $d += $w*$weeklen;
Packit 95306a
   $w  = int($d/$weeklen);
Packit 95306a
   $d -= $w*$weeklen;
Packit 95306a
Packit 95306a
   return ($w,$d);
Packit 95306a
}
Packit 95306a
Packit 95306a
# This is only done for non-business days with a fractional part.
Packit 95306a
# part.
Packit 95306a
#
Packit 95306a
sub _normalize_dh {
Packit 95306a
   my($self,$d,$h) = @_;
Packit 95306a
   no integer;
Packit 95306a
Packit 95306a
   $h += $d*24;
Packit 95306a
   $d  = int($h/24);
Packit 95306a
   $h -= $d*24;
Packit 95306a
Packit 95306a
   return ($d,$h);
Packit 95306a
}
Packit 95306a
Packit 95306a
# $self->_delta_convert(FORMAT,DELTA)
Packit 95306a
#    This converts delta into the given format. Returns '' if invalid.
Packit 95306a
#
Packit 95306a
sub _delta_convert {
Packit 95306a
   my($self,$format,$delta)=@_;
Packit 95306a
   my $fields = $self->split($format,$delta);
Packit 95306a
   return undef  if (! defined $fields);
Packit 95306a
   return $self->join($format,$fields);
Packit 95306a
}
Packit 95306a
Packit 95306a
###############################################################################
Packit 95306a
# Timezone critical dates
Packit 95306a
Packit 95306a
# NOTE: Although I would prefer to stick this routine in the
Packit 95306a
# Date::Manip::TZ module where it would be more appropriate, it must
Packit 95306a
# appear here as it will be used to generate the data that will be
Packit 95306a
# used by the Date::Manip::TZ module.
Packit 95306a
#
Packit 95306a
# This calculates a critical date based on timezone information. The
Packit 95306a
# critical date is the date (usually in the current time) at which
Packit 95306a
# the current timezone period ENDS.
Packit 95306a
#
Packit 95306a
# Input is:
Packit 95306a
#    $year,$mon,$flag,$num,$dow
Packit 95306a
#       This is information from the appropriate Rule line from the
Packit 95306a
#       zoneinfo files. These are used to determine the date (Y/M/D)
Packit 95306a
#       when the timezone period will end.
Packit 95306a
#    $isdst
Packit 95306a
#       Whether or not the next timezone period is a Daylight Saving
Packit 95306a
#       Time period.
Packit 95306a
#    $time,$timetype
Packit 95306a
#       The time of day when the change occurs. The timetype can be
Packit 95306a
#       'w' (wallclock time in the current period), 's' (standard
Packit 95306a
#       time which will match wallclock time in a non-DST period, or
Packit 95306a
#       be off an hour in a DST period), and 'u' (universal time).
Packit 95306a
#
Packit 95306a
# Output is:
Packit 95306a
#    $endUT, $endLT, $begUT, $begLT
Packit 95306a
#       endUT is the actual last second of the current timezone
Packit 95306a
#       period.  endLT is the same time expressed in local time.
Packit 95306a
#       begUT is the start (in UT) of the next time period. Note that
Packit 95306a
#       the begUT date is the one which actually corresponds to the
Packit 95306a
#       date/time specified in the input. begLT is the time in the new
Packit 95306a
#       local time. The endUT/endLT are the time one second earlier.
Packit 95306a
#
Packit 95306a
sub _critical_date {
Packit 95306a
   my($self,$year,$mon,$flag,$num,$dow,
Packit 95306a
      $isdst,$time,$timetype,$stdoff,$dstoff) = @_;
Packit 95306a
Packit 95306a
   #
Packit 95306a
   # Get the predicted Y/M/D
Packit 95306a
   #
Packit 95306a
Packit 95306a
   my($y,$m,$d) = ($year+0,$mon+0,1);
Packit 95306a
Packit 95306a
   if ($flag eq 'dom') {
Packit 95306a
      $d = $num;
Packit 95306a
Packit 95306a
   } elsif ($flag eq 'last') {
Packit 95306a
      my $ymd = $self->nth_day_of_week($year,-1,$dow,$mon);
Packit 95306a
      $d = $$ymd[2];
Packit 95306a
Packit 95306a
   } elsif ($flag eq 'ge') {
Packit 95306a
      my $ymd = $self->nth_day_of_week($year,1,$dow,$mon);
Packit 95306a
      $d = $$ymd[2];
Packit 95306a
      while ($d < $num) {
Packit 95306a
         $d += 7;
Packit 95306a
      }
Packit 95306a
Packit 95306a
   } elsif ($flag eq 'le') {
Packit 95306a
      my $ymd = $self->nth_day_of_week($year,-1,$dow,$mon);
Packit 95306a
      $d = $$ymd[2];
Packit 95306a
      while ($d > $num) {
Packit 95306a
         $d -= 7;
Packit 95306a
      }
Packit 95306a
   }
Packit 95306a
Packit 95306a
   #
Packit 95306a
   # Get the predicted time and the date (not yet taking into
Packit 95306a
   # account time type).
Packit 95306a
   #
Packit 95306a
Packit 95306a
   my($h,$mn,$s) = @{ $self->split('hms',$time) };
Packit 95306a
   my $date      = [ $y,$m,$d,$h,$mn,$s ];
Packit 95306a
Packit 95306a
   #
Packit 95306a
   # Calculate all the relevant dates.
Packit 95306a
   #
Packit 95306a
Packit 95306a
   my($endUT,$endLT,$begUT,$begLT,$offset);
Packit 95306a
   $stdoff = $self->split('offset',$stdoff);
Packit 95306a
   $dstoff = $self->split('offset',$dstoff);
Packit 95306a
Packit 95306a
   if ($timetype eq 'w') {
Packit 95306a
      $begUT = $self->calc_date_time($date,($isdst ? $stdoff : $dstoff), 1);
Packit 95306a
   } elsif ($timetype eq 'u') {
Packit 95306a
      $begUT = $date;
Packit 95306a
   } else {
Packit 95306a
      $begUT = $self->calc_date_time($date,$stdoff, 1);
Packit 95306a
   }
Packit 95306a
Packit 95306a
   $endUT    = $self->calc_date_time($begUT,[0,0,-1]);
Packit 95306a
   $endLT    = $self->calc_date_time($endUT,($isdst ? $stdoff : $dstoff));
Packit 95306a
   $begLT    = $self->calc_date_time($begUT,($isdst ? $dstoff : $stdoff));
Packit 95306a
Packit 95306a
   return ($endUT,$endLT,$begUT,$begLT);
Packit 95306a
}
Packit 95306a
Packit 95306a
###############################################################################
Packit 95306a
# Get a list of strings to try to parse.
Packit 95306a
Packit 95306a
sub _encoding {
Packit 95306a
   my($self,$string) = @_;
Packit 95306a
   my @ret;
Packit 95306a
Packit 95306a
   foreach my $enc (@{ $$self{'data'}{'calc'}{'enc_in'} }) {
Packit 95306a
      if (lc($enc) eq 'utf-8') {
Packit 95306a
         _utf8_on($string);
Packit 95306a
         push(@ret,$string) if is_utf8($string, 1);
Packit 95306a
      } elsif (lc($enc) eq 'perl') {
Packit 95306a
         push(@ret,encode_utf8($string));
Packit 95306a
      } else {
Packit 95306a
         my $tmp = $string;
Packit 95306a
         _utf8_off($tmp);
Packit 95306a
         $tmp = encode_utf8(decode($enc, $tmp));
Packit 95306a
         _utf8_on($tmp);
Packit 95306a
         push(@ret,$tmp) if is_utf8($tmp, 1);;
Packit 95306a
      }
Packit 95306a
   }
Packit 95306a
Packit 95306a
   return @ret;
Packit 95306a
}
Packit 95306a
Packit 95306a
1;
Packit 95306a
# Local Variables:
Packit 95306a
# mode: cperl
Packit 95306a
# indent-tabs-mode: nil
Packit 95306a
# cperl-indent-level: 3
Packit 95306a
# cperl-continued-statement-offset: 2
Packit 95306a
# cperl-continued-brace-offset: 0
Packit 95306a
# cperl-brace-offset: 0
Packit 95306a
# cperl-brace-imaginary-offset: 0
Packit 95306a
# cperl-label-offset: 0
Packit 95306a
# End: